Add connectdbParams and other connection key-value functions

postgresql-libpq.cabal

@@ -63,6 +63,7 @@ library
 
   other-modules:
     Database.PostgreSQL.LibPQ.Compat
+    Database.PostgreSQL.LibPQ.Connect
     Database.PostgreSQL.LibPQ.Enums
     Database.PostgreSQL.LibPQ.FFI
     Database.PostgreSQL.LibPQ.Marshal

src/Database/PostgreSQL/LibPQ.hs

@@ -52,12 +52,15 @@ module Database.PostgreSQL.LibPQ
     -- $dbconn
       Connection
     , connectdb
+    , connectdbParams
     , connectStart
     , connectPoll
     , newNullConnection
     , isNullConnection
-    --, conndefaults
-    --, conninfoParse
+    , ConninfoOption(..)
+    , conndefaults
+    , conninfo
+    , conninfoParse
     , reset
     , resetStart
     , resetPoll
@@ -222,25 +225,30 @@ module Database.PostgreSQL.LibPQ
     )
 where
 
+import Control.Monad           (when)
+import Control.Monad.IO.Class  (MonadIO(liftIO))
 import Control.Concurrent.MVar (MVar, newMVar, swapMVar, tryTakeMVar, withMVar)
 import Control.Exception       (mask_)
+import Foreign.C.ConstPtr      (ConstPtr (..))
 import Foreign.C.String        (CString, CStringLen, withCString)
 import Foreign.C.Types         (CInt (..))
 import Foreign.ForeignPtr      (ForeignPtr, finalizeForeignPtr, newForeignPtr, newForeignPtr_, touchForeignPtr, withForeignPtr)
-import Foreign.Marshal         (alloca, allocaBytes, finalizerFree, free, mallocBytes, maybeWith, reallocBytes, withArrayLen, withMany)
-import Foreign.Ptr             (Ptr, castPtr, nullPtr)
-import Foreign.Storable        (Storable (peek))
+import Foreign.Marshal         (alloca, allocaBytes, finalizerFree, free, mallocBytes, maybeWith, reallocBytes, withArray0, withArrayLen, withMany)
+import Foreign.Ptr             (Ptr, castPtr, nullPtr, plusPtr)
+import Foreign.Storable        (Storable (peek, sizeOf))
 import GHC.Conc                (closeFdWith)
 import System.IO               (IOMode (..), SeekMode (..))
 import System.Posix.Types      (CPid, Fd (..))
 
 import qualified Data.ByteString           as B
+import qualified Data.ByteString.Char8     as B8
 import qualified Data.ByteString.Internal  as B (c_strlen, createAndTrim, fromForeignPtr)
 import qualified Data.ByteString.Unsafe    as B
 import qualified Foreign.Concurrent        as FC
 import qualified Foreign.ForeignPtr.Unsafe as Unsafe
 
 import Database.PostgreSQL.LibPQ.Compat
+import Database.PostgreSQL.LibPQ.Connect
 import Database.PostgreSQL.LibPQ.Enums
 import Database.PostgreSQL.LibPQ.FFI
 import Database.PostgreSQL.LibPQ.Internal
@@ -274,16 +282,55 @@ import Database.PostgreSQL.LibPQ.Ptr
 -- value must be escaped with a backslash, i.e., \' and \\.
 connectdb :: B.ByteString -- ^ Connection Info
           -> IO Connection
-connectdb conninfo =
+connectdb connStr =
     mask_ $ do
-       connPtr <- B.useAsCString conninfo c_PQconnectdb
+       connPtr <- B.useAsCString connStr c_PQconnectdb
        if connPtr == nullPtr
            then fail "libpq failed to allocate a PGconn structure"
            else do
              noticeBuffer <- newMVar nullPtr
              connection <- newForeignPtrOnce connPtr (pqfinish connPtr noticeBuffer)
              return $! Conn connection noticeBuffer
 
