From b486d4f01f982df7f51ca00b0ad39106cd1a0a95 Mon Sep 17 00:00:00 2001 From: Ben Sinclair Date: Thu, 3 Oct 2024 10:46:51 +1000 Subject: [PATCH] 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. --- postgresql-libpq.cabal | 1 + src/Database/PostgreSQL/LibPQ.hs | 156 ++++++++++++++++------ src/Database/PostgreSQL/LibPQ/Connect.hsc | 89 ++++++++++++ src/Database/PostgreSQL/LibPQ/FFI.hs | 27 +++- 4 files changed, 225 insertions(+), 48 deletions(-) create mode 100644 src/Database/PostgreSQL/LibPQ/Connect.hsc diff --git a/postgresql-libpq.cabal b/postgresql-libpq.cabal index 2a5652b..a1c1fab 100644 --- a/postgresql-libpq.cabal +++ b/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 diff --git a/src/Database/PostgreSQL/LibPQ.hs b/src/Database/PostgreSQL/LibPQ.hs index 5b0c625..2e12ba4 100644 --- a/src/Database/PostgreSQL/LibPQ.hs +++ b/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,9 +282,9 @@ 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 @@ -284,6 +292,45 @@ connectdb conninfo = 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. -- diff --git a/src/Database/PostgreSQL/LibPQ/Connect.hsc b/src/Database/PostgreSQL/LibPQ/Connect.hsc new file mode 100644 index 0000000..5961ece --- /dev/null +++ b/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} diff --git a/src/Database/PostgreSQL/LibPQ/FFI.hs b/src/Database/PostgreSQL/LibPQ/FFI.hs index 5bc11ac..209dd4d 100644 --- a/src/Database/PostgreSQL/LibPQ/FFI.hs +++ b/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