Skip to content

Commit b486d4f

Browse files
bensbens
committed
Add connectdbParams and other connection key-value functions
Added a `Storable` instance for an equivalent to `PQconninfoOption` and bindings for the functions that use the struct: - PQconnectdbParams - PQconndefaults - PQconninfo - PQconninfoParse - PQconninfoFree Also added some wrappers which do a minimum of conversion to `ByteString`s and make sure memory isn't leaked.
1 parent a9122f8 commit b486d4f

File tree

4 files changed

+225
-48
lines changed

4 files changed

+225
-48
lines changed

‎postgresql-libpq.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -63,6 +63,7 @@ library
6363

6464
other-modules:
6565
Database.PostgreSQL.LibPQ.Compat
66+
Database.PostgreSQL.LibPQ.Connect
6667
Database.PostgreSQL.LibPQ.Enums
6768
Database.PostgreSQL.LibPQ.FFI
6869
Database.PostgreSQL.LibPQ.Marshal

‎src/Database/PostgreSQL/LibPQ.hs

+113-43
Original file line numberDiff line numberDiff line change
@@ -52,12 +52,15 @@ module Database.PostgreSQL.LibPQ
5252
-- $dbconn
5353
Connection
5454
, connectdb
55+
, connectdbParams
5556
, connectStart
5657
, connectPoll
5758
, newNullConnection
5859
, isNullConnection
59-
--, conndefaults
60-
--, conninfoParse
60+
, ConninfoOption(..)
61+
, conndefaults
62+
, conninfo
63+
, conninfoParse
6164
, reset
6265
, resetStart
6366
, resetPoll
@@ -222,25 +225,30 @@ module Database.PostgreSQL.LibPQ
222225
)
223226
where
224227

228+
import Control.Monad (when)
229+
import Control.Monad.IO.Class (MonadIO(liftIO))
225230
import Control.Concurrent.MVar (MVar, newMVar, swapMVar, tryTakeMVar, withMVar)
226231
import Control.Exception (mask_)
232+
import Foreign.C.ConstPtr (ConstPtr (..))
227233
import Foreign.C.String (CString, CStringLen, withCString)
228234
import Foreign.C.Types (CInt (..))
229235
import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, newForeignPtr, newForeignPtr_, touchForeignPtr, withForeignPtr)
230-
import Foreign.Marshal (alloca, allocaBytes, finalizerFree, free, mallocBytes, maybeWith, reallocBytes, withArrayLen, withMany)
231-
import Foreign.Ptr (Ptr, castPtr, nullPtr)
232-
import Foreign.Storable (Storable (peek))
236+
import Foreign.Marshal (alloca, allocaBytes, finalizerFree, free, mallocBytes, maybeWith, reallocBytes, withArray0, withArrayLen, withMany)
237+
import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr)
238+
import Foreign.Storable (Storable (peek, sizeOf))
233239
import GHC.Conc (closeFdWith)
234240
import System.IO (IOMode (..), SeekMode (..))
235241
import System.Posix.Types (CPid, Fd (..))
236242

237243
import qualified Data.ByteString as B
244+
import qualified Data.ByteString.Char8 as B8
238245
import qualified Data.ByteString.Internal as B (c_strlen, createAndTrim, fromForeignPtr)
239246
import qualified Data.ByteString.Unsafe as B
240247
import qualified Foreign.Concurrent as FC
241248
import qualified Foreign.ForeignPtr.Unsafe as Unsafe
242249

243250
import Database.PostgreSQL.LibPQ.Compat
251+
import Database.PostgreSQL.LibPQ.Connect
244252
import Database.PostgreSQL.LibPQ.Enums
245253
import Database.PostgreSQL.LibPQ.FFI
246254
import Database.PostgreSQL.LibPQ.Internal
@@ -274,16 +282,55 @@ import Database.PostgreSQL.LibPQ.Ptr
274282
-- value must be escaped with a backslash, i.e., \' and \\.
275283
connectdb :: B.ByteString -- ^ Connection Info
276284
-> IO Connection
277-
connectdb conninfo =
285+
connectdb connStr =
278286
mask_ $ do
279-
connPtr <- B.useAsCString conninfo c_PQconnectdb
287+
connPtr <- B.useAsCString connStr c_PQconnectdb
280288
if connPtr == nullPtr
281289
then fail "libpq failed to allocate a PGconn structure"
282290
else do
283291
noticeBuffer <- newMVar nullPtr
284292
connection <- newForeignPtrOnce connPtr (pqfinish connPtr noticeBuffer)
285293
return $! Conn connection noticeBuffer
286294

