postgresql-libpq 0.9.5.0 → 0.11.0.0
raw patch · 8 files changed
Files
- CHANGELOG.md +34/−0
- Setup.hs +0/−55
- postgresql-libpq.cabal +20/−28
- src/Database/PostgreSQL/LibPQ.hs +87/−7
- src/Database/PostgreSQL/LibPQ/Enums.hsc +52/−12
- src/Database/PostgreSQL/LibPQ/FFI.hs +65/−50
- src/Database/PostgreSQL/LibPQ/Ptr.hs +7/−0
- test/Smoke.hs +82/−16
CHANGELOG.md view
@@ -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 -------
− Setup.hs
@@ -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
postgresql-libpq.cabal view
@@ -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
src/Database/PostgreSQL/LibPQ.hs view
@@ -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
src/Database/PostgreSQL/LibPQ/Enums.hsc view
@@ -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 -------------------------------------------------------------------------------
src/Database/PostgreSQL/LibPQ/FFI.hs view
@@ -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) -------------------------------------------------------------------------------
+ src/Database/PostgreSQL/LibPQ/Ptr.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE MagicHash #-}+module Database.PostgreSQL.LibPQ.Ptr (emptyPtr) where++import GHC.Ptr (Ptr (..))++emptyPtr :: Ptr a+emptyPtr = Ptr ""#
test/Smoke.hs view
@@ -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