+-- Include an implementation of the ContT transformer here to avoid a dependency
+-- on transformers.
+newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r}
+
+instance Functor (ContT r m) where
+    fmap f m = ContT $ \c -> runContT m (c . f)
+
+instance (Applicative m) => Applicative (ContT r m) where
+    pure x = ContT ($ x)
+    fm <*> xm = ContT $ \c -> runContT fm (\f -> runContT xm (c . f))
+
+instance (Monad m) => Monad (ContT r m) where
+    return = pure
+    m >>= k  = ContT $ \c -> runContT m (\a -> runContT (k a) c)
+
+instance (MonadIO m) => MonadIO (ContT r m) where
+    liftIO m = ContT (liftIO m >>=)
+
+-- | This function opens a new database connection using the parameters taken
+-- from the list of key word and value pairs.
+connectdbParams :: [(B.ByteString, B.ByteString)] -- ^ Connection Info
+                -> Bool -- ^ Expand database name
+                -> IO Connection
+connectdbParams connOpts expandDBName =
+    mask_ $ flip runContT pure $ do
+       keys <- fmap ConstPtr $ do
+         xs <- mapM (ContT . B.useAsCString) (map fst connOpts)
+         ContT (withArray0 (ConstPtr nullPtr) (fmap ConstPtr xs))
+       values <- fmap ConstPtr $ do
+         xs <- mapM (ContT . B.useAsCString) (map snd connOpts)
+         ContT (withArray0 (ConstPtr nullPtr) (fmap ConstPtr xs))
+       connPtr <- liftIO $ c_PQconnectdbParams keys values (if expandDBName then 1 else 0)
+       liftIO $ if connPtr == nullPtr
+           then fail "libpq failed to allocate a PGconn structure"
+           else do
+             noticeBuffer <- newMVar nullPtr
+             connection <- newForeignPtrOnce connPtr (pqfinish connPtr noticeBuffer)
+             return $! Conn connection noticeBuffer
+
 -- | Make a connection to the database server in a nonblocking manner.
 connectStart :: B.ByteString -- ^ Connection Info
              -> IO Connection
@@ -356,42 +403,65 @@ connectPoll :: Connection
             -> IO PollingStatus
 connectPoll = pollHelper c_PQconnectPoll
 
-
--- PQconndefaults
--- Returns the default connection options.
-
--- PQconninfoOption *PQconndefaults(void);
-
--- typedef struct
--- {
---     char   *keyword;   /* The keyword of the option */
---     char   *envvar;    /* Fallback environment variable name */
---     char   *compiled;  /* Fallback compiled in default value */
---     char   *val;       /* Option's current value, or NULL */
---     char   *label;     /* Label for field in connect dialog */
---     char   *dispchar;  /* Indicates how to display this field
---                           in a connect dialog. Values are:
---                           ""        Display entered value as is
---                           "*"       Password field - hide value
---                           "D"       Debug option - don't show by default */
---     int     dispsize;  /* Field size in characters for dialog */
--- } PQconninfoOption;
--- 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.
-
--- 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.
-
--- PQconninfoParse
--- Returns parsed connection options from the provided connection string.
-
--- PQconninfoOption *PQconninfoParse(const char *conninfo, char **errmsg);
--- 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.
-
--- Note that only options explicitly specified in the string will have values set in the result array; no defaults are inserted.
-
--- 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.)
-
--- 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.
-
+-- | Returns a connection options list. This can be used to determine all
+-- possible 'connectdb' options and their current default values. Note that the
+-- current default values ('conninfoValue' fields) will depend on environment
+-- variables and other context.
+conndefaults :: IO [ConninfoOption]
+conndefaults = do
+    mask_ $ getConnInfos =<< c_PQconndefaults
+
+-- | Parses a connection string and returns the resulting options as a list.
+-- This can be used to determine the 'connectdb' options in the provided
+-- connection string.
+--
+-- Note that only options explicitly specified in the string will have values
+-- set in the result array; no defaults are inserted.
+conninfoParse :: B.ByteString -- ^ Connection String
+              -> IO [ConninfoOption]
+conninfoParse connStr =
+    mask_ $ flip runContT pure $ do
+        (connPtr :: CString) <- ContT $ B.useAsCString connStr
+        (errmsgPtr :: Ptr CString) <- ContT alloca
+        liftIO $ do
+            p <- c_PQconninfoParse connPtr errmsgPtr
+            -- 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.)
+            errmsgC <- peek errmsgPtr
+            -- If an error occurs and errmsg is not NULL, be sure to free the
+            -- error string using PQfreemem.
+            when (errmsgC /= nullPtr) $ do
+                errmsg <- B8.unpack <$> B.packCString errmsgC
+                c_PQfreemem errmsgC
+                fail errmsg
+            getConnInfos p
+
+-- | Returns a connection options list. This can be used to determine all
+-- possible 'connectdb' options and the values that were used to connect to the
+-- server. All notes above for 'conndefaults' also apply to the result of
+-- 'conninfo'.
+conninfo :: Connection -> IO [ConninfoOption]
+conninfo connection = withConn connection $ \pgconn -> do
+    mask_ $ getConnInfos =<< c_PQconninfo pgconn
+
+-- | Marshal from an array pointer to PQconninfoOption to a list of
+-- ConninfoOptions.
+getConnInfos :: Ptr PQconninfoOption -> IO [ConninfoOption]
+getConnInfos ptr =
+    -- 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.
+    if ptr == nullPtr then pure [] else go [] ptr <* c_PQconninfoFree ptr
+    where
+        go xs p = do
+            (keyword :: CString) <- peek (plusPtr p pqConninfoOptionKeyword)
+            if keyword == nullPtr
+                then pure (reverse xs)
+                else do
+                    (x :: ConninfoOption) <- peek (castPtr p)
+                    go (x:xs) (plusPtr p (sizeOf x))
 
 -- | Resets the communication channel to the server.
 --