295+
-- Include an implementation of the ContT transformer here to avoid a dependency
296+
-- on transformers.
297+
newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r}
298+
299+
instance Functor (ContT r m) where
300+
fmap f m = ContT $ \c -> runContT m (c . f)
301+
302+
instance (Applicative m) => Applicative (ContT r m) where
303+
pure x = ContT ($ x)
304+
fm <*> xm = ContT $ \c -> runContT fm (\f -> runContT xm (c . f))
305+
306+
instance (Monad m) => Monad (ContT r m) where
307+
return = pure
308+
m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c)
309+
310+
instance (MonadIO m) => MonadIO (ContT r m) where
311+
liftIO m = ContT (liftIO m >>=)
312+
313+
-- | This function opens a new database connection using the parameters taken
314+
-- from the list of key word and value pairs.
315+
connectdbParams :: [(B.ByteString, B.ByteString)] -- ^ Connection Info
316+
-> Bool -- ^ Expand database name
317+
-> IO Connection
318+
connectdbParams connOpts expandDBName =
319+
mask_ $ flip runContT pure $ do
320+
keys <- fmap ConstPtr $ do
321+
xs <- mapM (ContT . B.useAsCString) (map fst connOpts)
322+
ContT (withArray0 (ConstPtr nullPtr) (fmap ConstPtr xs))
323+
values <- fmap ConstPtr $ do
324+
xs <- mapM (ContT . B.useAsCString) (map snd connOpts)
325+
ContT (withArray0 (ConstPtr nullPtr) (fmap ConstPtr xs))
326+
connPtr <- liftIO $ c_PQconnectdbParams keys values (if expandDBName then 1 else 0)
327+
liftIO $ if connPtr == nullPtr
328+
then fail "libpq failed to allocate a PGconn structure"
329+
else do
330+
noticeBuffer <- newMVar nullPtr
331+
connection <- newForeignPtrOnce connPtr (pqfinish connPtr noticeBuffer)
332+
return $! Conn connection noticeBuffer
333+
287334
-- | Make a connection to the database server in a nonblocking manner.
288335
connectStart :: B.ByteString -- ^ Connection Info
289336
-> IO Connection
@@ -356,42 +403,65 @@ connectPoll :: Connection
356403
-> IO PollingStatus
357404
connectPoll = pollHelper c_PQconnectPoll
358405

