diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,37 @@ +0.11 +---- + +- Add pipeline mode API + https://www.postgresql.org/docs/current/libpq-pipeline-mode.html + + There are new values in `ExecStatus`, therefore the major version release. + + +0.10.2.0 +-------- + +- Split the c library dependency into separate packages. + Now the dependencies are either all `build-type: Simple` (`-f +use-pkg-config`) + or `build-type: Configure` (`-f -use-pkg-config`). + +0.10.1.0 +-------- + +- Fix issue with empty binary values (https://github.com/haskellari/postgresql-libpq/issues/54) + +0.10.0.0 +-------- + +There are technicallly two breaking changes in this release, +but they shouldn't affect anyone not doing anything weird. + +- Binary parameters are passed without copying. +- FFI functions are imported without `unsafe`. Most uses were incorrect. + We make all calls "safe", as checking whether libpq functions do IO + or may call a notifier (potentially calling back into Haskell), + is virtually impossible for all versions of libpq. + (The above properties are not specified in the documentation). + 0.9.5.0 ------- diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Main (main) where - -import Distribution.Simple -import Distribution.Simple.Setup -import Distribution.PackageDescription -import Distribution.Version - -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program -import Distribution.Verbosity - -import Data.Char (isSpace) -import Data.List (dropWhile,reverse) - -import Distribution.Types.UnqualComponentName - -flag :: String -> FlagName -flag = mkFlagName - -unqualComponentName :: String -> UnqualComponentName -unqualComponentName = mkUnqualComponentName - -main :: IO () -main = defaultMainWithHooks simpleUserHooks { - confHook = \pkg flags -> do - if lookup (flag "use-pkg-config") - (unFlagAssignment (configConfigurationsFlags flags)) == Just True - then do - confHook simpleUserHooks pkg flags - else do - lbi <- confHook simpleUserHooks pkg flags - bi <- psqlBuildInfo lbi - - return lbi { - localPkgDescr = updatePackageDescription - (Just bi, [(unqualComponentName "runtests", bi)]) (localPkgDescr lbi) - } -} - -psqlBuildInfo :: LocalBuildInfo -> IO BuildInfo -psqlBuildInfo lbi = do - (pgconfigProg, _) <- requireProgram verbosity - (simpleProgram "pg_config") (withPrograms lbi) - let pgconfig = getProgramOutput verbosity pgconfigProg - - incDir <- pgconfig ["--includedir"] - libDir <- pgconfig ["--libdir"] - - return emptyBuildInfo { - extraLibDirs = [strip libDir], - includeDirs = [strip incDir] - } - where - verbosity = normal -- honestly, this is a hack - strip x = dropWhile isSpace $ reverse $ dropWhile isSpace $ reverse x diff --git a/postgresql-libpq.cabal b/postgresql-libpq.cabal --- a/postgresql-libpq.cabal +++ b/postgresql-libpq.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: postgresql-libpq -version: 0.9.5.0 +version: 0.11.0.0 synopsis: low-level binding to libpq description: This is a binding to libpq: the C application @@ -21,18 +21,21 @@ (c) 2011 Leon P Smith category: Database -build-type: Custom +build-type: Simple extra-source-files: cbits/hs-libpq.h tested-with: - GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 + GHC ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.5 + || ==9.8.2 + || ==9.10.1 extra-source-files: CHANGELOG.md -custom-setup - setup-depends: - , base >=4.12.0.0 && <5 - , Cabal >=2.4 && <3.9 - -- If true, use pkg-config, otherwise use the pg_config based build -- configuration flag use-pkg-config @@ -65,36 +68,23 @@ Database.PostgreSQL.LibPQ.Marshal Database.PostgreSQL.LibPQ.Notify Database.PostgreSQL.LibPQ.Oid + Database.PostgreSQL.LibPQ.Ptr build-depends: - , base >=4.12.0.0 && <4.18 - , bytestring >=0.10.8.2 && <0.12 + , base >=4.12.0.0 && <4.21 + , bytestring >=0.10.8.2 && <0.13 if !os(windows) - build-depends: unix >=2.7.2.2 && <2.8 + build-depends: unix >=2.7.2.2 && <2.9 if os(windows) - build-depends: Win32 >=2.2.0.2 && <2.14 + build-depends: Win32 >=2.2.0.2 && <2.15 if flag(use-pkg-config) - pkgconfig-depends: libpq >=10.22 + build-depends: postgresql-libpq-pkgconfig ^>=0.11 else - if os(windows) - -- Due to https://sourceware.org/bugzilla/show_bug.cgi?id=22948, - -- if we specify pq instead of libpq, then ld might link against - -- libpq.dll directly, which can lead to segfaults. As a temporary hack, - -- we force ld to link against the libpq.lib import library directly - -- by specifying libpq here. - extra-libraries: libpq - - else - extra-libraries: pq - - if os(openbsd) - extra-libraries: - crypto - ssl + build-depends: postgresql-libpq-configure ^>=0.11 build-tool-depends: hsc2hs:hsc2hs >=0.68.5 @@ -107,6 +97,8 @@ , base , bytestring , postgresql-libpq + , tasty ^>=1.5 + , tasty-hunit ^>=0.10.1 source-repository head type: git diff --git a/src/Database/PostgreSQL/LibPQ.hs b/src/Database/PostgreSQL/LibPQ.hs --- a/src/Database/PostgreSQL/LibPQ.hs +++ b/src/Database/PostgreSQL/LibPQ.hs @@ -171,6 +171,15 @@ , FlushStatus(..) , flush + -- * Pipeline Mode + -- $pipelinemode + , PipelineStatus(..) + , pipelineStatus + , enterPipelineMode + , exitPipelineMode + , pipelineSync + , sendFlushRequest + -- * Cancelling Queries in Progress -- $cancel , Cancel @@ -238,6 +247,7 @@ import Database.PostgreSQL.LibPQ.Marshal import Database.PostgreSQL.LibPQ.Notify import Database.PostgreSQL.LibPQ.Oid +import Database.PostgreSQL.LibPQ.Ptr -- $dbconn -- The following functions deal with making a connection to a @@ -654,13 +664,29 @@ -- 'Result'. newtype Result = Result (ForeignPtr PGresult) deriving (Eq, Show) +-- | Prepare the given parameter bytestring for passing on to libpq, +-- without copying for binary parameters. +-- +-- This is safe to use to pass parameters to libpq considering: +-- * libpq treats the parameter data as read-only +-- * 'ByteString' uses pinned memory +-- * the reference to the 'CString' doesn't escape +unsafeUseParamAsCString :: (B.ByteString, Format) -> (CString -> IO a) -> IO a +unsafeUseParamAsCString (bs, format) kont = + case format of + Binary -> B.unsafeUseAsCStringLen bs kont' + Text -> B.useAsCString bs kont + where + kont' (ptr, 0) = if ptr == nullPtr then kont emptyPtr else kont ptr + kont' (ptr, _) = kont ptr + -- | Convert a list of parameters to the format expected by libpq FFI calls. withParams :: [Maybe (Oid, B.ByteString, Format)] -> (CInt -> Ptr Oid -> Ptr CString -> Ptr CInt -> Ptr CInt -> IO a) -> IO a withParams params action = unsafeWithArray n oids $ \ts -> - withMany (maybeWith B.useAsCString) values $ \c_values -> + withMany (maybeWith unsafeUseParamAsCString) values $ \c_values -> unsafeWithArray n c_values $ \vs -> unsafeWithArray n c_lengths $ \ls -> unsafeWithArray n formats $ \fs -> @@ -676,12 +702,12 @@ accum (Just (t,v,f)) ~(AccumParams i xs ys zs ws) = let !z = intToCInt (B.length v) !w = toCInt f - in AccumParams (i + 1) (t : xs) (Just v : ys) (z : zs) (w : ws) + in AccumParams (i + 1) (t : xs) (Just (v, f) : ys) (z : zs) (w : ws) intToCInt :: Int -> CInt intToCInt = toEnum -data AccumParams = AccumParams !Int ![Oid] ![Maybe B.ByteString] ![CInt] ![CInt] +data AccumParams = AccumParams !Int ![Oid] ![Maybe (B.ByteString, Format)] ![CInt] ![CInt] -- | Convert a list of parameters to the format expected by libpq FFI calls, -- prepared statement variant. @@ -689,7 +715,7 @@ -> (CInt -> Ptr CString -> Ptr CInt -> Ptr CInt -> IO a) -> IO a withParamsPrepared params action = - withMany (maybeWith B.useAsCString) values $ \c_values -> + withMany (maybeWith unsafeUseParamAsCString) values $ \c_values -> unsafeWithArray n c_values $ \vs -> unsafeWithArray n c_lengths $ \ls -> unsafeWithArray n formats $ \fs -> @@ -698,16 +724,16 @@ AccumPrepParams n values c_lengths formats = foldr accum (AccumPrepParams 0 [] [] []) params - accum :: Maybe (B.ByteString ,Format) -> AccumPrepParams -> AccumPrepParams + accum :: Maybe (B.ByteString, Format) -> AccumPrepParams -> AccumPrepParams accum Nothing ~(AccumPrepParams i a b c) = AccumPrepParams (i + 1) (Nothing : a) (0 : b) (0 : c) accum (Just (v, f)) ~(AccumPrepParams i xs ys zs) = let !y = intToCInt (B.length v) !z = toCInt f - in AccumPrepParams (i + 1) (Just v : xs) (y : ys) (z : zs) + in AccumPrepParams (i + 1) (Just (v, f) : xs) (y : ys) (z : zs) -data AccumPrepParams = AccumPrepParams !Int ![Maybe B.ByteString] ![CInt] ![CInt] +data AccumPrepParams = AccumPrepParams !Int ![Maybe (B.ByteString, Format)] ![CInt] ![CInt] -- | Submits a command to the server and waits for the result. -- @@ -1622,6 +1648,60 @@ 0 -> return FlushOk 1 -> return FlushWriting _ -> return FlushFailed + +-- $pipelinemode +-- These functions control behaviour in pipeline mode. +-- +-- Pipeline mode allows applications to send a query +-- without having to read the result of the previously +-- sent query. Taking advantage of the pipeline mode, +-- a client will wait less for the server, since multiple +-- queries/results can be sent/received in +-- a single network transaction. + +-- | Returns the current pipeline mode status of the libpq connection. +-- +-- @since 0.11.0.0 +pipelineStatus :: Connection + -> IO PipelineStatus +pipelineStatus connection = do + stat <- withConn connection c_PQpipelineStatus + maybe + (fail $ "Unknown pipeline status " ++ show stat) + return + (fromCInt stat) + +-- | Causes a connection to enter pipeline mode if it is currently idle or already in pipeline mode. +-- +-- @since 0.11.0.0 +enterPipelineMode :: Connection + -> IO Bool +enterPipelineMode connection = + enumFromConn connection c_PQenterPipelineMode + +-- | Causes a connection to exit pipeline mode if it is currently in pipeline mode with an empty queue and no pending results. +-- +-- @since 0.11.0.0 +exitPipelineMode :: Connection + -> IO Bool +exitPipelineMode connection = + enumFromConn connection c_PQexitPipelineMode + +-- | Marks a synchronization point in a pipeline by sending a sync message and flushing the send buffer. This serves as the delimiter of an implicit transaction and an error recovery point> +-- +-- @since 0.11.0.0 +pipelineSync :: Connection + -> IO Bool +pipelineSync connection = + enumFromConn connection c_PQpipelineSync + +-- | Sends a request for the server to flush its output buffer. +-- +-- @since 0.11.0.0 +sendFlushRequest :: Connection + -> IO Bool +sendFlushRequest connection = + enumFromConn connection c_PQsendFlushRequest -- $cancel diff --git a/src/Database/PostgreSQL/LibPQ/Enums.hsc b/src/Database/PostgreSQL/LibPQ/Enums.hsc --- a/src/Database/PostgreSQL/LibPQ/Enums.hsc +++ b/src/Database/PostgreSQL/LibPQ/Enums.hsc @@ -37,23 +37,42 @@ | NonfatalError -- ^ A nonfatal error (a notice or -- warning) occurred. | FatalError -- ^ A fatal error occurred. - | SingleTuple -- ^ The PGresult contains a single result tuple + | SingleTuple -- ^ The 'Result' contains a single result tuple -- from the current command. This status occurs -- only when single-row mode has been selected -- for the query. + + | PipelineSync -- ^ The 'Result' represents a synchronization + -- point in pipeline mode, requested by + -- 'pipelineSync'. This status occurs only + -- when pipeline mode has been selected. + -- + -- @since 0.11.0.0 + + | PipelineAbort -- ^ The 'Result' represents a pipeline that + -- has received an error from the server. + -- 'getResult' must be called repeatedly, + -- and each time it will return this status + -- code until the end of the current pipeline, + -- at which point it will return 'PipelineSync' + -- and normal processing can resume. + -- + -- @since 0.11.0.0 deriving (Eq, Show) instance FromCInt ExecStatus where - fromCInt (#const PGRES_EMPTY_QUERY) = Just EmptyQuery - fromCInt (#const PGRES_COMMAND_OK) = Just CommandOk - fromCInt (#const PGRES_TUPLES_OK) = Just TuplesOk - fromCInt (#const PGRES_COPY_OUT) = Just CopyOut - fromCInt (#const PGRES_COPY_IN) = Just CopyIn - fromCInt (#const PGRES_COPY_BOTH) = Just CopyBoth - fromCInt (#const PGRES_BAD_RESPONSE) = Just BadResponse - fromCInt (#const PGRES_NONFATAL_ERROR) = Just NonfatalError - fromCInt (#const PGRES_FATAL_ERROR) = Just FatalError - fromCInt (#const PGRES_SINGLE_TUPLE) = Just SingleTuple + fromCInt (#const PGRES_EMPTY_QUERY) = Just EmptyQuery + fromCInt (#const PGRES_COMMAND_OK) = Just CommandOk + fromCInt (#const PGRES_TUPLES_OK) = Just TuplesOk + fromCInt (#const PGRES_COPY_OUT) = Just CopyOut + fromCInt (#const PGRES_COPY_IN) = Just CopyIn + fromCInt (#const PGRES_COPY_BOTH) = Just CopyBoth + fromCInt (#const PGRES_BAD_RESPONSE) = Just BadResponse + fromCInt (#const PGRES_NONFATAL_ERROR) = Just NonfatalError + fromCInt (#const PGRES_FATAL_ERROR) = Just FatalError + fromCInt (#const PGRES_SINGLE_TUPLE) = Just SingleTuple + fromCInt (#const PGRES_PIPELINE_SYNC) = Just PipelineSync + fromCInt (#const PGRES_PIPELINE_ABORTED) = Just PipelineAbort fromCInt _ = Nothing instance ToCInt ExecStatus where @@ -67,6 +86,8 @@ toCInt NonfatalError = (#const PGRES_NONFATAL_ERROR) toCInt FatalError = (#const PGRES_FATAL_ERROR) toCInt SingleTuple = (#const PGRES_SINGLE_TUPLE) + toCInt PipelineSync = (#const PGRES_PIPELINE_SYNC) + toCInt PipelineAbort = (#const PGRES_PIPELINE_ABORTED) data FieldCode @@ -230,8 +251,8 @@ fromCInt (#const CONNECTION_SSL_STARTUP) = return ConnectionSSLStartup -- fromCInt (#const CONNECTION_NEEDED) = return ConnectionNeeded fromCInt _ = Nothing - + data TransactionStatus = TransIdle -- ^ currently idle | TransActive -- ^ a command is in progress @@ -261,6 +282,25 @@ instance FromCInt Format where fromCInt 0 = Just Text fromCInt 1 = Just Binary + fromCInt _ = Nothing + + +-- | +-- +-- @since 0.11.0.0 +data PipelineStatus + = PipelineOn -- ^ The 'Connection' is in pipeline mode. + | PipelineOff -- ^ The 'Connection' is /not/ in pipeline mode. + | PipelineAborted -- ^ The 'Connection' is in pipeline mode and an error + -- occurred while processing the current pipeline. The + -- aborted flag is cleared when 'getResult' returns a + -- result with status 'PipelineSync'. + deriving (Eq, Show) + +instance FromCInt PipelineStatus where + fromCInt (#const PQ_PIPELINE_ON) = return PipelineOn + fromCInt (#const PQ_PIPELINE_OFF) = return PipelineOff + fromCInt (#const PQ_PIPELINE_ABORTED) = return PipelineAborted fromCInt _ = Nothing ------------------------------------------------------------------------------- diff --git a/src/Database/PostgreSQL/LibPQ/FFI.hs b/src/Database/PostgreSQL/LibPQ/FFI.hs --- a/src/Database/PostgreSQL/LibPQ/FFI.hs +++ b/src/Database/PostgreSQL/LibPQ/FFI.hs @@ -35,53 +35,53 @@ foreign import capi "hs-libpq.h PQconnectPoll" c_PQconnectPoll :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQdb" +foreign import capi "hs-libpq.h PQdb" c_PQdb :: Ptr PGconn -> IO CString -foreign import capi unsafe "hs-libpq.h PQuser" +foreign import capi "hs-libpq.h PQuser" c_PQuser :: Ptr PGconn -> IO CString -foreign import capi unsafe "hs-libpq.h PQpass" +foreign import capi "hs-libpq.h PQpass" c_PQpass :: Ptr PGconn -> IO CString -foreign import capi unsafe "hs-libpq.h PQhost" +foreign import capi "hs-libpq.h PQhost" c_PQhost :: Ptr PGconn -> IO CString -foreign import capi unsafe "hs-libpq.h PQport" +foreign import capi "hs-libpq.h PQport" c_PQport :: Ptr PGconn -> IO CString -foreign import capi unsafe "hs-libpq.h PQoptions" +foreign import capi "hs-libpq.h PQoptions" c_PQoptions :: Ptr PGconn -> IO CString -foreign import capi unsafe "hs-libpq.h PQbackendPID" +foreign import capi "hs-libpq.h PQbackendPID" c_PQbackendPID :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQconnectionNeedsPassword" +foreign import capi "hs-libpq.h PQconnectionNeedsPassword" c_PQconnectionNeedsPassword :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQconnectionUsedPassword" +foreign import capi "hs-libpq.h PQconnectionUsedPassword" c_PQconnectionUsedPassword :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQstatus" +foreign import capi "hs-libpq.h PQstatus" c_PQstatus :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQtransactionStatus" +foreign import capi "hs-libpq.h PQtransactionStatus" c_PQtransactionStatus :: Ptr PGconn -> IO CInt -- TODO: GHC #22043 foreign import ccall "hs-libpq.h PQparameterStatus" c_PQparameterStatus :: Ptr PGconn -> CString -> IO CString -foreign import capi unsafe "hs-libpq.h PQprotocolVersion" +foreign import capi "hs-libpq.h PQprotocolVersion" c_PQprotocolVersion :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQserverVersion" +foreign import capi "hs-libpq.h PQserverVersion" c_PQserverVersion :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQlibVersion" +foreign import capi "hs-libpq.h PQlibVersion" c_PQlibVersion :: IO CInt -foreign import capi unsafe "hs-libpq.h PQsocket" +foreign import capi "hs-libpq.h PQsocket" c_PQsocket :: Ptr PGconn -> IO CInt foreign import capi "hs-libpq.h PQerrorMessage" @@ -99,7 +99,7 @@ foreign import capi "hs-libpq.h PQresetPoll" c_PQresetPoll :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQclientEncoding" +foreign import capi "hs-libpq.h PQclientEncoding" c_PQclientEncoding :: Ptr PGconn -> IO CInt -- TODO: GHC #22043 @@ -110,7 +110,7 @@ c_PQsetClientEncoding :: Ptr PGconn -> CString -> IO CInt type PGVerbosity = CInt -foreign import capi unsafe "hs-libpq.h PQsetErrorVerbosity" +foreign import capi "hs-libpq.h PQsetErrorVerbosity" c_PQsetErrorVerbosity :: Ptr PGconn -> PGVerbosity -> IO PGVerbosity foreign import capi "hs-libpq.h PQputCopyData" @@ -159,22 +159,22 @@ foreign import capi "hs-libpq.h PQcancel" c_PQcancel :: Ptr PGcancel -> CString -> CInt -> IO CInt -foreign import capi unsafe "hs-libpq.h PQnotifies" +foreign import capi "hs-libpq.h PQnotifies" c_PQnotifies :: Ptr PGconn -> IO (Ptr Notify) foreign import capi "hs-libpq.h PQconsumeInput" c_PQconsumeInput :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQisBusy" +foreign import capi "hs-libpq.h PQisBusy" c_PQisBusy :: Ptr PGconn -> IO CInt foreign import capi "hs-libpq.h PQsetnonblocking" c_PQsetnonblocking :: Ptr PGconn -> CInt -> IO CInt -foreign import capi unsafe "hs-libpq.h PQisnonblocking" +foreign import capi "hs-libpq.h PQisnonblocking" c_PQisnonblocking :: Ptr PGconn -> IO CInt -foreign import capi unsafe "hs-libpq.h PQsetSingleRowMode" +foreign import capi "hs-libpq.h PQsetSingleRowMode" c_PQsetSingleRowMode :: Ptr PGconn -> IO CInt foreign import capi "hs-libpq.h PQgetResult" @@ -207,67 +207,67 @@ foreign import capi "hs-libpq.h &PQclear" p_PQclear :: FunPtr (Ptr PGresult -> IO ()) -foreign import capi unsafe "hs-libpq.h PQresultStatus" +foreign import capi "hs-libpq.h PQresultStatus" c_PQresultStatus :: Ptr PGresult -> IO CInt -foreign import capi unsafe "hs-libpq.h PQresStatus" +foreign import capi "hs-libpq.h PQresStatus" c_PQresStatus :: CInt -> IO CString -foreign import capi unsafe "hs-libpq.h PQresultErrorMessage" +foreign import capi "hs-libpq.h PQresultErrorMessage" c_PQresultErrorMessage :: Ptr PGresult -> IO CString foreign import capi "hs-libpq.h PQresultErrorField" c_PQresultErrorField :: Ptr PGresult -> CInt -> IO CString -foreign import capi unsafe "hs-libpq.h PQntuples" +foreign import capi "hs-libpq.h PQntuples" c_PQntuples :: Ptr PGresult -> CInt -foreign import capi unsafe "hs-libpq.h PQnfields" +foreign import capi "hs-libpq.h PQnfields" c_PQnfields :: Ptr PGresult -> CInt -foreign import capi unsafe "hs-libpq.h PQfname" +foreign import capi "hs-libpq.h PQfname" c_PQfname :: Ptr PGresult -> CInt -> IO CString -foreign import capi unsafe "hs-libpq.h PQfnumber" +foreign import capi "hs-libpq.h PQfnumber" c_PQfnumber :: Ptr PGresult -> CString -> IO CInt -foreign import capi unsafe "hs-libpq.h PQftable" +foreign import capi "hs-libpq.h PQftable" c_PQftable :: Ptr PGresult -> CInt -> IO Oid -foreign import capi unsafe "hs-libpq.h PQftablecol" +foreign import capi "hs-libpq.h PQftablecol" c_PQftablecol :: Ptr PGresult -> CInt -> IO CInt -foreign import capi unsafe "hs-libpq.h PQfformat" +foreign import capi "hs-libpq.h PQfformat" c_PQfformat :: Ptr PGresult -> CInt -> IO CInt -foreign import capi unsafe "hs-libpq.h PQftype" +foreign import capi "hs-libpq.h PQftype" c_PQftype :: Ptr PGresult -> CInt -> IO Oid -foreign import capi unsafe "hs-libpq.h PQfmod" +foreign import capi "hs-libpq.h PQfmod" c_PQfmod :: Ptr PGresult -> CInt -> IO CInt -foreign import capi unsafe "hs-libpq.h PQfsize" +foreign import capi "hs-libpq.h PQfsize" c_PQfsize :: Ptr PGresult -> CInt -> IO CInt -foreign import capi unsafe "hs-libpq.h PQgetvalue" +foreign import capi "hs-libpq.h PQgetvalue" c_PQgetvalue :: Ptr PGresult -> CInt -> CInt -> IO CString -foreign import capi unsafe "hs-libpq.h PQgetisnull" +foreign import capi "hs-libpq.h PQgetisnull" c_PQgetisnull :: Ptr PGresult -> CInt -> CInt -> IO CInt -foreign import capi unsafe "hs-libpq.h PQgetlength" +foreign import capi "hs-libpq.h PQgetlength" c_PQgetlength :: Ptr PGresult -> CInt -> CInt -> IO CInt -foreign import capi unsafe "hs-libpq.h PQnparams" +foreign import capi "hs-libpq.h PQnparams" c_PQnparams :: Ptr PGresult -> IO CInt -foreign import capi unsafe "hs-libpq.h PQparamtype" +foreign import capi "hs-libpq.h PQparamtype" c_PQparamtype :: Ptr PGresult -> CInt -> IO Oid -foreign import capi unsafe "hs-libpq.h PQcmdStatus" +foreign import capi "hs-libpq.h PQcmdStatus" c_PQcmdStatus :: Ptr PGresult -> IO CString -foreign import capi unsafe "hs-libpq.h PQcmdTuples" +foreign import capi "hs-libpq.h PQcmdTuples" c_PQcmdTuples :: Ptr PGresult -> IO CString foreign import capi "hs-libpq.h PQescapeStringConn" @@ -290,38 +290,53 @@ -> Ptr CSize -> IO (Ptr Word8) -- Actually (IO (Ptr CUChar)) -foreign import capi unsafe "hs-libpq.h PQescapeIdentifier" +foreign import capi "hs-libpq.h PQescapeIdentifier" c_PQescapeIdentifier :: Ptr PGconn -> CString -> CSize -> IO CString -foreign import capi unsafe "hs-libpq.h &PQfreemem" +foreign import capi "hs-libpq.h &PQfreemem" p_PQfreemem :: FunPtr (Ptr a -> IO ()) -foreign import capi unsafe "hs-libpq.h PQfreemem" +foreign import capi "hs-libpq.h PQfreemem" c_PQfreemem :: Ptr a -> IO () +foreign import capi "hs-libpq.h PQpipelineStatus" + c_PQpipelineStatus :: Ptr PGconn -> IO CInt + +foreign import capi "hs-libpq.h PQenterPipelineMode" + c_PQenterPipelineMode :: Ptr PGconn -> IO CInt + +foreign import capi "hs-libpq.h PQexitPipelineMode" + c_PQexitPipelineMode :: Ptr PGconn -> IO CInt + +foreign import capi "hs-libpq.h PQpipelineSync" + c_PQpipelineSync :: Ptr PGconn -> IO CInt + +foreign import capi "hs-libpq.h PQsendFlushRequest" + c_PQsendFlushRequest :: Ptr PGconn -> IO CInt + ------------------------------------------------------------------------------- -- FFI imports: noticebuffers ------------------------------------------------------------------------------- -foreign import capi unsafe "hs-libpq.h hs_postgresql_libpq_malloc_noticebuffer" +foreign import capi "hs-libpq.h hs_postgresql_libpq_malloc_noticebuffer" c_malloc_noticebuffer :: IO (Ptr CNoticeBuffer) -foreign import capi unsafe "hs-libpq.h hs_postgresql_libpq_free_noticebuffer" +foreign import capi "hs-libpq.h hs_postgresql_libpq_free_noticebuffer" c_free_noticebuffer :: Ptr CNoticeBuffer -> IO () -foreign import capi unsafe "hs-libpq.h hs_postgresql_libpq_get_notice" +foreign import capi "hs-libpq.h hs_postgresql_libpq_get_notice" c_get_notice :: Ptr CNoticeBuffer -> IO (Ptr PGnotice) -foreign import capi unsafe "hs-libpq.h &hs_postgresql_libpq_discard_notices" +foreign import capi "hs-libpq.h &hs_postgresql_libpq_discard_notices" p_discard_notices :: FunPtr NoticeReceiver -foreign import capi unsafe "hs-libpq.h &hs_postgresql_libpq_store_notices" +foreign import capi "hs-libpq.h &hs_postgresql_libpq_store_notices" p_store_notices :: FunPtr NoticeReceiver -foreign import capi unsafe "hs-libpq.h PQsetNoticeReceiver" +foreign import capi "hs-libpq.h PQsetNoticeReceiver" c_PQsetNoticeReceiver :: Ptr PGconn -> FunPtr NoticeReceiver -> Ptr CNoticeBuffer -> IO (FunPtr NoticeReceiver) ------------------------------------------------------------------------------- diff --git a/src/Database/PostgreSQL/LibPQ/Ptr.hs b/src/Database/PostgreSQL/LibPQ/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/LibPQ/Ptr.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MagicHash #-} +module Database.PostgreSQL.LibPQ.Ptr (emptyPtr) where + +import GHC.Ptr (Ptr (..)) + +emptyPtr :: Ptr a +emptyPtr = Ptr ""# diff --git a/test/Smoke.hs b/test/Smoke.hs --- a/test/Smoke.hs +++ b/test/Smoke.hs @@ -1,17 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Monad (unless) +import Control.Monad (unless) +import Data.Foldable (toList) import Database.PostgreSQL.LibPQ -import Data.Foldable (toList) -import System.Environment (getEnvironment) -import System.Exit (exitFailure) +import System.Environment (getEnvironment) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCaseSteps) +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 main :: IO () main = do libpqVersion >>= print - withConnstring smoke + withConnstring $ \connString -> defaultMain $ testGroup "postgresql-libpq" + [ testCaseSteps "smoke" $ smoke connString + , testCaseSteps "issue54" $ issue54 connString + , testCaseSteps "pipeline" $ testPipeline connString + ] withConnstring :: (BS8.ByteString -> IO ()) -> IO () withConnstring kont = do @@ -35,21 +42,80 @@ , "port=5432" ] -smoke :: BS8.ByteString -> IO () -smoke connstring = do +smoke :: BS8.ByteString -> (String -> IO ()) -> IO () +smoke connstring info = do + let infoShow x = info (show x) + conn <- connectdb connstring -- status functions - db conn >>= print - user conn >>= print - host conn >>= print - port conn >>= print - status conn >>= print - transactionStatus conn >>= print - protocolVersion conn >>= print - serverVersion conn >>= print + db conn >>= infoShow + user conn >>= infoShow + host conn >>= infoShow + port conn >>= infoShow + status conn >>= infoShow + transactionStatus conn >>= infoShow + protocolVersion conn >>= infoShow + serverVersion conn >>= infoShow + pipelineStatus conn >>= infoShow s <- status conn - unless (s == ConnectionOk) exitFailure + assertEqual "connection not ok" ConnectionOk s finish conn + +issue54 :: BS8.ByteString -> (String -> IO ()) -> IO () +issue54 connString info = do + conn <- connectdb connString + + Just result <- execParams conn + "SELECT ($1 :: bytea), ($2 :: bytea)" + [Just (Oid 17,"",Binary), Just (Oid 17,BS.empty,Binary)] + Binary + s <- resultStatus result + assertEqual "result status" TuplesOk s + + -- ntuples result >>= info . show + -- nfields result >>= info . show + + null1 <- getisnull result 0 0 + null2 <- getisnull result 0 1 + assertEqual "fst not null" False null1 + assertEqual "snd not null" False null2 + + Just val1 <- getvalue result 0 0 + Just val2 <- getvalue result 0 1 + + assertEqual "fst not null" BS.empty val1 + assertEqual "snd not null" BS.empty val2 + +testPipeline :: BS8.ByteString -> (String -> IO ()) -> IO () +testPipeline connstring info = do + conn <- connectdb connstring + + setnonblocking conn True `shouldReturn` True + enterPipelineMode conn `shouldReturn` True + pipelineStatus conn `shouldReturn` PipelineOn + sendQueryParams conn (BS8.pack "select 1") [] Text `shouldReturn` True + sendQueryParams conn (BS8.pack "select 2") [] Text `shouldReturn` True + pipelineSync conn `shouldReturn` True + + Just r1 <- getResult conn + resultStatus r1 `shouldReturn` TuplesOk + getvalue r1 0 0 `shouldReturn` Just (BS8.pack "1") + Nothing <- getResult conn + + Just r2 <- getResult conn + getvalue r2 0 0 `shouldReturn` Just (BS8.pack "2") + Nothing <- getResult conn + + Just r3 <- getResult conn + resultStatus r3 `shouldReturn` PipelineSync + + finish conn + where + shouldBe r value = assertEqual "shouldBe" r value + + shouldReturn action value = do + r <- action + r `shouldBe` value