diff --git a/Database/PQ.hsc b/Database/PQ.hsc index 5e2b309..e592a2e 100644 --- a/Database/PQ.hsc +++ b/Database/PQ.hsc @@ -303,7 +303,7 @@ data PollingStatus = PollingFailed | PollingReading | PollingWriting - | PollingOk deriving Show + | PollingOk deriving (Eq, Show) pollHelper :: (Ptr PGconn -> IO CInt) -> Connection @@ -398,7 +398,7 @@ data ConnStatus | ConnectionSetEnv -- ^ Negotiating environment-driven -- parameter settings. | ConnectionSSLStartup -- ^ Negotiating SSL encryption. - deriving Show + deriving (Eq, Show) -- | Returns the status of the connection. @@ -436,6 +436,7 @@ data TransactionStatus = TransIdle -- ^ currently idle | TransInTrans -- ^ idle, in a valid transaction block | TransInError -- ^ idle, in a failed transaction block | TransUnknown -- ^ the connection is bad + deriving (Eq, Show) -- | Returns the current in-transaction status of the server. -- @@ -580,7 +581,7 @@ connectionUsedPassword connection = newtype Result = Result (ForeignPtr PGresult) deriving (Eq, Show) data PGresult -data Format = Text | Binary deriving Enum +data Format = Text | Binary deriving (Enum, Eq, Show) type Oid = CUInt @@ -835,7 +836,7 @@ data ExecStatus = EmptyQuery -- ^ The string sent to the server was empty. | NonfatalError -- ^ A nonfatal error (a notice or -- warning) occurred. | FatalError -- ^ A fatal error occurred. - deriving Show + deriving (Eq, Show) instance Enum ExecStatus where toEnum (#const PGRES_EMPTY_QUERY) = EmptyQuery @@ -952,6 +953,8 @@ data FieldCode = DiagSeverity -- ^ The name of the source-code function reporting the -- error. + deriving (Eq, Show) + instance Enum FieldCode where toEnum (#const PG_DIAG_SEVERITY) = DiagSeverity @@ -1651,6 +1654,7 @@ isnonblocking connection = enumFromConn connection c_PQisnonblocking data FlushStatus = FlushOk | FlushFailed | FlushWriting + deriving (Eq, Show) -- | Attempts to flush any queued output data to the server. Returns -- 'FlushOk' if successful (or if the send queue is empty), @@ -1984,141 +1988,141 @@ maybeBsFromForeignPtr fp f = foreign import ccall safe "libpq-fe.h PQconnectdb" c_PQconnectdb :: CString ->IO (Ptr PGconn) -foreign import ccall unsafe "libpq-fe.h PQconnectStart" +foreign import ccall safe "libpq-fe.h PQconnectStart" c_PQconnectStart :: CString ->IO (Ptr PGconn) -foreign import ccall unsafe "libpq-fe.h PQconnectPoll" +foreign import ccall safe "libpq-fe.h PQconnectPoll" c_PQconnectPoll :: Ptr PGconn ->IO CInt -foreign import ccall unsafe "libpq-fe.h PQdb" +foreign import ccall safe "libpq-fe.h PQdb" c_PQdb :: Ptr PGconn -> IO CString -foreign import ccall unsafe "libpq-fe.h PQuser" +foreign import ccall safe "libpq-fe.h PQuser" c_PQuser :: Ptr PGconn -> IO CString -foreign import ccall unsafe "libpq-fe.h PQpass" +foreign import ccall safe "libpq-fe.h PQpass" c_PQpass :: Ptr PGconn -> IO CString -foreign import ccall unsafe "libpq-fe.h PQhost" +foreign import ccall safe "libpq-fe.h PQhost" c_PQhost :: Ptr PGconn -> IO CString -foreign import ccall unsafe "libpq-fe.h PQport" +foreign import ccall safe "libpq-fe.h PQport" c_PQport :: Ptr PGconn -> IO CString -foreign import ccall unsafe "libpq-fe.h PQoptions" +foreign import ccall safe "libpq-fe.h PQoptions" c_PQoptions :: Ptr PGconn -> IO CString -foreign import ccall unsafe "libpq-fe.h PQbackendPID" +foreign import ccall safe "libpq-fe.h PQbackendPID" c_PQbackendPID :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQconnectionNeedsPassword" +foreign import ccall safe "libpq-fe.h PQconnectionNeedsPassword" c_PQconnectionNeedsPassword :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQconnectionUsedPassword" +foreign import ccall safe "libpq-fe.h PQconnectionUsedPassword" c_PQconnectionUsedPassword :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQstatus" +foreign import ccall safe "libpq-fe.h PQstatus" c_PQstatus :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQtransactionStatus" +foreign import ccall safe "libpq-fe.h PQtransactionStatus" c_PQtransactionStatus :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQparameterStatus" +foreign import ccall safe "libpq-fe.h PQparameterStatus" c_PQparameterStatus :: Ptr PGconn -> CString -> IO CString -foreign import ccall unsafe "libpq-fe.h PQprotocolVersion" +foreign import ccall safe "libpq-fe.h PQprotocolVersion" c_PQprotocolVersion :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQserverVersion" +foreign import ccall safe "libpq-fe.h PQserverVersion" c_PQserverVersion :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQsocket" +foreign import ccall safe "libpq-fe.h PQsocket" c_PQsocket :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQerrorMessage" +foreign import ccall safe "libpq-fe.h PQerrorMessage" c_PQerrorMessage :: Ptr PGconn -> IO CString -foreign import ccall unsafe "libpq-fe.h &PQfinish" +foreign import ccall safe "libpq-fe.h &PQfinish" p_PQfinish :: FunPtr (Ptr PGconn -> IO ()) foreign import ccall safe "libpq-fe.h PQreset" c_PQreset :: Ptr PGconn -> IO () -foreign import ccall unsafe "libpq-fe.h PQresetStart" +foreign import ccall safe "libpq-fe.h PQresetStart" c_PQresetStart :: Ptr PGconn ->IO CInt -foreign import ccall unsafe "libpq-fe.h PQresetPoll" +foreign import ccall safe "libpq-fe.h PQresetPoll" c_PQresetPoll :: Ptr PGconn ->IO CInt -foreign import ccall unsafe "libpq-fe.h PQclientEncoding" +foreign import ccall safe "libpq-fe.h PQclientEncoding" c_PQclientEncoding :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h pg_encoding_to_char" +foreign import ccall safe "libpq-fe.h pg_encoding_to_char" c_pg_encoding_to_char :: CInt -> IO CString -foreign import ccall unsafe "libpq-fe.h PQsetClientEncoding" +foreign import ccall safe "libpq-fe.h PQsetClientEncoding" c_PQsetClientEncoding :: Ptr PGconn -> CString -> IO CInt type PGVerbosity = CInt -foreign import ccall unsafe "libpq-fe.h PQsetErrorVerbosity" +foreign import ccall safe "libpq-fe.h PQsetErrorVerbosity" c_PQsetErrorVerbosity :: Ptr PGconn -> PGVerbosity -> IO PGVerbosity -foreign import ccall unsafe "libpq-fe.h PQtrace" +foreign import ccall safe "libpq-fe.h PQtrace" c_PQtrace :: Ptr PGconn -> Ptr CFile -> IO () -foreign import ccall unsafe "libpq-fe.h PQuntrace" +foreign import ccall safe "libpq-fe.h PQuntrace" c_PQuntrace :: Ptr PGconn -> IO () -foreign import ccall unsafe "libpq-fe.h PQsendQuery" +foreign import ccall safe "libpq-fe.h PQsendQuery" c_PQsendQuery :: Ptr PGconn -> CString ->IO CInt -foreign import ccall unsafe "libpq-fe.h PQsendQueryParams" +foreign import ccall safe "libpq-fe.h PQsendQueryParams" c_PQsendQueryParams :: Ptr PGconn -> CString -> CInt -> Ptr Oid -> Ptr CString -> Ptr CInt -> Ptr CInt -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQsendPrepare" +foreign import ccall safe "libpq-fe.h PQsendPrepare" c_PQsendPrepare :: Ptr PGconn -> CString -> CString -> CInt -> Ptr Oid -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQsendQueryPrepared" +foreign import ccall safe "libpq-fe.h PQsendQueryPrepared" c_PQsendQueryPrepared :: Ptr PGconn -> CString -> CInt -> Ptr CString -> Ptr CInt -> Ptr CInt -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQsendDescribePrepared" +foreign import ccall safe "libpq-fe.h PQsendDescribePrepared" c_PQsendDescribePrepared :: Ptr PGconn -> CString -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQsendDescribePortal" +foreign import ccall safe "libpq-fe.h PQsendDescribePortal" c_PQsendDescribePortal :: Ptr PGconn -> CString -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQflush" +foreign import ccall safe "libpq-fe.h PQflush" c_PQflush :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQgetCancel" +foreign import ccall safe "libpq-fe.h PQgetCancel" c_PQgetCancel :: Ptr PGconn -> IO (Ptr PGcancel) -foreign import ccall unsafe "libpq-fe.h &PQfreeCancel" +foreign import ccall safe "libpq-fe.h &PQfreeCancel" p_PQfreeCancel :: FunPtr (Ptr PGcancel -> IO ()) -foreign import ccall unsafe "libpq-fe.h PQcancel" +foreign import ccall safe "libpq-fe.h PQcancel" c_PQcancel :: Ptr PGcancel -> CString -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQnotifies" +foreign import ccall safe "libpq-fe.h PQnotifies" c_PQnotifies :: Ptr PGconn -> IO (Ptr Notify) -foreign import ccall unsafe "libpq-fe.h PQconsumeInput" +foreign import ccall safe "libpq-fe.h PQconsumeInput" c_PQconsumeInput :: Ptr PGconn ->IO CInt -foreign import ccall unsafe "libpq-fe.h PQisBusy" +foreign import ccall safe "libpq-fe.h PQisBusy" c_PQisBusy :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQsetnonblocking" +foreign import ccall safe "libpq-fe.h PQsetnonblocking" c_PQsetnonblocking :: Ptr PGconn -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQisnonblocking" +foreign import ccall safe "libpq-fe.h PQisnonblocking" c_PQisnonblocking :: Ptr PGconn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQgetResult" +foreign import ccall safe "libpq-fe.h PQgetResult" c_PQgetResult :: Ptr PGconn -> IO (Ptr PGresult) foreign import ccall safe "libpq-fe.h PQexec" @@ -2143,82 +2147,82 @@ foreign import ccall safe "libpq-fe.h PQdescribePrepared" foreign import ccall safe "libpq-fe.h PQdescribePortal" c_PQdescribePortal :: Ptr PGconn -> CString -> IO (Ptr PGresult) -foreign import ccall unsafe "libpq-fe.h &PQclear" +foreign import ccall safe "libpq-fe.h &PQclear" p_PQclear :: FunPtr (Ptr PGresult ->IO ()) -foreign import ccall unsafe "libpq-fe.h PQresultStatus" +foreign import ccall safe "libpq-fe.h PQresultStatus" c_PQresultStatus :: Ptr PGresult -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQresStatus" +foreign import ccall safe "libpq-fe.h PQresStatus" c_PQresStatus :: CInt -> IO CString -foreign import ccall unsafe "libpq-fe.h PQresultErrorMessage" +foreign import ccall safe "libpq-fe.h PQresultErrorMessage" c_PQresultErrorMessage :: Ptr PGresult -> IO CString -foreign import ccall unsafe "libpq-fe.h PQresultErrorField" +foreign import ccall safe "libpq-fe.h PQresultErrorField" c_PQresultErrorField :: Ptr PGresult -> CInt -> IO CString -foreign import ccall unsafe "libpq-fe.h PQntuples" +foreign import ccall safe "libpq-fe.h PQntuples" c_PQntuples :: Ptr PGresult -> CInt -foreign import ccall unsafe "libpq-fe.h PQnfields" +foreign import ccall safe "libpq-fe.h PQnfields" c_PQnfields :: Ptr PGresult -> CInt -foreign import ccall unsafe "libpq-fe.h PQfname" +foreign import ccall safe "libpq-fe.h PQfname" c_PQfname :: Ptr PGresult -> CInt -> IO CString -foreign import ccall unsafe "libpq-fe.h PQfnumber" +foreign import ccall safe "libpq-fe.h PQfnumber" c_PQfnumber :: Ptr PGresult -> CString -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQftable" +foreign import ccall safe "libpq-fe.h PQftable" c_PQftable :: Ptr PGresult -> CInt -> IO Oid -foreign import ccall unsafe "libpq-fe.h PQftablecol" +foreign import ccall safe "libpq-fe.h PQftablecol" c_PQftablecol :: Ptr PGresult -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQfformat" +foreign import ccall safe "libpq-fe.h PQfformat" c_PQfformat :: Ptr PGresult -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQftype" +foreign import ccall safe "libpq-fe.h PQftype" c_PQftype :: Ptr PGresult -> CInt -> IO Oid -foreign import ccall unsafe "libpq-fe.h PQfmod" +foreign import ccall safe "libpq-fe.h PQfmod" c_PQfmod :: Ptr PGresult -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQfsize" +foreign import ccall safe "libpq-fe.h PQfsize" c_PQfsize :: Ptr PGresult -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQgetvalue" +foreign import ccall safe "libpq-fe.h PQgetvalue" c_PQgetvalue :: Ptr PGresult -> CInt -> CInt -> IO CString -foreign import ccall unsafe "libpq-fe.h PQgetisnull" +foreign import ccall safe "libpq-fe.h PQgetisnull" c_PQgetisnull :: Ptr PGresult -> CInt -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQgetlength" +foreign import ccall safe "libpq-fe.h PQgetlength" c_PQgetlength :: Ptr PGresult -> CInt -> CInt -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQnparams" +foreign import ccall safe "libpq-fe.h PQnparams" c_PQnparams :: Ptr PGresult -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQparamtype" +foreign import ccall safe "libpq-fe.h PQparamtype" c_PQparamtype :: Ptr PGresult -> CInt -> IO Oid -foreign import ccall unsafe "stdio.h fdopen" +foreign import ccall safe "stdio.h fdopen" c_fdopen :: CInt -> CString -> IO (Ptr CFile) -foreign import ccall unsafe "libpq-fe.h PQprint" +foreign import ccall safe "libpq-fe.h PQprint" c_PQprint :: Ptr CFile -> Ptr PGresult -> Ptr PrintOpt -> IO () -foreign import ccall unsafe "libpq-fe.h PQcmdStatus" +foreign import ccall safe "libpq-fe.h PQcmdStatus" c_PQcmdStatus :: Ptr PGresult -> IO CString -foreign import ccall unsafe "libpq-fe.h PQcmdTuples" +foreign import ccall safe "libpq-fe.h PQcmdTuples" c_PQcmdTuples :: Ptr PGresult -> IO CString -foreign import ccall unsafe "libpq-fe.h PQoidValue" +foreign import ccall safe "libpq-fe.h PQoidValue" c_PQoidValue :: Ptr PGresult -> IO Oid -foreign import ccall unsafe "libpq-fe.h PQescapeStringConn" +foreign import ccall safe "libpq-fe.h PQescapeStringConn" c_PQescapeStringConn :: Ptr PGconn -> Ptr Word8 -- Actually (CString) -> CString @@ -2226,17 +2230,17 @@ foreign import ccall unsafe "libpq-fe.h PQescapeStringConn" -> Ptr CInt -> IO CSize -foreign import ccall unsafe "libpq-fe.h PQescapeByteaConn" +foreign import ccall safe "libpq-fe.h PQescapeByteaConn" c_PQescapeByteaConn :: Ptr PGconn -> CString -- Actually (Ptr CUChar) -> CSize -> Ptr CSize -> IO (Ptr Word8) -- Actually (IO (Ptr CUChar)) -foreign import ccall unsafe "libpq-fe.h PQunescapeBytea" +foreign import ccall safe "libpq-fe.h PQunescapeBytea" c_PQunescapeBytea :: CString -- Actually (Ptr CUChar) -> Ptr CSize -> IO (Ptr Word8) -- Actually (IO (Ptr CUChar)) -foreign import ccall unsafe "libpq-fe.h &PQfreemem" +foreign import ccall safe "libpq-fe.h &PQfreemem" p_PQfreemem :: FunPtr (Ptr a -> IO ()) diff --git a/Database/PQ/Utils.hs b/Database/PQ/Utils.hs new file mode 100644 index 0000000..d97d8ec --- /dev/null +++ b/Database/PQ/Utils.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, CPP #-} +-- | +-- Module: Database.PQ.Utils +-- +-- Utility module that adds error handling and convenient conversion to +-- and from SQL values. +-- +-- This module is meant to be used instead of "Database.PQ", with the latter +-- imported qualified if you need its entry points and types: +-- +-- >import Database.PQ.Utils +-- >import qualified Database.PQ as PQ + +module Database.PQ.Utils ( + -- * Connection + Connection, + connectdb, + + -- * Error handling + SqlError(..), + sqlError, + throwSqlError, + throwPQError, + + -- * Command execution + execCommand, + execCommandParams, + execTuples, + execTuplesParams, + withTransaction, + withTransactionCustom, + + -- * Conversion from SQL results + -- | Read tuples from 'PQ.Result' structures using a convenient + -- 'Applicative' interface. Columns are requested by name. Column names + -- are looked up only once per result set. + -- + -- Example: + -- + -- >{-# LANGUAGE OverloadedStrings #-} + -- > + -- >import Control.Applicative + -- >import Database.PQ.Utils + -- >import qualified Data.Vector as V + -- > + -- >main :: IO () + -- >main = do + -- > conn <- connectdb "" + -- > res <- execTuples conn "SELECT x, x*x AS y FROM generate_series(1, 10) AS x" + -- > + -- > let row :: ReadResult (Int, Int) + -- > row = (,) + -- > <$> columnNotNull "x" fromInt + -- > <*> columnNotNull "y" fromInt + -- > + -- > vec <- readResult row res + -- > V.forM_ vec print + + ReadResult, + readResult, + + -- ** Column retrieval + column, + column', + columnNotNull, + columnNotNull', + + -- ** Value conversion functions + -- | + -- These functions assume that the result has been retrieved in text + -- mode. If you use the 'execTuples' and 'execTuplesParams' functions from + -- this module, you don't need to worry about this. If you use 'PQ.execParams' + -- from "Database.PQ" and specify Binary as the 'PQ.Format', these functions + -- will not work correctly on datums retrieved from the 'PQ.Result'. + fromText, + fromBytea, + fromBool, + fromInt, + fromFloat, + fromReadS, + + -- * Conversion to SQL parameters + PQParam, + toText, + toBytea, + toBool, + toInt, + toFloat, + + -- * Miscellaneous + consume +) where + +import Database.PQ (Connection) +import qualified Database.PQ as PQ + +import Control.Applicative (Applicative(..), (<$>)) +import Data.ByteString (ByteString) +import Control.Exception (Exception) +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import Numeric (readSigned, readDec, readFloat, showSigned, showInt, showFloat) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Control.Exception as E +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.Vector as V + +data SqlError = SqlError String + deriving (Show, Typeable) + +instance Exception SqlError + +-- | Throw a 'SqlError' exception from pure code. +sqlError :: String -> a +sqlError = E.throw . SqlError + +-- | Throw a 'SqlError' exception from within the IO monad. +throwSqlError :: String -> IO a +throwSqlError = E.throwIO . SqlError + +-- | Like 'throwSqlError', but handle the format returned by 'PQ.errorMessage' +-- and 'PQ.resultErrorMessage'. For example, these functions might return an +-- empty string if the previous command did not produce an error. Although +-- using such functions when an error did not occur is a bug, it's confusing +-- when a program fails and prints nothing. +throwPQError :: Maybe ByteString -> IO a +throwPQError errmsg = + case errmsg of + Nothing -> throwSqlError "(null)" + Just x | B.null x -> throwSqlError "(empty error message)" + | otherwise -> throwSqlError $ UTF8.toString x + +checkConnection :: Connection -> IO Connection +checkConnection conn = do + status <- PQ.status conn + if status == PQ.ConnectionOk + then return conn + else throwPQError =<< PQ.errorMessage conn + +checkResult :: PQ.ExecStatus -> Connection -> Maybe PQ.Result -> IO PQ.Result +checkResult expectedStatus conn mresult = + case mresult of + Nothing -> throwPQError =<< PQ.errorMessage conn + Just result -> do + actualStatus <- PQ.resultStatus result + if actualStatus == expectedStatus + then return result + else let wrongStatus = throwSqlError $ + "Expected status " ++ show expectedStatus ++ + ", but command produced " ++ show actualStatus + in case actualStatus of + PQ.EmptyQuery -> throwSqlError "Empty query string" + + -- Non-error result codes + PQ.CommandOk -> wrongStatus + PQ.TuplesOk -> wrongStatus + PQ.CopyOut -> wrongStatus + PQ.CopyIn -> wrongStatus + + -- Error / unrecognized status + _ -> throwPQError =<< PQ.resultErrorMessage result + +-- | Make a new database connection (using 'PQ.connectdb' from "Database.PQ"). +-- If the connection fails, throw a 'SqlError' describing the error. +connectdb :: ByteString -> IO Connection +connectdb conninfo = checkConnection =<< PQ.connectdb conninfo + +-- | Execute a query that is expected to return no data. +-- +-- If the query fails, or does in fact return a result set, +-- a 'SqlError' is thrown. +execCommand :: Connection -> ByteString -> IO PQ.Result +execCommand conn query = checkResult PQ.CommandOk conn =<< PQ.exec conn query + +-- | Execute a query that is expected to return data (such as @SELECT@ or @SHOW@). +-- +-- If the query fails, or does not return a result set, a 'SqlError' is thrown. +-- +-- Bear in mind that in PostgreSQL, result rows are not returned lazily. +-- If you want to read a large result set incrementally, you +-- will need to use a cursor. See 'consume' for an example. +execTuples :: Connection -> ByteString -> IO PQ.Result +execTuples conn query = checkResult PQ.TuplesOk conn =<< PQ.exec conn query + +-- | Run an action within a transaction. +-- +-- If an exception arises, the transaction will be rolled back. +withTransaction :: Connection -> IO a -> IO a +withTransaction conn = withTransactionCustom conn "BEGIN" + +-- | Like 'withTransaction', but with a custom \"begin\" statement. +-- +-- @'withTransaction' conn = 'withTransactionCustom' conn \"BEGIN\"@ +withTransactionCustom :: Connection -> ByteString -> IO a -> IO a +withTransactionCustom conn begin action + = portableMask $ \restore -> do + _ <- execCommand conn begin + r <- restore action `E.onException` execCommand conn "ROLLBACK" + _ <- execCommand conn "COMMIT" + return r + +-- | Like 'E.mask', but backported to base before version 4.3.0. +-- +-- Note that the restore callback is monomorphic, unlike in 'E.mask'. +-- This could be fixed by changing the type signature, but it would +-- require us to enable the RankNTypes extension. The 'withTransactionCustom' +-- function above calls the restore callback only once, so we don't +-- need that polymorphism. +portableMask :: ((IO a -> IO a) -> IO b) -> IO b +#if MIN_VERSION_base(4,3,0) +portableMask io = E.mask $ \restore -> io restore +#else +portableMask io = do + b <- E.blocked + E.block $ io $ \m -> if b then m else E.unblock m +#endif + +type PQParam = (PQ.Oid, ByteString, PQ.Format) + +-- | Like execCommand, but with the ability to pass parameters separately +-- from the SQL command text. +-- +execCommandParams :: Connection -> ByteString -> [Maybe PQParam] -> IO PQ.Result +execCommandParams conn query params = + checkResult PQ.CommandOk conn + =<< PQ.execParams conn query params PQ.Text + +-- | Like execTuples, but with the ability to pass parameters separately +-- from the SQL command text. +-- +execTuplesParams :: Connection -> ByteString -> [Maybe PQParam] -> IO PQ.Result +execTuplesParams conn query params = + checkResult PQ.TuplesOk conn + =<< PQ.execParams conn query params PQ.Text + +-- | Result parser. +newtype ReadResult a = ReadResult {runReadResult :: PQ.Result -> IO (PQ.Row -> IO a)} + +instance Functor ReadResult where + fmap f a = ReadResult $ \res -> do + ac <- runReadResult a res + return $ \row -> do + v <- ac row + return (f v) + +instance Applicative ReadResult where + pure x = ReadResult $ \_ -> return $ \_ -> return x + f1 <*> f2 = ReadResult $ \res -> do + c1 <- runReadResult f1 res + c2 <- runReadResult f2 res + return $ \row -> do + v1 <- c1 row + v2 <- c2 row + return (v1 v2) + +-- | Execute a 'ReadResult' computation on a 'PQ.Result'. +-- +-- Each item in the resulting 'Vector' corresponds to a /row/ of the +-- result set. +-- +-- This function is strict in @record@. As long as @record@ is in turn +-- strict in its members, and as long as those members do not contain +-- original copies of values returned by 'PQ.getvalue', result records +-- should not pin down the entire 'PQ.Result'. +readResult :: ReadResult record -> PQ.Result -> IO (Vector record) +readResult r res = do + readRowAction <- runReadResult r res + count <- PQ.ntuples res + V.generateM count $ \i -> do + row <- readRowAction (PQ.toRow i) + return $! row + +columnHelper :: String -> (PQ.Result -> PQ.Row -> PQ.Column -> IO a) -> ReadResult a +columnHelper colname f = ReadResult $ \res -> do + m <- PQ.fnumber res (C.pack colname) + case m of + Just col -> return $ \row -> do + v <- f res row (PQ.toColumn col) + return $! v + Nothing -> throwSqlError $ "Result set does not have column \"" + ++ colname ++ "\"" + +-- | Retrieve a (nullable) column by name, and convert it using the given function. +column :: String -> (ByteString -> a) -> ReadResult (Maybe a) +column colname f = columnHelper colname $ \res row col -> do + m <- PQ.getvalue res row col + case m of + Nothing -> return Nothing + Just v -> return $! Just $! f v + +-- | Retrieve a column by name and convert it. If the value is null, +-- throw a 'SqlError'. +columnNotNull :: String -> (ByteString -> a) -> ReadResult a +columnNotNull colname f = columnHelper colname $ \res row col -> do + m <- PQ.getvalue res row col + case m of + Just v -> return $! f v + Nothing -> throwSqlError $ "Unexpected null value in column \"" + ++ colname ++ "\"" + +-- | Like 'column', but use 'PQ.getvalue'' instead of 'PQ.getvalue'. +column' :: String -> (ByteString -> a) -> ReadResult (Maybe a) +column' colname f = columnHelper colname $ \res row col -> do + v <- PQ.getvalue' res row col + return (f <$> v) + +-- | Like 'columnNotNull', but use 'PQ.getvalue'' instead of 'PQ.getvalue'. +columnNotNull' :: String -> (ByteString -> a) -> ReadResult a +columnNotNull' colname f = columnHelper colname $ \res row col -> do + m <- PQ.getvalue' res row col + case m of + Just v -> return (f v) + Nothing -> throwSqlError $ "Unexpected null value in column \"" + ++ colname ++ "\"" + +-- | Convert a @TEXT@ datum to a 'ByteString'. This is just a 'B.copy'. +fromText :: ByteString -> ByteString +fromText = B.copy + +-- | Convert a @BYTEA@ datum to a 'ByteString'. This performs conversion +-- using 'PQ.unescapeBytea', throwing a 'SqlError' on failure. +fromBytea :: ByteString -> ByteString +fromBytea str = + case unsafePerformIO $ PQ.unescapeBytea str of + Just bstr -> bstr + Nothing -> sqlError "PQunescapeBytea failed" + +-- | Read a @BOOL@ datum. The text representation of a @BOOL@ is a single +-- character: @\'f\'@ or @\'t\'@. +fromBool :: ByteString -> Bool +fromBool str | str == C.singleton 'f' = False + | str == C.singleton 't' = True + | otherwise = sqlError "Invalid syntax for fromBool" + +-- | Convert a datum by converting its bytes to a 'String' and feeding +-- it to a 'ReadS' parser. +-- +-- See 'fromInt' and 'fromFloat' for examples. +fromReadS :: ReadS a -- ^ Parser + -> String -- ^ Error message if parsing fails + -> ByteString -- ^ Datum in text format (should consist solely + -- of ASCII characters) + -> a +fromReadS readS errmsg bstr = + case [x | (x, "") <- readS (C.unpack bstr)] of + [x] -> x + [] -> sqlError errmsg + _ -> sqlError (errmsg ++ " (ambiguous parse)") + +-- | Read any datum that can be parsed as an integer. +-- +-- @'fromInt' = 'fromReadS' ('readSigned' 'readDec') \"Invalid syntax for fromInt\"@ +fromInt :: (Integral a) => ByteString -> a +fromInt = fromReadS (readSigned readDec) "Invalid syntax for fromInt" + +-- | Read any datum that can be parsed as a floating point number. +-- +-- This function should be able to accept the PostgreSQL text representation +-- of any of the numeric types (except for weird ones like @MONEY@), but this has +-- not been proven. The @NaN@ and @Infinity@ syntax PostgreSQL uses are +-- recognized by Haskell's 'readFloat'. +-- +-- @'fromFloat' = 'fromReadS' ('readSigned' 'readFloat') \"Invalid syntax for fromFloat\"@ +fromFloat :: (RealFrac a) => ByteString -> a +fromFloat = fromReadS (readSigned readFloat) "Invalid syntax for fromFloat" + +toText :: ByteString -> PQParam +toText txt = (0, txt, PQ.Text) + +toBytea :: ByteString -> PQParam +toBytea btxt = (0, btxt, PQ.Binary) + +toBool :: Bool -> PQParam +toBool False = toText (C.singleton 'f') +toBool True = toText (C.singleton 't') + +toInt :: (Integral a) => a -> PQParam +toInt n = toText $ C.pack $ showSigned showInt 0 n "" + +toFloat :: (RealFloat a) => a -> PQParam +toFloat n = toText $ C.pack $ showFloat n "" + +-- | Repeatedly execute a query until it returns zero rows. +-- +-- Each non-empty result set is passed to the callback action. +-- +-- Example: +-- +-- >consumeExample :: Connection -> IO () +-- >consumeExample conn = +-- > withTransaction conn $ do +-- > _ <- execCommand conn +-- > $ "DECLARE series_cursor NO SCROLL CURSOR FOR" +-- > ++ " SELECT x, x*x AS y FROM generate_series(1,100) AS x" +-- > +-- > let parser :: ReadResult (Int, Int) +-- > parser = (,) +-- > <$> columnNotNull "x" fromInt +-- > <*> columnNotNull "y" fromInt +-- > +-- > consume conn "FETCH FORWARD 7 FROM series_cursor" parser +-- > $ \set -> do +-- > putStrLn $ "Chunk " ++ show (V.length set) +-- > V.forM_ set $ \(x, y) -> +-- > putStrLn $ "\t" ++ show x ++ "\t" ++ show y +consume :: Connection -- ^ Database connection + -> ByteString -- ^ Query + -> ReadResult record -- ^ Result parser + -> (Vector record -> IO a) -- ^ Callback + -> IO () +consume conn query parser callback = loop + where + loop = do + res <- execTuples conn query + ntuples <- PQ.ntuples res + case ntuples of + _ | ntuples > 0 -> do + _ <- callback =<< readResult parser res + loop + | ntuples == 0 -> return () + | otherwise -> throwSqlError "PQntuples returned a negative number" diff --git a/libpq.cabal b/libpq.cabal index e70d0c6..f497a5c 100644 --- a/libpq.cabal +++ b/libpq.cabal @@ -21,12 +21,22 @@ Build-type: Custom Cabal-version: >=1.8 Library Exposed-modules: Database.PQ + Database.PQ.Utils Build-depends: base >= 4 && < 5 , bytestring , unix + , utf8-string + , vector GHC-Options: -Wall Extra-Libraries: pq -- Other-modules: Build-tools: hsc2hs + + other-extensions: CPP + , DeriveDataTypeable + , EmptyDataDecls + , ForeignFunctionInterface + , OverloadedStrings + , ScopedTypeVariables