359-
360-
-- PQconndefaults
361-
-- Returns the default connection options.
362-
363-
-- PQconninfoOption *PQconndefaults(void);
364-
365-
-- typedef struct
366-
-- {
367-
-- char *keyword; /* The keyword of the option */
368-
-- char *envvar; /* Fallback environment variable name */
369-
-- char *compiled; /* Fallback compiled in default value */
370-
-- char *val; /* Option's current value, or NULL */
371-
-- char *label; /* Label for field in connect dialog */
372-
-- char *dispchar; /* Indicates how to display this field
373-
-- in a connect dialog. Values are:
374-
-- "" Display entered value as is
375-
-- "*" Password field - hide value
376-
-- "D" Debug option - don't show by default */
377-
-- int dispsize; /* Field size in characters for dialog */
378-
-- } PQconninfoOption;
379-
-- Returns a connection options array. This can be used to determine all possible PQconnectdb options and their current default values. The return value points to an array of PQconninfoOption structures, which ends with an entry having a null keyword pointer. The null pointer is returned if memory could not be allocated. Note that the current default values (val fields) will depend on environment variables and other context. Callers must treat the connection options data as read-only.
380-
381-
-- After processing the options array, free it by passing it to PQconninfoFree. If this is not done, a small amount of memory is leaked for each call to PQconndefaults.
382-
383-
-- PQconninfoParse
384-
-- Returns parsed connection options from the provided connection string.
385-
386-
-- PQconninfoOption *PQconninfoParse(const char *conninfo, char **errmsg);
387-
-- Parses a connection string and returns the resulting options as an array; or returns NULL if there is a problem with the connection string. This can be used to determine the PQconnectdb options in the provided connection string. The return value points to an array of PQconninfoOption structures, which ends with an entry having a null keyword pointer.
388-
389-
-- Note that only options explicitly specified in the string will have values set in the result array; no defaults are inserted.
390-
391-
-- If errmsg is not NULL, then *errmsg is set to NULL on success, else to a malloc'd error string explaining the problem. (It is also possible for *errmsg to be set to NULL even when NULL is returned; this indicates an out-of-memory situation.)
392-
393-
-- After processing the options array, free it by passing it to PQconninfoFree. If this is not done, some memory is leaked for each call to PQconninfoParse. Conversely, if an error occurs and errmsg is not NULL, be sure to free the error string using PQfreemem.
394-
406+
-- | Returns a connection options list. This can be used to determine all
407+
-- possible 'connectdb' options and their current default values. Note that the
408+
-- current default values ('conninfoValue' fields) will depend on environment
409+
-- variables and other context.
410+
conndefaults :: IO [ConninfoOption]
411+
conndefaults = do
412+
mask_ $ getConnInfos =<< c_PQconndefaults
413+
414+
-- | Parses a connection string and returns the resulting options as a list.
415+
-- This can be used to determine the 'connectdb' options in the provided
416+
-- connection string.
417+
--
418+
-- Note that only options explicitly specified in the string will have values
419+
-- set in the result array; no defaults are inserted.
420+
conninfoParse :: B.ByteString -- ^ Connection String
421+
-> IO [ConninfoOption]
422+
conninfoParse connStr =
423+
mask_ $ flip runContT pure $ do
424+
(connPtr :: CString) <- ContT $ B.useAsCString connStr
425+
(errmsgPtr :: Ptr CString) <- ContT alloca
426+
liftIO $ do
427+
p <- c_PQconninfoParse connPtr errmsgPtr
428+
-- If errmsg is not NULL, then *errmsg is set to NULL on success,
429+
-- else to a malloc'd error string explaining the problem. (It is
430+
-- also possible for *errmsg to be set to NULL even when NULL is
431+
-- returned; this indicates an out-of-memory situation.)
432+
errmsgC <- peek errmsgPtr
433+
-- If an error occurs and errmsg is not NULL, be sure to free the
434+
-- error string using PQfreemem.
435+
when (errmsgC /= nullPtr) $ do
436+
errmsg <- B8.unpack <$> B.packCString errmsgC
437+
c_PQfreemem errmsgC
438+
fail errmsg
439+
getConnInfos p
440+
441+
-- | Returns a connection options list. This can be used to determine all
442+
-- possible 'connectdb' options and the values that were used to connect to the
443+
-- server. All notes above for 'conndefaults' also apply to the result of
444+
-- 'conninfo'.
445+
conninfo :: Connection -> IO [ConninfoOption]
446+
conninfo connection = withConn connection $ \pgconn -> do
447+
mask_ $ getConnInfos =<< c_PQconninfo pgconn
448+
449+
-- | Marshal from an array pointer to PQconninfoOption to a list of
450+
-- ConninfoOptions.
451+
getConnInfos :: Ptr PQconninfoOption -> IO [ConninfoOption]
452+
getConnInfos ptr =
453+
-- After processing the options array, free it by passing it to
454+
-- PQconninfoFree. If this is not done, a small amount of memory is leaked
455+
-- for each call to PQconndefaults.
456+
if ptr == nullPtr then pure [] else go [] ptr <* c_PQconninfoFree ptr
457+
where
458+
go xs p = do
459+
(keyword :: CString) <- peek (plusPtr p pqConninfoOptionKeyword)
460+
if keyword == nullPtr
461+
then pure (reverse xs)
462+
else do
463+
(x :: ConninfoOption) <- peek (castPtr p)
464+
go (x:xs) (plusPtr p (sizeOf x))
395465