src/Database/PostgreSQL/LibPQ/Connect.hsc

@@ -0,0 +1,89 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Database.PostgreSQL.LibPQ.Connect where
+
+#include "hs-libpq.h"
+
+import Foreign (Storable (..), nullPtr)
+import Foreign.C (CInt)
+
+import qualified Data.ByteString as B
+
+-------------------------------------------------------------------------------
+-- ConninfoOption
+-------------------------------------------------------------------------------
+
+-- typedef struct
+-- {
+--     char   *keyword;   /* The keyword of the option */
+--     char   *envvar;    /* Fallback environment variable name */
+--     char   *compiled;  /* Fallback compiled in default value */
+--     char   *val;       /* Option's current value, or NULL */
+--     char   *label;     /* Label for field in connect dialog */
+--     char   *dispchar;  /* Indicates how to display this field
+--                           in a connect dialog. Values are:
+--                           ""        Display entered value as is
+--                           "*"       Password field - hide value
+--                           "D"       Debug option - don't show by default */
+--     int     dispsize;  /* Field size in characters for dialog */
+-- } PQconninfoOption;
+data ConninfoOption = ConninfoOption {
+      conninfoKeyword  :: B.ByteString -- ^ The keyword of the option
+    , conninfoEnvVar   :: Maybe B.ByteString -- ^ Fallback environment variable name
+    , conninfoCompiled :: Maybe B.ByteString -- ^ Fallback compiled in default value
+    , conninfoValue    :: Maybe B.ByteString -- ^ Option's current value, or NULL
+    , conninfoLabel    :: B.ByteString -- ^ Label for field in connect dialog
+      -- | Indicates how to display this field in a connect dialog. Values are:
+      --     ""   Display entered value as is
+      --     "*"  Password field - hide value
+      --     "D"  Debug option - don't show by default
+    , conninfoDispChar :: B.ByteString
+    , conninfoDispSize :: CInt -- ^ Field size in characters for dialog
+    }
+    deriving Show
+
+instance Storable ConninfoOption where
+  sizeOf _ = #{size PQconninfoOption}
+
+  alignment _ = #{alignment PQconninfoOption}
+
+  peek ptr = do
+      conninfoKeyword <- B.packCString =<< #{peek PQconninfoOption, keyword} ptr
+      conninfoEnvVar <- do
+        p <- #{peek PQconninfoOption, envvar} ptr
+        if p == nullPtr then pure Nothing else Just <$> B.packCString p
+      conninfoCompiled <- do
+        p <- #{peek PQconninfoOption, compiled} ptr
+        if p == nullPtr then pure Nothing else Just <$> B.packCString p
+      conninfoValue <- do
+        p <- #{peek PQconninfoOption, val} ptr
+        if p == nullPtr then pure Nothing else Just <$> B.packCString p
+      conninfoLabel <- B.packCString =<< #{peek PQconninfoOption, label} ptr
+      conninfoDispChar <- B.packCString =<< #{peek PQconninfoOption, dispchar} ptr
+      conninfoDispSize <- #{peek PQconninfoOption, dispsize} ptr
+      return $! ConninfoOption{..}
+
+  poke ptr ConninfoOption{..} = do
+      B.useAsCString conninfoKeyword $ \keyword ->
+        maybe ($ nullPtr) B.useAsCString conninfoEnvVar $ \envvar ->
+          maybe ($ nullPtr) B.useAsCString conninfoCompiled $ \compiled ->
+            maybe ($ nullPtr) B.useAsCString conninfoValue $ \value ->
+              B.useAsCString conninfoLabel $ \label ->
+                B.useAsCString conninfoDispChar $ \dispchar -> do
+                  #{poke PQconninfoOption, keyword} ptr keyword
+                  #{poke PQconninfoOption, envvar} ptr envvar
+                  #{poke PQconninfoOption, compiled} ptr compiled
+                  #{poke PQconninfoOption, val} ptr value
+                  #{poke PQconninfoOption, label} ptr label
+                  #{poke PQconninfoOption, dispchar} ptr dispchar
+                  #{poke PQconninfoOption, dispsize} ptr conninfoDispSize
+
+-------------------------------------------------------------------------------
+-- PQconninfoOption
+-------------------------------------------------------------------------------
+
+data PQconninfoOption
+
+pqConninfoOptionKeyword :: Int
+pqConninfoOptionKeyword = #{offset PQconninfoOption, keyword}

