| Module : Database.PostgreSQL.PGFunctions Copyright : (c) 2004 Oleg Kiselyov, Alistair Bayley License : BSD-style Maintainer : oleg@pobox.com, alistair@abayley.org Stability : experimental Portability : non-portable Simple wrappers for PostgreSQL functions (FFI) plus middle-level wrappers (in the second part of this file) > {-# OPTIONS -fglasgow-exts #-} > {-# LANGUAGE ForeignFunctionInterface #-} > module Database.PostgreSQL.PGFunctions where > import Prelude hiding (catch) > import Database.Util > import Control.Applicative > import Control.Monad > import Control.Exception.Extensible > import Data.Char > import Data.Dynamic > import Data.Int > import Data.Time > import Foreign > import Foreign.C > import Foreign.C.UTF8 > import Foreign.Ptr > import System.IO > import System.Time > import Text.Printf > data DBHandleStruct = PGconn > type DBHandle = Ptr DBHandleStruct > data StmtStruct = PGresult > type ResultSetHandle = Ptr StmtStruct > type Oid = CUInt -- from postgres_ext.h > type Format = CInt > type Void = () > type ParamLen = CInt > invalidOid = 0 > -- type Blob = Ptr Word8 > data PGException = PGException Int String > deriving (Typeable) > instance Show PGException where > show (PGException i s) = "PGException " ++ (show i) ++ " " ++ s > catchPG :: IO a -> (PGException -> IO a) -> IO a > throwPG :: Integral i => i -> String -> a > rethrowPG :: PGException -> a > instance Exception PGException > catchPG = catch > throwPG rc s = throw (PGException (fromIntegral rc) s) > rethrowPG = throw > cStr :: CStringLen -> CString > cStr = fst > cStrLen :: CStringLen -> CInt > cStrLen = fromIntegral . snd PG sends binary data in big-endian byte-order (AKA network byte order) at least according to the manual page for the DECLARE command (in the Reference section of the manual). The example C programs in the manual use the htonl/ntohl functions to reverse the byte order before-sending/after-receiving (resp.) I've included the decls here for reference, but we now use a Haskell function to achieve the same result. Note that this only works in little-endian platforms, like x86. We need something better to detect endian-ness and choose whether or not to reverse. include C:\MinGW\include\winsock.h foreign import stdcall "winsock.h htonl" htonl :: Word32 -> Word32 foreign import stdcall "winsock.h ntohl" ntohl :: Word32 -> Word32 > foreign import ccall "libpq-fe.h PQconnectdb" fPQconnectdb > :: CString -> IO DBHandle > foreign import ccall "libpq-fe.h PQfinish" fPQfinish > :: DBHandle -> IO () From the PostgreSQL 8.0.0 docs, postgresql/libpq.html: This function will close the connection to the server and attempt to reestablish a new connection to the same server, using all the same parameters previously used. This may be useful for error recovery if a working connection is lost. > foreign import ccall "libpq-fe.h PQreset" fPQreset > :: DBHandle -> IO () Returns the database name of the connection This is guaranteed by the Postgresql documentation to be a pure function > foreign import ccall "libpq-fe.h PQdb" fPQdb > :: DBHandle -> CString Inquire the connection status > type ConnStatusType = CInt -- enumeration, see libpq-fe.h > [eCONNECTION_OK,eCONNECTION_BAD] = [0..1]::[ConnStatusType] > foreign import ccall "libpq-fe.h PQstatus" fPQstatus > :: DBHandle -> IO ConnStatusType Returns the error message most recently generated by an operation on the connection. > foreign import ccall "libpq-fe.h PQerrorMessage" fPQerrorMessage > :: DBHandle -> IO CString Set client charset (UTF8 etc) > foreign import ccall "libpq-fe.h PQsetClientEncoding" fPQsetClientEncoding > :: DBHandle -> CString -> IO CString 28.10. Notice Processing We have a couple of callback hooks for server notice messages. The C decls are: typedef void (*PQnoticeReceiver) (void *arg, const PGresult *res); PQnoticeReceiver PQsetNoticeReceiver(PGconn *conn, PQnoticeReceiver proc, void *arg); typedef void (*PQnoticeProcessor) (void *arg, const char *message); PQnoticeProcessor PQsetNoticeProcessor(PGconn *conn, PQnoticeProcessor proc, void *arg); > type NoticeReceiver = Ptr () -> ResultSetHandle -> IO () > type NoticeProcessor = Ptr () -> CString -> IO () We need the wrapper to turn our NoticeReceiver-typed function into something libpq can consume. This decl will make GHC create the wrapper function for us. GHC generates files PGFunctions_stub.h and PGFunctions_stub.c. The wrapper decl syntax is odd, as it's more an export than an import... > foreign import ccall "wrapper" mkNoticeReceiver :: > NoticeReceiver -> IO (FunPtr NoticeReceiver) > foreign import ccall "wrapper" mkNoticeProcessor :: > NoticeProcessor -> IO (FunPtr NoticeProcessor) > foreign import ccall "libpq-fe.h PQsetNoticeReceiver" fPQsetNoticeReceiver > :: DBHandle -> FunPtr NoticeReceiver -> Ptr () -> IO (FunPtr NoticeReceiver) > foreign import ccall "libpq-fe.h PQsetNoticeProcessor" fPQsetNoticeProcessor > :: DBHandle -> FunPtr NoticeProcessor -> Ptr () -> IO (FunPtr NoticeProcessor) Execution of commands We don't use fPQexec; the docs suggest fPQexecParams is better anyway (better defense from SQL injection attacks, etc). foreign import ccall "libpq-fe.h PQexec" fPQexec :: DBHandle -> CString -> IO ResultSetHandle > foreign import ccall "libpq-fe.h PQexecParams" fPQexecParams > :: DBHandle -> CString -> CInt -> Ptr Oid -> Ptr Void -> Ptr ParamLen -> Ptr Format -> > CInt -> IO ResultSetHandle > foreign import ccall "libpq-fe.h PQprepare" fPQprepare > :: DBHandle -> CString -> CString -> CInt -> Ptr Oid -> IO ResultSetHandle > foreign import ccall "libpq-fe.h PQexecPrepared" fPQexecPrepared > :: DBHandle -> CString -> CInt -> Ptr Void -> Ptr ParamLen -> Ptr Format -> > CInt -> IO ResultSetHandle > foreign import ccall "libpq-fe.h PQresultStatus" fPQresultStatus > :: ResultSetHandle -> IO ExecStatusType > type ExecStatusType = CInt -- enumeration, see libpq-fe.h > (ePGRES_EMPTY_QUERY : > ePGRES_COMMAND_OK : > ePGRES_TUPLES_OK : > ePGRES_COPY_OUT : > ePGRES_COPY_IN : > ePGRES_BAD_RESPONSE : > ePGRES_NONFATAL_ERROR : > ePGRES_FATAL_ERROR : > _) > = [0..] :: [ExecStatusType] > (textResultSet:binaryResultSet:_) = [0,1] :: [CInt] > (textParameters:binaryParameters:_) = [0,1] :: [CInt] > foreign import ccall "libpq-fe.h PQresultErrorMessage" fPQresultErrorMessage > :: ResultSetHandle -> IO CString > foreign import ccall "libpq-fe.h PQclear" fPQclear > :: ResultSetHandle -> IO () Retrieving Query Result Information > foreign import ccall "libpq-fe.h PQntuples" fPQntuples > :: ResultSetHandle -> IO CInt > foreign import ccall "libpq-fe.h PQnfields" fPQnfields > :: ResultSetHandle -> IO CInt Inquiry about a column; Column numbers start at 0 > foreign import ccall "libpq-fe.h PQfname" fPQfname > :: ResultSetHandle -> CInt -> IO CString > foreign import ccall "libpq-fe.h PQfformat" fPQfformat > :: ResultSetHandle -> CInt -> IO CInt > foreign import ccall "libpq-fe.h PQftype" fPQftype > :: ResultSetHandle -> CInt -> IO Oid Really getting the values > foreign import ccall "libpq-fe.h PQgetvalue" fPQgetvalue > :: ResultSetHandle -> CInt -> CInt -> IO (Ptr Word8) > foreign import ccall "libpq-fe.h PQgetisnull" fPQgetisnull > :: ResultSetHandle -> CInt -> CInt -> IO CInt > foreign import ccall "libpq-fe.h PQgetlength" fPQgetlength > :: ResultSetHandle -> CInt -> CInt -> IO CInt 27.3.3. Retrieving Result Information for Other Commands > foreign import ccall "libpq-fe.h PQcmdStatus" fPQcmdStatus > :: ResultSetHandle -> IO CString > foreign import ccall "libpq-fe.h PQcmdTuples" fPQcmdTuples > :: ResultSetHandle -> IO CString > foreign import ccall "libpq-fe.h PQoidValue" fPQoidValue > :: ResultSetHandle -> IO Oid 27.8. Functions Associated with the COPY Command > foreign import ccall "libpq-fe.h PQputCopyData" fPQputCopyData > :: DBHandle -> Ptr Word8 -> CInt -> IO CInt > foreign import ccall "libpq-fe.h PQputCopyEnd" fPQputCopyEnd > :: DBHandle -> CString -> IO CInt > foreign import ccall "libpq-fe.h PQgetResult" fPQgetResult > :: DBHandle -> IO ResultSetHandle 27.9. Control Functions > type PGVerbosity = CInt -- enumeration, see libpq-fe.h > (ePQERRORS_TERSE : > ePQERRORS_DEFAULT : > ePQERRORS_VERBOSE : > _) = [0..]::[PGVerbosity] > foreign import ccall "libpq-fe.h PQsetErrorVerbosity" fPQsetErrorVerbosity > :: DBHandle -> PGVerbosity -> IO PGVerbosity 28.3. Large Objects. Client Interfaces > type LOAccessType = CInt -- enumeration, see libpq-fs.h > [eINV_WRITE,eINV_READ] = [0x00020000,0x00040000]::[LOAccessType] > type WhenceType = CInt -- enumeration, see > [eSEEK_SET,eSEEK_CUR,eSEEK_END] = [0,1,2]::[WhenceType] > foreign import ccall "libpq-fe.h lo_creat" flo_creat > :: DBHandle -> LOAccessType -> IO Oid > foreign import ccall "libpq-fe.h lo_import" flo_import > :: DBHandle -> CString -> IO Oid > foreign import ccall "libpq-fe.h lo_export" flo_export > :: DBHandle -> Oid -> CString -> IO CInt > foreign import ccall "libpq-fe.h lo_open" flo_open > :: DBHandle -> Oid -> LOAccessType -> IO CInt > foreign import ccall "libpq-fe.h lo_write" flo_write > :: DBHandle -> CInt -> Ptr Word8 -> CUInt -> IO CInt > foreign import ccall "libpq-fe.h lo_read" flo_read > :: DBHandle -> CInt -> Ptr Word8 -> CUInt -> IO CInt > foreign import ccall "libpq-fe.h lo_lseek" flo_lseek > :: DBHandle -> CInt -> CInt -> WhenceType -> IO CInt > foreign import ccall "libpq-fe.h lo_tell" flo_tell > :: DBHandle -> CInt -> IO CInt > foreign import ccall "libpq-fe.h lo_close" flo_close > :: DBHandle -> CInt -> IO CInt > foreign import ccall "libpq-fe.h lo_unlink" flo_unlink > :: DBHandle -> Oid -> IO CInt ------------------------------------------------------------------- Middle-level interface Get the current error message > getError :: DBHandle -> IO String > getError db = fPQerrorMessage db >>= peekUTF8String conn'parm is a string with all the attributes > openDb :: String -> IO DBHandle > openDb conn'parm = > withUTF8String conn'parm $ \cstr -> do > db <- fPQconnectdb cstr > if db == nullPtr > then throwPG (-1) "Null PGconn handle from PQconnectdb" > else do > rc <- fPQstatus db > if rc == eCONNECTION_OK > then do > setClientEncoding db "UTF8" > return db > else do > emsg <- getError db > fPQfinish db > throwPG rc emsg > closeDb :: DBHandle -> IO () > closeDb db = fPQfinish db > ignoreNotices _ _ = return () > reportNotices _ cstr = peekUTF8String cstr >>= hPutStrLn stderr > disableNoticeReporting db = do > r <- mkNoticeProcessor ignoreNotices > fPQsetNoticeProcessor db r nullPtr > enableNoticeReporting db = do > r <- mkNoticeProcessor reportNotices > fPQsetNoticeProcessor db r nullPtr > setErrorVerbosity db verb = fPQsetErrorVerbosity db verb >> return () > setClientEncoding db enc = > withUTF8String enc (\s -> fPQsetClientEncoding db s) ----------------------------------------------------------- Here we define a class useful in marshalling Haskell values to and from their Postgres counterparts (for binding and defining). We can find the OIDs with this query: select oid, typname from pg_type Types we'll map: 16 bool 17 bytea 18 char 25 text 21 int2 23 int4 20 int8 700 float4 701 float8 1114 timestamp 1184 timestamptz 1700 numeric 2950 uuid We are marshalling everything to and from Strings, so internal representations are irrelevant. For ints and doubles/floats, we need to check what size they are and choose the appropriate oid. PG timestamps are stored as 8-byte Doubles (i.e. double-precision floating point) holding the seconds before or after midnight 2000-01-01. date = oid 1082 (4 bytes) time = oid 1083 (8 bytes) timetz = oid 1266 (12 bytes) timestamp (sans time zone) = oid 1114 (8 bytes) timestamptz (with time zone) = oid 1184 (8 bytes) UUIDs are 128-bit values, with the pattern 8-4-4-4-12 e.g. a0eebc99-9c0b-4ef8-bb6d-6bb9bd380a11 Apparently Postgres will take any old crap as input i.e. surrounding braces optional, hyphens optional and anywhere. We'll take a sequence of 32 hex digits, interspersed with anything that's not a hex digit (we just strip them). We should have a newtype for UUID: > newtype UUID = UUID (Word64, Word64) > deriving (Eq, Ord) > instance Show UUID where > show (UUID (w1, w2)) = printf "UUID (0x%016x, 0x%016x)" w1 w2 > uuid2string :: UUID -> String > uuid2string (UUID (w1, w2)) = > tail (sub 0 8 ++ sub 8 4 ++ sub 12 4 ++ sub 16 4 ++ sub 20 12) > where > g = printf "%016x%016x" w1 w2 > sub i j = "-" ++ take j (drop i g) > string2uuid :: String -> UUID > string2uuid s = > if length stripped /= 32 > then error "string2uuid: malformed UUID - not 32 digits" > else UUID (read w1, read w2) > where > stripped = filter isHexDigit s > w1 = "0x" ++ take 16 stripped > w2 = "0x" ++ drop 16 stripped > class PGType a where > pgTypeFormat :: a -> Format -- ^ 0 == text, 1 == binary > pgTypeOid :: a -> Oid > pgNewValue :: a -> IO (Ptr Word8) > pgPeek :: Ptr Word8 -> IO a > pgSize :: a -> Int > -- default impls > pgTypeFormat _ = textParameters > instance PGType a => PGType (Maybe a) where > pgTypeFormat Nothing = pgTypeFormat (undefined::a) > pgTypeFormat (Just v) = pgTypeFormat v > pgTypeOid Nothing = pgTypeOid (undefined::a) > pgTypeOid (Just v) = pgTypeOid v > pgNewValue Nothing = return nullPtr > pgNewValue (Just v) = pgNewValue v > pgPeek ptr = if ptr == nullPtr then return Nothing else pgPeek ptr >>= return . Just > pgSize Nothing = 0 -- what is the size of a null value?... probably irrelevant > pgSize (Just v) = pgSize v timestamp and timestamp with time zone are probably exactly the same in terms of internal representation, so it's really just an input-output semantics that the two types distinguish. > instance PGType UTCTime where > pgTypeOid _ = 1114 > pgNewValue v = pgNewValue (utcTimeToPGDatetime v) > pgPeek p = pgPeek p >>= return . pgDatetimetoUTCTime > pgSize v = pgSize (utcTimeToPGDatetime v) > instance PGType CalendarTime where > pgTypeOid _ = 1114 > pgNewValue v = pgNewValue (calTimeToPGDatetime v) > pgPeek p = pgPeek p >>= return . pgDatetimetoCalTime > pgSize v = pgSize (calTimeToPGDatetime v) We assume all Strings are UTF8 encoded. > instance PGType String where > pgTypeOid _ = 25 > pgNewValue s = newUTF8String s >>= return . castPtr > pgPeek p = peekUTF8String (castPtr p) > pgSize s = lengthUTF8 s > instance PGType Bool where > pgTypeOid _ = 16 > pgNewValue v = pgNewValue (if v then "t" else "f") > pgPeek p = pgPeek p >>= return . readBool > where readBool s = if s == "t" then True else False > pgSize _ = sizeOf 'a' > byteaUnesc :: [Word8] -> [Word8] > byteaUnesc [] = [] > byteaUnesc (s:rest) = > if fromIntegral s == ord '\\' > then let (w8, rest') = parseEsc rest in w8 : byteaUnesc rest' > else s : byteaUnesc rest > where > parseEsc :: [Word8] -> (Word8, [Word8]) > parseEsc (a:rest) > | a == fromIntegral (ord '\'') = (a, rest) > | a == fromIntegral (ord '\\') = (a, rest) > parseEsc (a:b:c:rest) = (fromIntegral ((f a * 8 + f b) * 8 + f c), rest) > where f i = fromIntegral i - ord '0' > parseEsc s = error ("byteaUnesc: incomplete escape sequence: " ++ map (toEnum . fromIntegral) s) > word8AsOctet :: Word8 -> [Word8] > word8AsOctet w = fromIntegral (ord '\\') : plus0 a : plus0 b : plus0 c : [] > where > plus0 x = x + fromIntegral (ord '0') > a = shiftR (w .&. 192) 6 -- 128 + 64 > b = shiftR (w .&. 56) 3 -- 32 + 16 + 8 > c = w .&. 7 -- 4 + 2 + 1 > byteaEsc :: [Word8] -> [Word8] > byteaEsc (c:rest) > | c == backslash = backslash : backslash : byteaEsc rest > | c == quote = backslash : quote : byteaEsc rest > | c >= 0 && c <= 31 = word8AsOctet c ++ byteaEsc rest > | c >= 127 && c <= 255 = word8AsOctet c ++ byteaEsc rest > | otherwise = c : byteaEsc rest > where > backslash = fromIntegral (ord '\\') > quote = fromIntegral (ord '\'') > byteaEsc [] = [] > instance PGType [Word8] where > pgTypeOid _ = 17 > pgTypeFormat _ = binaryParameters > pgNewValue v = newArray0 0 v > -- byteaUnesc because the result is in bytea escaped format for some reason > pgPeek p = byteaUnesc <$> peekArray0 0 p > pgSize v = length v > instance PGType UUID where > pgTypeOid _ = 2950 > pgNewValue v = pgNewValue (uuid2string v) > pgPeek p = pgPeek p >>= return . string2uuid > pgSize v = pgSize (uuid2string v) > instance PGType Char where > pgTypeOid _ = 18 > -- need to cast to CChar because we don't know what the Storable instance > -- for Char does; does it write 4 bytes, or just the lowest one? > pgNewValue v = malloc >>= \p -> poke p (toCChar v) >> return (castPtr p) > pgPeek p = peek (castPtr p) >>= return . fromCChar > pgSize _ = sizeOf 'a' > instance PGType Int16 where > pgTypeOid _ = 21 > pgNewValue v = pgNewValue (show v) > pgPeek p = pgPeek p >>= return . read > pgSize v = pgSize (show v) > instance PGType Int32 where > pgTypeOid _ = 23 > pgNewValue v = pgNewValue (show v) > pgPeek p = pgPeek p >>= return . read > pgSize v = pgSize (show v) > instance PGType Int64 where > pgTypeOid _ = 20 > pgNewValue v = pgNewValue (show v) > pgPeek p = pgPeek p >>= return . read > pgSize v = pgSize (show v) > instance PGType Int where > pgTypeOid v = 1700 > pgNewValue v = pgNewValue (show v) > pgPeek p = pgPeek p >>= return . read > pgSize v = pgSize (show v) > instance PGType Integer where > pgTypeOid v = 1700 > pgNewValue v = pgNewValue (show v) > pgPeek p = pgPeek p >>= return . read > pgSize v = pgSize (show v) > instance PGType Double where > pgTypeOid v = 1700 > pgNewValue v = pgNewValue (show v) > pgPeek p = pgPeek p >>= return . read > pgSize v = pgSize (show v) > instance PGType Float where > pgTypeOid v = 1700 > pgNewValue v = pgNewValue (show v) > pgPeek p = pgPeek p >>= return . read > pgSize v = pgSize (show v) > data PGBindVal = PGBindVal > { bindValOid :: Oid > , bindValFormat :: Format > , bindValSize :: CInt > , bindValPtr :: IO (Ptr Word8) > } newBindVal is useful when creating lists of bind values, for passing to the stmtExec and prepare'n'exec functions. > newBindVal v = PGBindVal (pgTypeOid v) (pgTypeFormat v) (toCInt (pgSize v)) (pgNewValue v) > bindTypes vs = map bindValOid vs > toCChar :: Char -> CChar; toCChar = toEnum . fromEnum > fromCChar :: CChar -> Char; fromCChar = toEnum . fromEnum > toCInt :: Int -> CInt; toCInt = fromIntegral ----------------------------------------------------------- Check the ResultSetHandle returned by fPQexec and similar functions > check'stmt :: DBHandle -> ExecStatusType -> ResultSetHandle -> IO ResultSetHandle > check'stmt db _ stmt > | stmt == nullPtr = do -- something is really wrong > emsg <- getError db > rc <- fPQstatus db > throwPG rc emsg > check'stmt _ expected'status stmt = do > rc <- fPQresultStatus stmt > if rc == expected'status then return stmt > else do > msg <- fPQresultErrorMessage stmt >>= peekUTF8String > fPQclear stmt > throwPG rc msg > stmtPrepare :: DBHandle -> String -> String -> [Oid] -> IO String > stmtPrepare db stmt'name sqlText types = > withUTF8String stmt'name $ \csn -> do > withUTF8String sqlText $ \cstr -> do > withArray types $ \ctypearray -> do > let np = fromIntegral $ length types > stmt <- fPQprepare db csn cstr np ctypearray > check'stmt db ePGRES_COMMAND_OK stmt > fPQclear stmt -- doesn't have any useful info > return stmt'name Execute some kind of statement that returns no tuples. Because this is a frequently used function, we code it specially (rather than invoking a more generic execCommand). > nqExec :: DBHandle -> String -> IO (String, String, Oid) > nqExec db sqlText = > withUTF8String sqlText $ \cstr -> > do > stmt <- fPQexecParams db cstr 0 nullPtr nullPtr nullPtr nullPtr textResultSet > >>= check'stmt db ePGRES_COMMAND_OK > -- save all information from PGresult and free it > cmd'status <- fPQcmdStatus stmt >>= peekUTF8String > cmd'ntuples <- fPQcmdTuples stmt >>= peekUTF8String > cmd'oid <- fPQoidValue stmt > fPQclear stmt > return (cmd'status, cmd'ntuples, cmd'oid) > execCommand :: DBHandle -> String -> [PGBindVal] -> IO (String, String, Oid) > execCommand db sqlText bindvals = do > stmtPrepare db "" sqlText (bindTypes bindvals) > execPreparedCommand db "" bindvals | This is for commands, as opposed to queries. The query equivalent of 'execPreparedCommand' is 'stmtExec'. > execPreparedCommand :: DBHandle -> String -> [PGBindVal] -> IO (String, String, Oid) > execPreparedCommand db stmtname bindvals = do > (rs, ntuples) <- execPrepared db stmtname bindvals ePGRES_COMMAND_OK > -- save all information from PGresult and free it > cmd'status <- fPQcmdStatus rs >>= peekUTF8String > cmd'ntuples <- fPQcmdTuples rs >>= peekUTF8String > cmd'oid <- fPQoidValue rs > stmtFinalise rs > return (cmd'status, cmd'ntuples, cmd'oid) Prepare and Execute a query. Returns results as binary. > stmtExecImm :: DBHandle -> String -> [PGBindVal] -> IO (ResultSetHandle, Int) > stmtExecImm db sqlText bindvals = do > let np = fromIntegral $ length bindvals > withUTF8String sqlText $ \cstr -> do > withArray (map bindValOid bindvals) $ \coidarray -> do > withArray (map bindValSize bindvals) $ \clenarray -> do > withArray (map bindValFormat bindvals) $ \cformatarray -> do > -- The bindValPtrs are IO actions; executing them (via sequence) > -- creates the bind values (allocates storage, pokes values, etc). > -- We must remember to free these later. > paramlist <- sequence (map bindValPtr bindvals) > withArray paramlist $ \cparamarray -> do > rs <- fPQexecParams db cstr np coidarray (castPtr cparamarray) clenarray cformatarray textResultSet > mapM_ (\p -> if p == nullPtr then return () else free p) paramlist > check'stmt db ePGRES_TUPLES_OK rs > ntuples <- fPQntuples rs > return (rs, fromIntegral ntuples) A simple version with no binding parameters and returning results as text > stmtExecImm0 :: DBHandle -> String -> IO (ResultSetHandle, Int) > stmtExecImm0 db sqlText = > withUTF8String sqlText $ \cstr -> do > rs <- fPQexecParams db cstr 0 nullPtr nullPtr nullPtr nullPtr textResultSet > check'stmt db ePGRES_TUPLES_OK rs > ntuples <- fPQntuples rs > return (rs, fromIntegral ntuples) Execute a previously prepared query, with no params. > stmtExec0 :: DBHandle -> String -> IO (ResultSetHandle, Int) > stmtExec0 db stmt'name = stmtExec0bt db stmt'name binaryResultSet > stmtExec0t :: DBHandle -> String -> IO (ResultSetHandle, Int) > stmtExec0t db stmt'name = stmtExec0bt db stmt'name textResultSet > stmtExec0bt db stmt'name binary_or_text = > withUTF8String stmt'name $ \cstmtname -> do > rs <- fPQexecPrepared db cstmtname 0 nullPtr nullPtr nullPtr > binary_or_text > check'stmt db ePGRES_TUPLES_OK rs > ntuples <- fPQntuples rs > return (rs, fromIntegral ntuples) Execute a previously prepared query, with params. > stmtExec :: DBHandle -> String -> [PGBindVal] -> IO (ResultSetHandle, Int) > stmtExec db stmt'name bindvals = execPrepared db stmt'name bindvals ePGRES_TUPLES_OK This is used for both queries and commands. We have to pass the expected PQresult code, because queries return ePGRES_TUPLES_OK while commands return ePGRES_COMMAND_OK. > execPrepared :: DBHandle -> String -> [PGBindVal] -> CInt -> IO (ResultSetHandle, Int) > execPrepared db stmt'name bindvals rc = do > let np = fromIntegral $ length bindvals > withUTF8String stmt'name $ \cstmtname -> do > withArray (map bindValSize bindvals) $ \clenarray -> do > withArray (map bindValFormat bindvals) $ \cformatarray -> do > -- The bindValPtrs are IO actions; executing them (via sequence) > -- creates the bind values (allocates storage, pokes values, etc). > -- We must remember to free these later. > paramlist <- sequence (map bindValPtr bindvals) > withArray paramlist $ \cparamarray -> do > rs <- fPQexecPrepared db cstmtname np (castPtr cparamarray) clenarray cformatarray textResultSet > mapM_ (\p -> if p == nullPtr then return () else free p) paramlist > check'stmt db rc rs > ntuples <- fPQntuples rs > return (rs, fromIntegral ntuples) > prepare'n'exec :: DBHandle -> String -> String -> [PGBindVal] -> IO (ResultSetHandle, Int) > prepare'n'exec db stmtname stmt bindvals = do > let np = fromIntegral $ length bindvals > withUTF8String stmtname $ \cstmtname -> do > withUTF8String stmt $ \cstmt -> do > withArray (map bindValOid bindvals) $ \coidarray -> do > rs <- fPQprepare db cstmtname cstmt np coidarray > check'stmt db ePGRES_COMMAND_OK rs > execPrepared db stmtname bindvals ePGRES_TUPLES_OK Free storage, that is. No error in Postgres > stmtFinalise :: ResultSetHandle -> IO () > stmtFinalise = fPQclear |Column numbers are zero-indexed, so subtract one from given index (we present a one-indexed interface). So are the row numbers. > colValPtr :: ResultSetHandle -> Int -> Int -> IO (Ptr Word8) > colValPtr rs row col = do > nr <- fPQntuples rs > nc <- fPQnfields rs > if (fromIntegral nr) < row || row < 1 > then throwPG (-1) ("Attempted fetch from invalid row number " ++ show row) > else > if (fromIntegral nc) < col || col < 1 > then throwPG (-1) ("Attempted fetch from invalid column number " ++ show col) > else fPQgetvalue rs (toCInt (row-1)) (toCInt (col-1)) >>= return . castPtr > colVal :: PGType a => ResultSetHandle -> Int -> Int -> IO a > colVal rs row col = colValPtr rs row col >>= pgPeek > colValString :: ResultSetHandle -> Int -> Int -> IO String > colValString = colVal > colValBool :: ResultSetHandle -> Int -> Int -> IO Bool > colValBool = colVal > colValInt :: ResultSetHandle -> Int -> Int -> IO Int > colValInt = colVal > colValInt64 :: ResultSetHandle -> Int -> Int -> IO Int64 > colValInt64 = colVal > colValDouble :: ResultSetHandle -> Int -> Int -> IO Double > colValDouble = colVal > colValFloat :: ResultSetHandle -> Int -> Int -> IO Float > colValFloat = colVal > colValBytea :: ResultSetHandle -> Int -> Int -> IO [Word8] > colValBytea = colVal > colValUUID :: ResultSetHandle -> Int -> Int -> IO UUID > colValUUID = colVal > colValUTCTime :: ResultSetHandle -> Int -> Int -> IO UTCTime > colValUTCTime = colVal > colValCalTime :: ResultSetHandle -> Int -> Int -> IO CalendarTime > colValCalTime = colVal > colValNull :: ResultSetHandle -> Int -> Int -> IO Bool > colValNull rs row col = do > ind <- fPQgetisnull rs (toCInt (row-1)) (toCInt (col-1)) > return (ind /= 0) > {- > colValBlob :: ResultSetHandle -> Int -> Int -> IO (ForeignPtr Blob) > colValBlob rs row col = do > let ccolnum = fromIntegral (colnum - 1) > bytes <- sqliteColumnBytes stmt ccolnum > src <- sqliteColumnBlob stmt ccolnum > buffer <- mallocForeignPtrBytes bytes > withForeignPtr buffer $ \dest -> copyBytes dest src bytes > return (castForeignPtr buffer) > -} > substituteBindPlaceHolders sql = sbph sql 1 False "" > sbph :: String -> Int -> Bool -> String -> String > sbph [] _ _ acc = reverse acc > sbph ('\'':cs) i inQuote acc = sbph cs i (not inQuote) ('\'':acc) > sbph ('?':cs) i False acc = sbph cs (i+1) False ((reverse (show i)) ++ ('$':acc)) > sbph (c:cs) i inQuote acc = sbph cs i inQuote (c:acc) Execute the COPY FROM STDIN command > nqCopyIn_buflen :: Int > nqCopyIn_buflen = 8192 > nqCopyIn :: DBHandle -> String -> Handle -> IO () > nqCopyIn db sqlText hin = > withUTF8String sqlText $ \cstr -> > allocaBytes nqCopyIn_buflen $ \buffer -> > do > stmt <- fPQexecParams db cstr 0 nullPtr nullPtr nullPtr nullPtr 0 > >>= check'stmt db ePGRES_COPY_IN > let check'copy'status 1 = return () > check'copy'status _ = do > emsg <- getError db > rc <- fPQstatus db > throwPG rc emsg > let loop = do > len <- hGetBuf hin buffer nqCopyIn_buflen > if len < 0 then withUTF8String "IO error" $ fPQputCopyEnd db > else if len == 0 then fPQputCopyEnd db nullPtr > else fPQputCopyData db buffer (fromIntegral len) >>= > check'copy'status >> loop > res <- loop > fPQclear stmt > check'copy'status res > -- finishing, checking the final status > fPQgetResult db >>= check'stmt db ePGRES_COMMAND_OK >>= fPQclear