396466
-- | Resets the communication channel to the server.
397467
--

‎src/Database/PostgreSQL/LibPQ/Connect.hsc

+89
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,89 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
4+
module Database.PostgreSQL.LibPQ.Connect where
5+
6+
#include "hs-libpq.h"
7+
8+
import Foreign (Storable (..), nullPtr)
9+
import Foreign.C (CInt)
10+
11+
import qualified Data.ByteString as B
12+
13+
-------------------------------------------------------------------------------
14+
-- ConninfoOption
15+
-------------------------------------------------------------------------------
16+
17+
-- typedef struct
18+
-- {
19+
-- char *keyword; /* The keyword of the option */
20+
-- char *envvar; /* Fallback environment variable name */
21+
-- char *compiled; /* Fallback compiled in default value */
22+
-- char *val; /* Option's current value, or NULL */
23+
-- char *label; /* Label for field in connect dialog */
24+
-- char *dispchar; /* Indicates how to display this field
25+
-- in a connect dialog. Values are:
26+
-- "" Display entered value as is
27+
-- "*" Password field - hide value
28+
-- "D" Debug option - don't show by default */
29+
-- int dispsize; /* Field size in characters for dialog */
30+
-- } PQconninfoOption;
31+
data ConninfoOption = ConninfoOption {
32+
conninfoKeyword :: B.ByteString -- ^ The keyword of the option
33+
, conninfoEnvVar :: Maybe B.ByteString -- ^ Fallback environment variable name
34+
, conninfoCompiled :: Maybe B.ByteString -- ^ Fallback compiled in default value
35+
, conninfoValue :: Maybe B.ByteString -- ^ Option's current value, or NULL
36+
, conninfoLabel :: B.ByteString -- ^ Label for field in connect dialog
37+
-- | Indicates how to display this field in a connect dialog. Values are:
38+
-- "" Display entered value as is
39+
-- "*" Password field - hide value
40+
-- "D" Debug option - don't show by default
41+
, conninfoDispChar :: B.ByteString
42+
, conninfoDispSize :: CInt -- ^ Field size in characters for dialog
43+
}
44+
deriving Show
45+
46+
instance Storable ConninfoOption where
47+
sizeOf _ = #{size PQconninfoOption}
48+
49+
alignment _ = #{alignment PQconninfoOption}
50+
51+
peek ptr = do
52+
conninfoKeyword <- B.packCString =<< #{peek PQconninfoOption, keyword} ptr
53+
conninfoEnvVar <- do
54+
p <- #{peek PQconninfoOption, envvar} ptr
55+
if p == nullPtr then pure Nothing else Just <$> B.packCString p
56+
conninfoCompiled <- do
57+
p <- #{peek PQconninfoOption, compiled} ptr
58+
if p == nullPtr then pure Nothing else Just <$> B.packCString p
59+
conninfoValue <- do
60+
p <- #{peek PQconninfoOption, val} ptr
61+
if p == nullPtr then pure Nothing else Just <$> B.packCString p
62+
conninfoLabel <- B.packCString =<< #{peek PQconninfoOption, label} ptr
63+
conninfoDispChar <- B.packCString =<< #{peek PQconninfoOption, dispchar} ptr
64+
conninfoDispSize <- #{peek PQconninfoOption, dispsize} ptr
65+
return $! ConninfoOption{..}
66+
67+
poke ptr ConninfoOption{..} = do
68+
B.useAsCString conninfoKeyword $ \keyword ->
69+
maybe ($ nullPtr) B.useAsCString conninfoEnvVar $ \envvar ->
70+
maybe ($ nullPtr) B.useAsCString conninfoCompiled $ \compiled ->
71+
maybe ($ nullPtr) B.useAsCString conninfoValue $ \value ->
72+
B.useAsCString conninfoLabel $ \label ->
73+
B.useAsCString conninfoDispChar $ \dispchar -> do
74+
#{poke PQconninfoOption, keyword} ptr keyword
75+
#{poke PQconninfoOption, envvar} ptr envvar
76+
#{poke PQconninfoOption, compiled} ptr compiled
77+
#{poke PQconninfoOption, val} ptr value
78+
#{poke PQconninfoOption, label} ptr label
79+
#{poke PQconninfoOption, dispchar} ptr dispchar
80+
#{poke PQconninfoOption, dispsize} ptr conninfoDispSize
81+
82+
-------------------------------------------------------------------------------
83+
-- PQconninfoOption
84+
-------------------------------------------------------------------------------
85+
86+
data PQconninfoOption
87+
88+
pqConninfoOptionKeyword :: Int
89+
pqConninfoOptionKeyword = #{offset PQconninfoOption, keyword}