src/Database/PostgreSQL/LibPQ/FFI.hs

@@ -2,11 +2,13 @@
 {-# LANGUAGE EmptyDataDecls #-}
 module Database.PostgreSQL.LibPQ.FFI where
 
-import Data.Word        (Word8)
-import Foreign.C.String (CString)
-import Foreign.C.Types  (CChar, CInt (..), CSize (..), CUInt (..))
-import Foreign.Ptr      (FunPtr, Ptr)
+import Data.Word          (Word8)
+import Foreign.C.ConstPtr (ConstPtr(..))
+import Foreign.C.String   (CString)
+import Foreign.C.Types    (CChar, CInt (..), CSize (..), CUInt (..))
+import Foreign.Ptr        (FunPtr, Ptr)
 
+import Database.PostgreSQL.LibPQ.Connect  (PQconninfoOption)
 import Database.PostgreSQL.LibPQ.Internal (CNoticeBuffer, NoticeBuffer, PGconn)
 import Database.PostgreSQL.LibPQ.Notify   (Notify, PGnotice)
 import Database.PostgreSQL.LibPQ.Oid      (Oid (..))
@@ -29,6 +31,9 @@ type NoticeReceiver = NoticeBuffer -> Ptr PGresult -> IO ()
 foreign import capi        "hs-libpq.h PQconnectdb"
     c_PQconnectdb :: CString -> IO (Ptr PGconn)
 
+foreign import capi        "hs-libpq.h PQconnectdbParams"
+    c_PQconnectdbParams :: ConstPtr (ConstPtr CChar) -> ConstPtr (ConstPtr CChar) -> CInt -> IO (Ptr PGconn)
+
 foreign import capi        "hs-libpq.h PQconnectStart"
     c_PQconnectStart :: CString -> IO (Ptr PGconn)
 
@@ -87,6 +92,18 @@ foreign import capi        "hs-libpq.h PQsocket"
 foreign import capi        "hs-libpq.h PQerrorMessage"
     c_PQerrorMessage :: Ptr PGconn -> IO CString
 
+foreign import capi        "hs-libpq.h PQconndefaults"
+    c_PQconndefaults :: IO (Ptr PQconninfoOption)
+
+foreign import capi        "hs-libpq.h PQconninfo"
+    c_PQconninfo :: Ptr PGconn -> IO (Ptr PQconninfoOption)
+
+foreign import capi        "hs-libpq.h PQconninfoParse"
+    c_PQconninfoParse :: CString -> Ptr (Ptr CChar) -> IO (Ptr PQconninfoOption)
+
+foreign import capi        "hs-libpq.h PQconninfoFree"
+    c_PQconninfoFree :: Ptr PQconninfoOption -> IO ()
+
 foreign import capi        "hs-libpq.h PQfinish"
     c_PQfinish :: Ptr PGconn -> IO ()
 
@@ -118,7 +135,7 @@ foreign import capi        "hs-libpq.h PQputCopyData"
 
 foreign import capi        "hs-libpq.h PQputCopyEnd"
     c_PQputCopyEnd :: Ptr PGconn -> CString -> IO CInt
- 
+
 -- TODO: GHC #22043
 foreign import ccall       "hs-libpq.h PQgetCopyData"
     c_PQgetCopyData :: Ptr PGconn -> Ptr (Ptr Word8) -> CInt -> IO CInt