‎src/Database/PostgreSQL/LibPQ/FFI.hs

+22-5
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,13 @@
22
{-# LANGUAGE EmptyDataDecls #-}
33
module Database.PostgreSQL.LibPQ.FFI where
44

5-
import Data.Word (Word8)
6-
import Foreign.C.String (CString)
7-
import Foreign.C.Types (CChar, CInt (..), CSize (..), CUInt (..))
8-
import Foreign.Ptr (FunPtr, Ptr)
5+
import Data.Word (Word8)
6+
import Foreign.C.ConstPtr (ConstPtr(..))
7+
import Foreign.C.String (CString)
8+
import Foreign.C.Types (CChar, CInt (..), CSize (..), CUInt (..))
9+
import Foreign.Ptr (FunPtr, Ptr)
910

11+
import Database.PostgreSQL.LibPQ.Connect (PQconninfoOption)
1012
import Database.PostgreSQL.LibPQ.Internal (CNoticeBuffer, NoticeBuffer, PGconn)
1113
import Database.PostgreSQL.LibPQ.Notify (Notify, PGnotice)
1214
import Database.PostgreSQL.LibPQ.Oid (Oid (..))
@@ -29,6 +31,9 @@ type NoticeReceiver = NoticeBuffer -> Ptr PGresult -> IO ()
2931
foreign import capi "hs-libpq.h PQconnectdb"
3032
c_PQconnectdb :: CString -> IO (Ptr PGconn)
3133

34+
foreign import capi "hs-libpq.h PQconnectdbParams"
35+
c_PQconnectdbParams :: ConstPtr (ConstPtr CChar) -> ConstPtr (ConstPtr CChar) -> CInt -> IO (Ptr PGconn)
36+
3237
foreign import capi "hs-libpq.h PQconnectStart"
3338
c_PQconnectStart :: CString -> IO (Ptr PGconn)
3439

@@ -87,6 +92,18 @@ foreign import capi "hs-libpq.h PQsocket"
8792
foreign import capi "hs-libpq.h PQerrorMessage"
8893
c_PQerrorMessage :: Ptr PGconn -> IO CString
8994

95+
foreign import capi "hs-libpq.h PQconndefaults"
96+
c_PQconndefaults :: IO (Ptr PQconninfoOption)
97+
98+
foreign import capi "hs-libpq.h PQconninfo"
99+
c_PQconninfo :: Ptr PGconn -> IO (Ptr PQconninfoOption)
100+
101+
foreign import capi "hs-libpq.h PQconninfoParse"
102+
c_PQconninfoParse :: CString -> Ptr (Ptr CChar) -> IO (Ptr PQconninfoOption)
103+
104+
foreign import capi "hs-libpq.h PQconninfoFree"
105+
c_PQconninfoFree :: Ptr PQconninfoOption -> IO ()
106+
90107
foreign import capi "hs-libpq.h PQfinish"
91108
c_PQfinish :: Ptr PGconn -> IO ()
92109

@@ -118,7 +135,7 @@ foreign import capi "hs-libpq.h PQputCopyData"
118135

119136
foreign import capi "hs-libpq.h PQputCopyEnd"
120137
c_PQputCopyEnd :: Ptr PGconn -> CString -> IO CInt
121-
138+
122139
-- TODO: GHC #22043
123140
foreign import ccall "hs-libpq.h PQgetCopyData"
124141
c_PQgetCopyData :: Ptr PGconn -> Ptr (Ptr Word8) -> CInt -> IO CInt

0 commit comments

Comments
 (0)