hdbi-postgresql (empty) → 1.0.0
raw patch · 8 files changed
+1394/−0 lines, 8 filesdep +Decimaldep +HUnitdep +QuickChecksetup-changed
Dependencies added: Decimal, HUnit, QuickCheck, attoparsec, base, blaze-builder, bytestring, containers, derive, hdbi, ieee754, mtl, old-locale, postgresql-libpq, postgresql-simple, quickcheck-assertions, quickcheck-instances, safe, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, uuid
Files
- Database/HDBI/PostgreSQL.hs +30/−0
- Database/HDBI/PostgreSQL/Implementation.hs +581/−0
- Database/HDBI/PostgreSQL/Parser.hs +157/−0
- LICENSE +27/−0
- Setup.hs +2/−0
- hdbi-postgresql.cabal +105/−0
- testsrc/puretests.hs +256/−0
- testsrc/runtests.hs +236/−0
+ Database/HDBI/PostgreSQL.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE+ TypeFamilies+, DeriveDataTypeable+, OverloadedStrings+ #-}++{- |+ Module : Database.HDBI.PostgreSQL+ Copyright : Copyright (C) 2005-2011 John Goerzen+ License : BSD3++ Maintainer : Aleksey Uymanov <s9gf4ult@gmail.com>+ Stability : experimental+ Portability: portable++HDBI driver interface for PostgreSQL 8.x and above++Written by John Goerzen, jgoerzen\@complete.org++-}++module Database.HDBI.PostgreSQL+ (+ PostgreConnection(..)+ , PostgreStatement(..)+ , PGStatementState(..)+ , connectPostgreSQL+ ) where++import Database.HDBI.PostgreSQL.Implementation
+ Database/HDBI/PostgreSQL/Implementation.hs view
@@ -0,0 +1,581 @@+{-# LANGUAGE+ TypeFamilies+, DeriveDataTypeable+, OverloadedStrings+ #-}++{- |+ Module : Database.HDBI.PostgreSQL.Implementation+ Copyright : Copyright (C) 2005-2013 John Goerzen+ License : BSD3++ Maintainer : Aleksey Uymanov <s9gf4ult@gmail.com>+ Stability : experimental+ Portability: portable+-}+++module Database.HDBI.PostgreSQL.Implementation+ (+ -- * Types+ PostgreConnection(..)+ , PGStatementState(..)+ , PostgreStatement(..)+ -- * Connection functions+ , connectPostgreSQL+ , withPGConnection+ -- * Data manipulating functions+ , sqlValueToNative+ , formatUTC+ , formatDay+ , formatT+ , formatDT+ , formatBits+ , o2b+ , nativeToSqlValue+ , parseT+ , parseDT+ , parseD+ , parseUTC+ , parseBit+ -- * Miscellaneous functions+ , throwErrorMessage+ , getPGResult+ , throwResultError+ , pgRun+ , pgRunRaw+ , pgRunMany+ , pgstGetResult+ ) where++import Blaze.ByteString.Builder (toByteString)+import Blaze.ByteString.Builder.ByteString (fromByteString)+import Blaze.ByteString.Builder.Char.Utf8 (fromLazyText, fromString)+import Control.Applicative+import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+import Data.Bits+import Data.List (intercalate)+import Data.Monoid+import Data.Time+import Data.Typeable+import Data.Word+import Database.HDBI+import Database.HDBI.DriverUtils+import Database.HDBI.Parsers+import Database.HDBI.PostgreSQL.Parser (buildSqlQuery)+import Safe+import System.IO+import System.Locale (defaultTimeLocale)+import qualified Data.Attoparsec.Text.Lazy as P+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.UUID as U+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Database.PostgreSQL.Simple.BuiltinTypes as PS++data PostgreConnection = PostgreConnection+ { postNative :: MVar (Maybe PQ.Connection) -- ^ LibPQ connection if established+ , postStatements :: ChildList PostgreStatement -- ^ List of weak refs to statements to finalize on disconnect+ , postConnString :: TL.Text -- ^ Original connection string+ }+ deriving (Typeable)++data PGStatementState =+ -- | Newly created or reseted statement+ STNew+ -- | Just executed statement+ | STExecuted+ { pgstResult :: ! PQ.Result+ }+ -- | Fetching rows is in progress+ | STFetching+ { pgstResult :: ! PQ.Result -- ^ The result to fetch data from+ , pgstColumns :: ! PQ.Column -- ^ Columns count+ , pgstFormats :: ! [PQ.Format]+ , pgstTypes :: ! [PQ.Oid]+ , pgstTuples :: ! PQ.Row -- ^ Tuples in result+ , pgstCurrent :: ! PQ.Row -- ^ Row number waiting to fetch+ }+ -- | Statement is finished, can still be reseted+ | STFinished+++data PostgreStatement = PostgreStatement+ { stQuery :: Query -- ^ Initial query+ , stConnection :: PostgreConnection -- ^ Connection this statement working with+ , stState :: MVar PGStatementState -- ^ State of statement+ }+ deriving (Typeable)+++instance Connection PostgreConnection where+ type ConnStatement PostgreConnection = PostgreStatement++ disconnect conn = modifyMVar_ (postNative conn) $ \con -> do+ case con of+ Nothing -> return Nothing+ Just c -> do+ closeAllChildren $ postStatements conn+ PQ.finish c+ return Nothing++ begin conn = runRaw conn "BEGIN"+ commit conn = runRaw conn "COMMIT"+ rollback conn = runRaw conn "ROLLBACK"+ inTransaction conn = withPGConnection conn $ \con -> do+ st <- PQ.transactionStatus con+ case st of+ PQ.TransInTrans -> return True+ PQ.TransInError -> do+ hPutStrLn stderr "Transaction is in error status"+ return True+ PQ.TransUnknown -> throwIO $ SqlDriverError "Could not determine the transaction status (TransUnknown)"+ _ -> return False+ connStatus conn = withMVar (postNative conn) $ \con -> case con of+ Nothing -> return ConnDisconnected+ Just c -> do+ st <- PQ.status c+ case st of+ PQ.ConnectionOk -> return ConnOK++ PQ.ConnectionBad -> return ConnBad+ x -> throwIO $ SqlDriverError $ pgMsg $ "unexpected status code (" ++ show x ++ ")"++ prepare conn query = do+ st <- PostgreStatement+ <$> return query+ <*> return conn+ <*> newMVar STNew+ addChild (postStatements conn) st+ return st++ run conn query values = do+ res <- pgRun conn query values+ PQ.unsafeFreeResult res+ return ()++ runRaw conn query = do+ res <- pgRunRaw conn query+ PQ.unsafeFreeResult res+ return ()++ runMany = pgRunMany++ clone conn = connectPostgreSQL $ postConnString conn++ hdbiDriverName = const "postgresql"++ dbTransactionSupport = const True+++instance Statement PostgreStatement where++ execute stmt values = modifyMVar_ (stState stmt)+ $ \st -> withPGSTNew st $ do+ res <- pgRun (stConnection stmt) (stQuery stmt) values+ return $ STExecuted res++ executeMany stmt vals = withMVar (stState stmt)+ $ \st -> withPGSTNew st+ $ pgRunMany (stConnection stmt) (stQuery stmt) vals++ statementStatus stmt = withMVar (stState stmt)+ $ \st -> case st of+ STNew -> return StatementNew+ STExecuted {} -> return StatementExecuted+ STFetching { pgstCurrent = c+ , pgstTuples = t} -> if c >= t+ then return StatementFetched+ else return StatementExecuted+ STFinished -> return StatementFinished++ affectedRows stmt = withMVar (stState stmt)+ $ \st -> do+ let res = pgstGetResult "Statement is not executed or already finished" st+ tpls <- PQ.cmdTuples res+ case tpls of+ Nothing -> withPGConnection (stConnection stmt) throwErrorMessage+ Just "" -> return 0 -- when query was SELECT libPQ return empty string+ Just r -> let rx = TL.unpack $ decodeUTF8 r+ in case readMay rx of+ Just x -> return x+ Nothing -> throwIO $ SqlDriverError $ pgMsg $ "Could not read binding output as integer \"" ++ rx ++ "\""++ finish stmt = modifyMVar_ (stState stmt) doFinishStatement++ reset stmt = modifyMVar_ (stState stmt) $ \st -> do+ _ <- doFinishStatement st+ return STNew++ fetchRow stmt = modifyMVar (stState stmt) _fetchRow+ where+ _fetchRow STExecuted {pgstResult = result} = do+ fields <- PQ.nfields result+ s <- STFetching+ <$> return result+ <*> return fields+ <*> forM [0..fields-1] (PQ.fformat result)+ <*> forM [0..fields-1] (PQ.ftype result)+ <*> PQ.ntuples result+ <*> (return $ PQ.toRow (0 :: Int))+ _fetchRow s++ _fetchRow x@(STFetching result cols formats oids tpls current) =+ if current >= tpls+ then return (x, Nothing)+ else do+ ret <- forM (zip3 [0..cols-1] formats oids) $ \(col, fmt, oid) -> do+ mval <- PQ.getvalue' result current col+ case mval of+ Nothing -> return SqlNull+ Just val -> nativeToSqlValue val fmt oid+ return (x {pgstCurrent = current + 1}, Just ret)++ _fetchRow x = throwIO+ $ SqlDriverError+ $ pgMsg $ "Statement is in wrong state (" ++ pgstName x ++ ") to fetch row"++ getColumnNames stmt = withMVar (stState stmt) $ \st -> do+ let res = pgstGetResult "Statement is in wrong state to get column names" st+ cols <- PQ.nfields res+ forM [0 .. cols-1] $ \col -> do+ mname <- PQ.fname res col+ case mname of+ Nothing -> withPGConnection (stConnection stmt) throwErrorMessage+ Just name -> return $ decodeUTF8 name++ getColumnsCount stmt = withMVar (stState stmt) $ \st -> do+ let res = pgstGetResult "Statement is in wrong state to get columns count" st+ ret <- PQ.nfields res+ return $ toEnum $ fromEnum ret++ originalQuery = stQuery+++-- | Throw `SqlDriverError` that connection is closed+throwConnectionClosed :: IO a+throwConnectionClosed = throwIO $ SqlDriverError $ pgMsg "The connection is closed, can not operate"++-- | If connection is opened then execute an action, else throw an error.+withPGConnection :: PostgreConnection+ -> (PQ.Connection -> IO a) -- ^ action to execute with native LibPQ connection+ -> IO a+withPGConnection conn action = withMVar (postNative conn) $ \c -> case c of+ Nothing -> throwConnectionClosed+ Just con -> action con++-- | Convert SqlValue to native libPQ data representation+sqlValueToNative :: SqlValue -> Maybe (PQ.Oid, B.ByteString, PQ.Format)+sqlValueToNative SqlNull = Nothing+sqlValueToNative x = Just $ tonative x+ where+ bshow :: (Show a) => a -> B.ByteString+ bshow = toByteString . fromString . show++ asText :: (Show a) => PS.BuiltinType -> a -> (PQ.Oid, B.ByteString, PQ.Format)+ asText t v = (PS.builtin2oid t, bshow v, PQ.Text)++ tonative :: SqlValue -> (PQ.Oid, B.ByteString, PQ.Format)+ tonative (SqlDecimal d) = asText PS.Numeric d+ tonative (SqlInteger i) = asText PS.Numeric i+ tonative (SqlDouble d) = asText PS.Float8 d+ tonative (SqlText t) = (PS.builtin2oid PS.Text, encodeUTF8 t, PQ.Text)+ tonative (SqlBlob b) = (PS.builtin2oid PS.ByteA, b, PQ.Binary)+ tonative (SqlBool b) = (PS.builtin2oid PS.Bool, if b then "t" else "f", PQ.Text)+ tonative (SqlBitField b) = (PS.builtin2oid PS.VarBit, formatBits $ unBitField b, PQ.Text)+ tonative (SqlUUID u) = (PS.builtin2oid PS.UUID, toByteString $ fromString $ U.toString u, PQ.Text)+ tonative (SqlUTCTime ut) = (PS.builtin2oid PS.TimestampTZ, formatUTC ut, PQ.Text)+ tonative (SqlLocalDate d) = (PS.builtin2oid PS.Date, formatDay d, PQ.Text)+ tonative (SqlLocalTimeOfDay tod) = (PS.builtin2oid PS.Time, formatT tod, PQ.Text)+ tonative (SqlLocalTime t) = (PS.builtin2oid PS.Timestamp, formatDT t, PQ.Text)+ tonative SqlNull = error "SqlNull is passed to 'tonative' internal function, this is a bug"+++-- | format any formatable data+formatToBS :: (FormatTime a) => String -> a -> B.ByteString+formatToBS s d = toByteString $ fromString $ formatTime defaultTimeLocale s d++-- | Format UTCTime as ByteString+formatUTC :: UTCTime -> B.ByteString+formatUTC x = formatToBS "%Y-%m-%d %H:%M:%S%Q%z" x++-- | Format Day as ByteString+formatDay :: Day -> B.ByteString+formatDay = formatToBS "%Y-%m-%d"++-- | format TimeOfDay to ByteString+formatT :: TimeOfDay -> B.ByteString+formatT = formatToBS "%H:%M:%S%Q"++-- | format LocalTime as ByteString+formatDT :: LocalTime -> B.ByteString+formatDT = formatToBS "%Y-%m-%d %H:%M:%S%Q"++-- | format Word64 as bit field (001010111)+formatBits :: Word64 -> B.ByteString+formatBits 0 = "0"+formatBits w = toByteString $ bits+ where+ bits = mconcat $ map toBS $ truncFalse $ wbits++ wbits = map (testBit w) [bsz-1, bsz-2 .. 0]+ bsz = bitSize w++ truncFalse [] = []+ truncFalse (False:r) = truncFalse r+ truncFalse x@(True:_) = x++ toBS True = fromByteString "1"+ toBS False = fromByteString "0"++-- | convert `PQ.Oid` to `PS.BuiltinType` if not converted then throw an error+o2b :: PQ.Oid -> PS.BuiltinType+o2b fmt = case PS.oid2builtin fmt of+ Nothing -> throw $ SqlDriverError $ pgMsg $ "Could not understand returned type, OID=" ++ show fmt+ Just r -> r++-- | Try parse text with given parser. If parsing failed throw SqlError+parseFromNative :: String -> P.Parser a -> TL.Text -> a+parseFromNative m p t = case P.parse p t of+ P.Done _ r -> r+ P.Fail _ cont msg -> throw $ SqlDriverError+ $ "Could not parse "+ ++ show t+ ++ " as " ++ m+ ++ " parser context is: " ++ (intercalate ", " cont)+ ++ " message: " ++ msg++-- | convert native LibPQ data representation to `SqlValue`. Now support just+-- `PQ.Text` format completely. Maybe binary protocol will be added in future+-- versions.+nativeToSqlValue :: B.ByteString -> PQ.Format -> PQ.Oid -> IO SqlValue+nativeToSqlValue b PQ.Text f = fromNative (o2b f) b+ where+ ftext x = SqlText $ decodeUTF8 x++ fromNative PS.Bool x = case x of+ "t" -> return $ SqlBool True+ "f" -> return $ SqlBool False+ _ -> throwIO $ SqlDriverError $ pgMsg $ "could not parse " ++ (TL.unpack $ decodeUTF8 x) ++ " as Boolean"+ fromNative PS.ByteA x = do+ r <- PQ.unescapeBytea x+ case r of+ Nothing -> throwIO $ SqlDriverError $ pgMsg "Could not unescape binary data, maybe format is wrong"+ Just ret -> return $ SqlBlob ret+ fromNative PS.Char x = return $ ftext x+ fromNative PS.Int8 x = return+ $ SqlInteger+ $ parseFromNative "Integer" (P.signed P.decimal)+ $ decodeUTF8 x+ fromNative PS.Int4 x = return+ $ SqlInteger+ $ parseFromNative "Integer" (P.signed P.decimal)+ $ decodeUTF8 x+ fromNative PS.Int2 x = return+ $ SqlInteger+ $ parseFromNative "Integer" (P.signed P.decimal)+ $ decodeUTF8 x+ fromNative PS.Text x = return $ ftext x+ fromNative PS.Xml x = return $ ftext x+ fromNative PS.Float4 x = return+ $ SqlDouble+ $ parseFromNative "Double" (P.signed P.double)+ $ decodeUTF8 x+ fromNative PS.Float8 x = return+ $ SqlDouble+ $ parseFromNative "Double" (P.signed P.double)+ $ decodeUTF8 x+ fromNative PS.BpChar x = return $ ftext x+ fromNative PS.VarChar x = return $ ftext x+ fromNative PS.Date x = return+ $ SqlLocalDate+ $ parseFromNative "Date" parseIsoDay+ $ decodeUTF8 x+ fromNative PS.Time x = return+ $ SqlLocalTimeOfDay+ $ parseFromNative "TimeOfDay" parseIsoTimeOfDay+ $ decodeUTF8 x+ fromNative PS.Timestamp x = return+ $ SqlLocalTime+ $ parseFromNative "LocalTime" parseIsoLocalTime+ $ decodeUTF8 x+ fromNative PS.TimestampTZ x = return+ $ SqlUTCTime+ $ zonedTimeToUTC+ $ parseFromNative "UTCTime" parseIsoZonedTime+ $ decodeUTF8 x+ fromNative PS.Bit x = return $ SqlBitField $ BitField $ parseBit x+ fromNative PS.VarBit x = return $ SqlBitField $ BitField $ parseBit x+ fromNative PS.Numeric x = return+ $ SqlDecimal+ $ parseFromNative "Decimal" (P.signed P.rational)+ $ decodeUTF8 x+ fromNative PS.Void _ = return $ SqlNull+ fromNative PS.UUID x = SqlUUID <$> case U.fromString uval of+ Nothing -> throwIO $ SqlDriverError $ pgMsg $ "could not read " ++ uval ++ " as UUID"+ Just r -> return r+ where+ uval = TL.unpack $ decodeUTF8 x+ fromNative _ x = return $ ftext x++nativeToSqlValue b PQ.Binary f = binFromNative (o2b f) b+ where+ binFromNative PS.ByteA x = return $ SqlBlob x+ binFromNative x _ = throwIO $ SqlDriverError $ pgMsg $ "Can not parse bytes (Binary result format) as " ++ show x++parseDTBytes :: (ParseTime a) => String -> B.ByteString -> a+parseDTBytes fmt dt = parseDTString fmt val+ where+ val = TL.unpack $ decodeUTF8 dt++parseDTString :: (ParseTime a) => String -> String -> a+parseDTString fmt val = case parseTime defaultTimeLocale fmt val of+ Nothing -> throw $ SqlDriverError $ pgMsg $ "Could not parse " ++ val ++ " as Date/Time in format \"" ++ fmt ++ "\""+ Just r -> r+++-- | parse ByteString as `TimeOfDay`+parseT :: B.ByteString -> TimeOfDay+parseT = parseDTBytes "%H:%M:%S%Q"++-- | parse ByteString as `LocalTime`+parseDT :: B.ByteString -> LocalTime+parseDT = parseDTBytes "%Y-%m-%d %H:%M:%S%Q"++-- | parse ByteString as `Day`+parseD :: B.ByteString -> Day+parseD = parseDTBytes "%Y-%m-%d"++-- | parse ByteString as `UTCTime`+parseUTC :: B.ByteString -> UTCTime+parseUTC u = parseDTString "%Y-%m-%d %H:%M:%S%Q%z" val+ where+ val = (TL.unpack $ decodeUTF8 u) ++ "00" -- strange Postgre behaviour++-- | parse ByteString as 64 bit field (00101110) and convert to Word64+parseBit :: B.ByteString -> Word64+parseBit bt = foldl makeBit 0 $ zip [0..] $ take (bitSize (undefined :: Word64)) $ reverse val+ where+ makeBit l (n, '1') = setBit l n+ makeBit l (_, '0') = l+ makeBit _ _ = throw $ SqlDriverError $ pgMsg $ "Could not parse string \"" ++ val ++ "\" as bit field"+ val = TL.unpack $ decodeUTF8 bt++-- | get last error code and error message from connection and throw proper+-- `SqlError`+throwErrorMessage :: PQ.Connection -> IO a+throwErrorMessage con = do+ errm <- throwNoMessage =<< PQ.errorMessage con+ throwIO $ SqlError "" $ TL.unpack $ decodeUTF8 errm+++-- | Throws appropriate SqlError when no `PQ.Result` is not given, or it is in+-- wrong status+getPGResult :: PQ.Connection -> Maybe PQ.Result -> IO PQ.Result+getPGResult _ (Just x) = do+ st <- PQ.resultStatus x+ case st of+ PQ.FatalError -> throwResultError x+ PQ.EmptyQuery -> throwResultError x+ PQ.BadResponse -> throwResultError x+ _ -> return x+getPGResult con Nothing = throwErrorMessage con++-- | if Nothing throws error about no message+throwNoMessage :: Maybe e -> IO e+throwNoMessage Nothing = throwIO $ SqlDriverError $ pgMsg "Error has occured, but no error message received"+throwNoMessage (Just e) = return e++-- | Get error message from the result and throw it as 'SqlError'+throwResultError :: PQ.Result -> IO a+throwResultError res = do+ errm <- throwNoMessage =<< PQ.resultErrorMessage res+ ef <- throwNoMessage =<< PQ.resultErrorField res PQ.DiagSqlstate+ throwIO $ SqlError (TL.unpack $ decodeUTF8 ef) (TL.unpack $ decodeUTF8 errm)+++-- | Establish new PostgreSQL connection+connectPostgreSQL :: TL.Text -- ^ Connection string according to the documentation+ -> IO PostgreConnection+connectPostgreSQL constr = do+ con <- PQ.connectdb $ encodeUTF8 constr+ st <- PQ.status con+ case st of+ PQ.ConnectionOk -> do+ done <- PQ.setClientEncoding con "UTF8"+ when (not done) $ throwErrorMessage con+ ret <- PostgreConnection+ <$> (newMVar $ Just con)+ <*> newChildList+ <*> (return constr)+ runRaw ret "set timezone='utc'"+ return ret+ _ -> throwErrorMessage con++-- | encode `TL.Text` in UTF8 encoding+encodeUTF8 :: TL.Text -> B.ByteString+encodeUTF8 = toByteString . fromLazyText+++decodeUTF8 :: B.ByteString -> TL.Text+decodeUTF8 x = TL.decodeUtf8 $ BL.fromChunks [x]++pgRun :: PostgreConnection -> Query -> [SqlValue] -> IO PQ.Result+pgRun conn query values = withPGConnection conn $ \con -> do+ r <- PQ.execParams con (buildSqlQuery query) binvals PQ.Text+ getPGResult con r -- Throwing error if failed+ where+ binvals = map sqlValueToNative values++pgRunRaw :: PostgreConnection -> Query -> IO PQ.Result+pgRunRaw conn query = withPGConnection conn $ \con -> do+ r <- PQ.exec con $ buildSqlQuery query+ getPGResult con r++pgRunMany :: PostgreConnection -> Query -> [[SqlValue]] -> IO ()+pgRunMany conn query values = withPGConnection conn $ \con -> do+ forM_ values $ \val -> do+ r <- PQ.execParams con binq (binv val) PQ.Text+ res <- getPGResult con r+ PQ.unsafeFreeResult res+ return ()+ where+ binq = buildSqlQuery query+ binv = map sqlValueToNative++-- | add "hdbi-postgresql: " before an argument+pgMsg :: String -> String+pgMsg = ("hdbi-postgresql: " ++)++-- | return the name of `PGStatementState` constructor+pgstName :: PGStatementState -> String+pgstName STNew = "New"+pgstName (STExecuted {}) = "Executed"+pgstName (STFetching {}) = "Fetching state"+pgstName STFinished = "Finished"++withPGSTNew :: PGStatementState -> IO a -> IO a+withPGSTNew st action = case st of+ STNew -> action+ x -> throwIO $ SqlDriverError $ pgMsg $ "Statement is not in new state (" ++ (pgstName x) ++ ")"++-- | get Result from `PGStatementState` if can. If can not throw an error with specified message+pgstGetResult :: String -> PGStatementState -> PQ.Result+pgstGetResult _ STExecuted { pgstResult = result } = result+pgstGetResult _ STFetching { pgstResult = result } = result+pgstGetResult msg st = throw $ SqlDriverError $ pgMsg $ msg ++ " (" ++ pgstName st ++ ")"++-- | Perform result finishing and return `STFinished`+doFinishStatement :: PGStatementState -> IO PGStatementState+doFinishStatement st = case st of+ STExecuted {pgstResult = r} -> _finish r+ STFetching {pgstResult = r} -> _finish r+ _ -> return STFinished+ where+ _finish res = do+ PQ.unsafeFreeResult res+ return STFinished
+ Database/HDBI/PostgreSQL/Parser.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE+ OverloadedStrings+ #-}++{- |+ Module : Database.HDBI.PostgreSQL.Parser+ Copyright : Copyright (C) 2005-2013 John Goerzen+ License : BSD3++ Maintainer : Aleksey Uymanov <s9gf4ult@gmail.com>+ Stability : experimental+ Portability: portable+-}++module Database.HDBI.PostgreSQL.Parser+ (+ buildSqlQuery+ -- * partial parsers+ , qidentifier+ , quoteLiteral+ , dollarLiteral+ , ccomment+ , linecomment+ , literal+ ) where++import Blaze.ByteString.Builder (toByteString)+import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromString)+import Control.Applicative ((<$>), Alternative(..))+import Control.Exception (throw)+import Data.Attoparsec.Text.Lazy+import Data.Monoid ((<>), mempty)+import Database.HDBI.Types (Query(..), SqlError(..))+import Prelude hiding (take)+import qualified Data.ByteString as B+import qualified Data.Text as T++data ParseResult =+ -- | copy Text to the result+ PQuoteText T.Text+ -- | copy String to the result+ | PQuoteString String+ -- | replace with series of $1 $2 $3 and so on+ | PReplace+ deriving (Show, Eq)++normalText :: Parser [ParseResult]+normalText = (:[]) . PQuoteText <$> takeWhile1 (not . (flip elem) ['\\', '?', '-', '/', '"', '\'', '$'])++qmark :: Parser [ParseResult]+qmark = (:[]) <$> ((char '?') >> (return PReplace))++comment :: Parser [ParseResult]+comment = linecomment <|> ccomment++ccomment :: Parser [ParseResult]+ccomment = (map PQuoteText) <$> (ccomment' <?> "Inline comment")+ where+ ccomment' :: Parser [T.Text]+ ccomment' = do+ _ <- string "/*"+ c <- manyTill+ (ccomment' <|> ((:[]) <$> take 1))+ $ string "*/"+ return $ ["/*"] ++ concat c ++ ["*/"]++linecomment :: Parser [ParseResult]+linecomment = linecomment' <?> "Line comment"+ where+ linecomment' = do+ _ <- string "--"+ c <- (manyTill anyChar (endOfLine <|> endOfInput)) <?> "Body of line comment"+ return [PQuoteString "--", PQuoteString c, PQuoteString "\n"]++qidentifier :: Parser [ParseResult]+qidentifier = qidentifier' <?> "Quoted identifier parser"+ where+ qidentifier' = do+ _ <- (char '"') <?> "First double quote"+ res <- (scan False scanner) <?> "qidentifier body"+ let quotes = T.count "\"" res+ if quotes `mod` 2 == 0+ then fail "the number of quotes must be even"+ else return [PQuoteString "\"", PQuoteText res]++ scanner False '"' = Just True+ scanner False _ = Just False+ scanner True '"' = Just False+ scanner True _ = Nothing+ +literal :: Parser [ParseResult]+literal = quoteLiteral <|> dollarLiteral++data QLChar = BackQ+ | Quote+ | Other ++quoteLiteral :: Parser [ParseResult]+quoteLiteral = literal' <?> "Literal string parser"+ where+ literal' = do+ _ <- char '\'' <?> "First quote"+ res <- scan Other scanner+ let quotes = T.count "'" res+ bquotes = T.count "\\'" res+ if (quotes - bquotes) `mod` 2 == 0+ then fail "the number of quotes must be even"+ else return [PQuoteString "'", PQuoteText res]++ scanner Quote '\'' = Just Other+ scanner Quote _ = Nothing+ scanner BackQ _ = Just Other+ scanner Other '\'' = Just Quote+ scanner Other '\\' = Just BackQ+ scanner Other _ = Just Other++dollarLiteral :: Parser [ParseResult]+dollarLiteral = dollarLiteral' <?> "Dollar quoted literal string parser"+ where+ dollarLiteral' = do+ _ <- char '$'+ tag <- tagParser <?> "Tag name parser"+ _ <- char '$'+ body <- (manyTill anyChar $ (char '$' >> string tag >> char '$')) <?> "Dollar quoted string body"+ let prepost = [PQuoteString "$", PQuoteText tag, PQuoteString "$"]+ return $ prepost ++ [PQuoteString body] ++ prepost++ tagParser = do+ ret <- takeTill (== '$')+ case T.length ret of+ 0 -> return ret+ _ -> if inClass ['0'..'9'] $ T.head ret+ then fail "First character must not be digit"+ else return ret+ ++sqlParser :: Parser [ParseResult]+sqlParser = concat <$> (many' $ choice [ normalText+ , qmark+ , comment+ , qidentifier+ , literal+ , (:[]) . PQuoteString . (:[]) <$> anyChar+ ])+++buildSqlQuery :: Query -> B.ByteString+buildSqlQuery (Query q) = case eitherResult $ parse sqlParser q of+ Left e -> throw $ SqlDriverError $ "postgresql query parser: " ++ e+ Right r -> buildBS r++buildBS :: [ParseResult] -> B.ByteString+buildBS r = toByteString $ fst $ foldl bsr (mempty, 1 :: Integer) r+ where+ bsr (res, n) (PQuoteText t) = (res <> fromText t, n)+ bsr (res, n) (PQuoteString s) = (res <> fromString s, n)+ bsr (res, n) PReplace = (res <> fromString ('$':show n), n+1)
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2005-2011 John Goerzen+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice, this+ list of conditions and the following disclaimer in the documentation and/or+ other materials provided with the distribution.++* Neither the name of John Goerzen nor the names of its+ contributors may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hdbi-postgresql.cabal view
@@ -0,0 +1,105 @@+Name: hdbi-postgresql+Version: 1.0.0+License: BSD3+Maintainer: Aleksey Uymanov <s9gf4ult@gmail.com>+Author: John Goerzen+Copyright: Copyright (c) 2005-2013 John Goerzen+license-file: LICENSE+homepage: https://github.com/s9gf4ult/hdbi-postgresql+Category: Database+synopsis: PostgreSQL driver for hdbi+Description: This package provides a PostgreSQL driver for hdbi+Stability: experimental++Build-Type: Simple+Cabal-Version: >=1.8++source-repository head+ type: git+ location: https://github.com/s9gf4ult/hdbi-postgresql.git++Library+ Exposed-Modules: Database.HDBI.PostgreSQL+ , Database.HDBI.PostgreSQL.Implementation+ , Database.HDBI.PostgreSQL.Parser+ Build-Depends: base >= 3 && < 5+ , attoparsec+ , blaze-builder+ , bytestring+ , hdbi >= 1.0.0+ , mtl+ , old-locale+ , postgresql-libpq+ , postgresql-simple+ , safe+ , text+ , time+ , uuid++ if impl(ghc >= 6.9)+ Build-Depends: base >= 4+ Ghc-Options: -Wall+ ghc-prof-options: -auto-all+++test-suite runtests+ type: exitcode-stdio-1.0+ main-is: testsrc/runtests.hs+ other-modules: Database.HDBI.PostgreSQL.Implementation+ , Database.HDBI.PostgreSQL.Parser++ ghc-options: -Wall -fno-warn-orphans -main-is Runtests+ build-depends: base >= 3 && < 5+ , Decimal+ , HUnit+ , QuickCheck+ , attoparsec+ , blaze-builder+ , bytestring+ , containers+ , hdbi >= 1.0.0+ , ieee754+ , mtl+ , old-locale+ , postgresql-libpq+ , postgresql-simple+ , quickcheck-assertions+ , quickcheck-instances+ , safe+ , test-framework <= 0.7+ , test-framework-hunit+ , test-framework-quickcheck2+ , text+ , time+ , uuid+++test-suite puretests+ type: exitcode-stdio-1.0+ main-is: testsrc/puretests.hs+ other-modules: Database.HDBI.PostgreSQL.Implementation+ , Database.HDBI.PostgreSQL.Parser++ ghc-options: -Wall -fno-warn-orphans -main-is Puretests+ build-depends: base >= 3 && < 5+ , Decimal+ , HUnit+ , QuickCheck+ , attoparsec+ , blaze-builder+ , bytestring+ , derive+ , hdbi >= 1.0.0+ , mtl+ , old-locale+ , postgresql-libpq+ , postgresql-simple+ , quickcheck-assertions+ , quickcheck-instances+ , safe+ , test-framework <= 0.7+ , test-framework-hunit+ , test-framework-quickcheck2+ , text+ , time+ , uuid
+ testsrc/puretests.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE+ OverloadedStrings+, ScopedTypeVariables+, FlexibleInstances+, FlexibleContexts+, TemplateHaskell+ #-}++module Puretests where++import Blaze.ByteString.Builder (toByteString)+import Blaze.ByteString.Builder.Char.Utf8 (fromString)+import Control.Applicative+import Data.Attoparsec.Text.Lazy+import Data.Decimal+import Data.Derive.Arbitrary+import Data.DeriveTH+import Data.List (intercalate, isInfixOf, mapAccumL, intersperse)+import Data.Monoid (mconcat)+import Data.UUID (UUID, fromWords)+import Database.HDBI+import Database.HDBI.PostgreSQL.Implementation+import Database.HDBI.PostgreSQL.Parser+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit (assertFailure, Assertion, (@?=))+import Test.QuickCheck+import Test.QuickCheck.Assertions+import Test.QuickCheck.Instances ()+import qualified Data.ByteString as B+import qualified Data.Text.Lazy as TL+import qualified Test.QuickCheck.Monadic as QM+import qualified Test.QuickCheck.Property as QP++instance Arbitrary (DecimalRaw Integer) where+ arbitrary = Decimal <$> arbitrary <*> arbitrary++instance Arbitrary UUID where+ arbitrary = fromWords+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary BitField where+ arbitrary = BitField <$> arbitrary++$( derive makeArbitrary ''SqlValue )++isID :: (Eq a, Show a) => (a -> b) -> (b -> a) -> a -> QP.Result+isID to from a = a ==? (from $ to a)++sqlToNativeAndBack :: SqlValue -> Property+sqlToNativeAndBack val = QM.monadicIO $ do+ res <- QM.run $ do+ let nat = sqlValueToNative val+ case nat of+ Nothing -> return SqlNull+ Just (o, b, f) -> nativeToSqlValue b f o+ QM.stop $ res ?== val++convertionTests :: Test+convertionTests = testGroup "Can convert to and back"+ [testProperty "SqlValue" sqlToNativeAndBack]++parseToLeft :: (Show a) => Parser a -> TL.Text -> Assertion+parseToLeft p t = case eitherResult $ parse p t of+ Left _ -> return ()+ Right r -> assertFailure $ "string " ++ (show t) ++ " parsed to " ++ show r++formatParseFail :: String -- ^ Initial string+ -> [String] -- ^ context+ -> String -- ^ error message+ -> String+formatParseFail s cts err = "string " ++ (show s)+ ++ "\ncontext: " ++ (intercalate ", " cts)+ ++ "\nerror: " ++ err++parseToRight :: Parser a -> TL.Text -> Assertion+parseToRight p t = case parse p t of+ Fail _ cts err -> assertFailure $ formatParseFail (TL.unpack t) cts err+ Done _ _ -> return ()++testParseQidentifier :: Assertion+testParseQidentifier = do+ parseToRight qidentifier "\"hello\""+ parseToRight qidentifier "\" efs a \""+ parseToRight qidentifier "\"\""+ parseToRight qidentifier "\"jas\"\"jas\"\"\""+ parseToRight qidentifier "\"\"\"\""+ parseToLeft qidentifier " asdf \""+ parseToLeft qidentifier "\" ijasdf "+ parseToLeft qidentifier "\"ja\"\""++testQuoteLiteral :: Assertion+testQuoteLiteral = do+ parseToRight quoteLiteral "''"+ parseToRight quoteLiteral "'aije'"+ parseToRight quoteLiteral "' asdf '''"+ parseToRight quoteLiteral "' asdfij \\''"+ parseToRight quoteLiteral "'\\'''''\\'\\''''"+ parseToRight quoteLiteral "''' asidfj '''"+ parseToRight quoteLiteral "'afe\\\\s''fa'"+ parseToLeft quoteLiteral "adf'" -- started not from quote+ parseToLeft quoteLiteral "'aijfa\\'" -- no end quote+ parseToLeft quoteLiteral "'ssd''"++testDollarLiteral :: Assertion+testDollarLiteral = do+ parseToRight dollarLiteral "$$$$"+ parseToRight dollarLiteral "$tag$$tag$"+ parseToRight dollarLiteral "$asdf$\"jiasd$$f 'j ija\"$asdf$"+ parseToRight dollarLiteral "$tag$$$$$$ajs$$$tag$"+ parseToLeft dollarLiteral "$a$jaisdj$$" -- tag mismatch+ parseToLeft dollarLiteral "$a$ aisj\\$a $"+ parseToLeft dollarLiteral "$4sf$hello$4sf$" -- tag started with digit++testInlineComment :: Assertion+testInlineComment = do+ parseToRight ccomment "/**/"+ parseToRight ccomment "/* asdf */"+ parseToRight ccomment "/*ja e /* jasd */*/" -- inlined comment+ parseToRight ccomment "/* ij/ * iajef */"+ parseToRight ccomment "/*/*/**/*/*/"+ parseToLeft ccomment " jae */" -- no start /*+ parseToLeft ccomment "/* asdf " -- no end */++testLineComment :: Assertion+testLineComment = do+ parseToRight linecomment "--"+ parseToRight linecomment "-- jijasdf "+ parseToRight linecomment "-- jasdf sj\n"+ parseToLeft linecomment "a-- jasd" -- not started from --++buildsTo :: Query -> B.ByteString -> Assertion+buildsTo q res = (buildSqlQuery q) @?= res++testQueryBuilder :: Assertion+testQueryBuilder = do+ buildsTo "\"hello?\" ?"+ "\"hello?\" $1"+ buildsTo "'?', ?" "'?', $1"+ buildsTo "select \"a?\\?\"\"?\" from \"?\"\" \" where fld = ? and ff = 'con?t''' ?"+ "select \"a?\\?\"\"?\" from \"?\"\" \" where fld = $1 and ff = 'con?t''' $2"++parserTests :: Test+parserTests = testGroup "Parser tests"+ [ testCase "qidentifier parser" testParseQidentifier+ , testCase "quote literal string parser" testQuoteLiteral+ , testCase "dollar literal string parser" testDollarLiteral+ , testCase "inline comment parser" testInlineComment+ , testCase "line comment parser" testLineComment+ , testCase "complex query builder test" testQueryBuilder+ ]++alphabet :: [String]+alphabet = (map (:[]) "qwertyuiop[]asdfghjklzxcvbnm,. ?") ++ ["- "]++parseRightProperty :: Parser a -> String -> QP.Result+parseRightProperty p s = case parse p $ TL.pack s of+ Done _ _ -> QP.succeeded+ Fail _ cont err -> QP.failed {QP.reason = formatParseFail s cont err}++quoteLiteralGen :: Gen String+quoteLiteralGen = do+ r <- listOf $ elements $ ["''", "\\'"] ++ alphabet+ return $ "'" ++ concat r ++ "'"++dollarLiteralGen :: Gen String+dollarLiteralGen = do+ tag <- concat <$> (listOf $ elements $ alphabet ++ ["''", "\\'", "\"", "\\\"", "\"\""])+ let quotes = "$" ++ tag ++ "$"+ body <- suchThat (concat <$> (listOf+ $ elements+ $ alphabet ++ ["$", "''", "\\'", "\"", "\\\"", "\"\""]))+ $ not . (isInfixOf quotes) . (++ "$")+ return $ quotes ++ body ++ quotes+++qidentifierGen :: Gen String+qidentifierGen = do+ body <- concat <$> (listOf $ elements $ alphabet ++ ["'", "\\'", "\"\"", "$"])+ return $ "\"" ++ body ++ "\""++inlineCommentGen :: Gen String+inlineCommentGen = do+ body <- oneof+ [ inlineCommentGen+ , concat <$> (listOf $ elements $ alphabet)+ ]+ return $ "/*" ++ body ++ "*/"++lineCommentGen :: Gen String+lineCommentGen = do+ body <- concat <$> (listOf $ elements alphabet)+ end <- elements ["", "\n"]+ return $ "--" ++ body ++ end++parameterPlaceholderGen :: Gen String+parameterPlaceholderGen = do+ (v :: Int) <- getPositive <$> arbitrary+ return $ "$" ++ (show v)++data GenS = GenQ String -- ^ Generate string as is+ | GenR -- ^ Generate $1, $2 sequence in this place++generateQueryPiece :: Gen (String, GenS) -- initial string and the result+generateQueryPiece = oneof+ [ quote quoteLiteralGen+ , quote dollarLiteralGen+ , quote qidentifierGen+ , quote inlineCommentGen+ , quote parameterPlaceholderGen+ , quote ((++ "\n") <$> lineCommentGen)+ -- , quote $ return "\\?"+ , return ("?", GenR)+ ]+ where+ quote p = do+ r <- p+ return (r, GenQ r)++pieceToResult :: [(String, GenS)] -> [(String, String)]+pieceToResult p = snd $ mapAccumL accl 1 p+ where+ accl acc (x, GenQ y) = (acc, (x, y))+ accl acc (x, GenR) = (acc+1, (x, "$" ++ show acc))++fullQueryGen :: Gen (Query, B.ByteString)+fullQueryGen = do+ (q, res) <- unzip . (intersperse (" ", " ")) . pieceToResult <$> (listOf generateQueryPiece)+ return $ (Query $ TL.pack $ concat q, toByteString $ mconcat $ map fromString res)++checkFullQueryGen :: (Query, B.ByteString) -> QP.Result+checkFullQueryGen (q, res) = (buildSqlQuery q) ?== res+ ++parserProperties :: Test+parserProperties = testGroup "Parser properties"+ [ testProperty "literal" $ forAll quoteLiteralGen $ parseRightProperty literal+ , testProperty "dollar literal" $ forAll dollarLiteralGen $ parseRightProperty dollarLiteral+ , testProperty "qidentifier" $ forAll qidentifierGen $ parseRightProperty qidentifier+ , testProperty "inline comment" $ forAll inlineCommentGen $ parseRightProperty ccomment+ , testProperty "line comment" $ forAll lineCommentGen $ parseRightProperty linecomment+ , testProperty "whole parser" $ forAll fullQueryGen checkFullQueryGen+ ]+++++main :: IO ()+main = defaultMain [ convertionTests+ , parserTests+ , parserProperties+ ]
+ testsrc/runtests.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE+ OverloadedStrings+, ScopedTypeVariables+, FlexibleInstances+, FlexibleContexts+ #-}++module Runtests where++import Control.Applicative+import Data.AEq+import Data.Decimal+import Data.Fixed+import Data.Int+import Data.List+import Data.Monoid+import Data.Time+import Data.UUID+import Data.Word+import Database.HDBI+import Database.HDBI.PostgreSQL+import System.Environment+import System.Exit+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit ((@?=), Assertion)+import Test.QuickCheck+import Test.QuickCheck.Assertions+import Test.QuickCheck.Instances ()+import qualified Data.ByteString as B+import qualified Data.Set as S+import qualified Data.Text.Lazy as TL+import qualified Test.QuickCheck.Monadic as QM+++instance Arbitrary (DecimalRaw Integer) where+ arbitrary = Decimal <$> arbitrary <*> arbitrary++instance Arbitrary UUID where+ arbitrary = fromWords+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++runInsertSelect :: (FromSql a, ToSql a) => PostgreConnection -> Query -> a -> IO a+runInsertSelect conn tname val = withTransaction conn $ do+ runRaw conn "drop table if exists table1"+ runRaw conn $ "create table table1 (val " <> tname <> ")"+ run conn "insert into table1 (val) values (?)" [toSql val]+ s <- prepare conn "select val from table1"+ executeRaw s+ (Just [res])<- fetchRow s+ finish s+ return $ fromSql res++runInsertMany :: PostgreConnection -> [String] -> [[SqlValue]] -> IO [[SqlValue]]+runInsertMany conn types values = withTransaction conn $ do+ runRaw conn "drop table if exists table1"+ runRaw conn $ pk $ "create table table1 (" ++ valnames ++ ")"+ s <- prepare conn $ pk $ "insert into table1(" ++ colnames ++ ") values (" ++ (intersperse ',' $ replicate (length names) '?') ++")"+ executeMany s values+ finish s+ s2 <- prepare conn $ pk $ "select " ++ colnames ++ " from table1"+ executeRaw s2+ fetchAllRows s2+ + where+ pk = Query . TL.pack+ names = map (("val"++) . show) [1..length types]+ colnames = intercalate "," names+ valnames = intercalate "," $ map (\(a, b) -> a ++ " " ++ b) $ zip names types++setsEqual :: PostgreConnection -> [String] -> [[SqlValue]] -> Property+setsEqual conn types values = QM.monadicIO $ do+ ret <- QM.run $ runInsertMany conn types values+ QM.stop $ (S.fromList values) ==? (S.fromList ret)+ +preciseEqual :: (Eq a, Show a, FromSql a, ToSql a) => PostgreConnection -> Query -> a -> Property+preciseEqual conn tname val = QM.monadicIO $ do+ res <- QM.run $ runInsertSelect conn tname val+ QM.stop $ res ?== val+++approxEqual :: (Show a, AEq a, FromSql a, ToSql a) => PostgreConnection -> Query -> a -> Property+approxEqual conn tname val = QM.monadicIO $ do+ res <- QM.run $ runInsertSelect conn tname val+ QM.stop $ res ?~== val++genTOD :: Gen TimeOfDay+genTOD = roundTod <$> arbitrary++genLT :: Gen LocalTime+genLT = rnd <$> arbitrary+ where+ rnd x@(LocalTime {localTimeOfDay = t}) = x {localTimeOfDay = roundTod t}++-- | Generate Text without 'NUL' symbols+genText :: Gen TL.Text+genText = TL.filter fltr <$> arbitrary+ where+ fltr '\NUL' = False -- NULL truncates C string when pass to libpq binding.+ fltr _ = True++genUTC :: Gen UTCTime+genUTC = rnd <$> arbitrary+ where+ rnd x@(UTCTime {utctDayTime = d}) = x {utctDayTime = anyToMicro d}+++-- | Strip TimeOfDay to microsecond precision+roundTod :: TimeOfDay -> TimeOfDay+roundTod x@(TimeOfDay {todSec = s}) = x {todSec = anyToMicro s}++anyToMicro :: (Fractional b, Real a) => a -> b+anyToMicro a = fromRational $ toRational ((fromRational $ toRational a) :: Micro)++testG1 :: PostgreConnection -> Test+testG1 c = testGroup "Can insert and select"+ [ testProperty "Decimal" $ \(d :: Decimal) -> preciseEqual c "decimal(400,255)" d+ , testProperty "Int32" $ \(i :: Int32) -> preciseEqual c "integer" i+ , testProperty "Int64" $ \(i :: Int64) -> preciseEqual c "bigint" i+ , testProperty "Integer" $ \(i :: Integer) -> preciseEqual c "decimal(100,0)" i+ , testProperty "Double" $ \(d :: Double) -> approxEqual c "double precision" d+ , testProperty "Text" $ forAll genText $ \(t :: TL.Text) -> preciseEqual c "text" t+ , testProperty "ByteString" $ \(b :: B.ByteString) -> preciseEqual c "bytea" b+ , testProperty "Bool" $ \(b :: Bool) -> preciseEqual c "boolean" b+ , testProperty "UUID" $ \(u :: UUID) -> preciseEqual c "uuid" u+ , testProperty "BitField" $ \(w :: Word64) -> preciseEqual c "varbit" (BitField w)+ , testProperty "UTCTime" $ forAll genUTC $ \(u :: UTCTime) -> preciseEqual c "timestamp with time zone" u+ , testProperty "Day" $ \(d :: Day) -> preciseEqual c "date" d+ , testProperty "TimeOfDay" $ forAll genTOD $ \(tod :: TimeOfDay) -> preciseEqual c "time" tod+ , testProperty "LocalTime" $ forAll genLT $ \(lt :: LocalTime) -> preciseEqual c "timestamp without time zone" lt+ , testProperty "Null" $ preciseEqual c "integer" SqlNull+ , testProperty "Maybe Integer" $ \(val :: Maybe Integer) -> preciseEqual c "decimal(100,0)" val+ , testProperty "Maybe ByteString" $ \(val :: Maybe B.ByteString) -> preciseEqual c "bytea" val+ , testProperty "Insert many numbers" $ \(x :: [(Integer, Decimal)]) -> setsEqual c+ ["decimal(100,0)", "decimal(400,255)"]+ $ map (\(i, d) -> [toSql i, toSql d]) x+ , testProperty "Insert many text" $ \(x :: [(Maybe Integer, UUID, Maybe B.ByteString)]) -> setsEqual c+ ["decimal(100,0)", "text", "bytea"]+ $ map (\(i, u, b) -> [toSql i, toSql u, toSql b]) x+ ]++testAffectedRows :: PostgreConnection -> [Int32] -> Property+testAffectedRows c is = QM.monadicIO $ do+ res <- QM.run $ withTransaction c $ do+ runRaw c "drop table if exists table1"+ runRaw c "create table table1 (val bigint)"+ runMany c "insert into table1(val) values (?)" $ map ((:[]) . toSql) is++ s2 <- prepare c "update table1 set val=10"+ executeRaw s2+ res <- affectedRows s2+ finish s2+ + return res+ QM.stop $ res ?== (genericLength is)+ +testG2 :: PostgreConnection -> Test+testG2 c = testGroup "Auxiliary functions"+ [ testProperty "affectedRows" $ testAffectedRows c ]+++stmtStatus :: PostgreConnection -> Assertion+stmtStatus c = do+ runRaw c "drop table table1"+ runRaw c "create table table1 (val bigint)" -- Just for postgre 9+ s <- prepare c "select * from table1"+ statementStatus s >>= (@?= StatementNew)+ executeRaw s+ statementStatus s >>= (@?= StatementExecuted)+ _ <- fetchRow s+ statementStatus s >>= (@?= StatementFetched)+ finish s+ statementStatus s >>= (@?= StatementFinished)+ reset s+ statementStatus s >>= (@?= StatementNew)++inTransactionStatus :: PostgreConnection -> Assertion+inTransactionStatus c = do+ inTransaction c >>= (@?= False)+ withTransaction c $ do+ inTransaction c >>= (@?= True)++connStatusGood :: PostgreConnection -> Assertion+connStatusGood c = connStatus c >>= (@?= ConnOK)++connClone :: PostgreConnection -> Assertion+connClone c = do+ newc <- clone c+ connStatus newc >>= (@?= ConnOK)+ withTransaction newc $ inTransaction c >>= (@?= False)+ withTransaction c $ inTransaction newc >>= (@?= False)+ disconnect newc+ connStatus newc >>= (@?= ConnDisconnected)++checkColumnNames :: PostgreConnection -> Assertion+checkColumnNames c = do+ withTransaction c $ do+ runRaw c "drop table if exists table1"+ runRaw c "create table table1 (val1 bigint, val2 bigint, val3 bigint)"+ s <- prepare c "select val1, val2, val3 from table1"+ executeRaw s+ getColumnNames s >>= (@?= ["val1", "val2", "val3"])+ getColumnsCount s >>= (@?= 3)+ finish s+ +testG3 :: PostgreConnection -> Test+testG3 c = testGroup "Fixed tests"+ [ testCase "Statement status" $ stmtStatus c+ , testCase "inTransaction return right value" $ inTransactionStatus c+ , testCase "Connection status is good" $ connStatusGood c+ , testCase "Connection clone works" $ connClone c+ , testCase "Check driver name" $ hdbiDriverName c @?= "postgresql"+ , testCase "Check transaction support" $ dbTransactionSupport c @?= True+ , testCase "Check right column names" $ checkColumnNames c+ ]++main :: IO ()+main = do+ a <- getArgs+ case a of+ (conn:args) -> do+ c <- connectPostgreSQL $ TL.pack conn+ (flip defaultMainWithArgs) args [ testG1 c+ , testG2 c+ , testG3 c+ ]+ disconnect c++ _ -> do+ mapM_ putStrLn [ "Need at least one argument as connection string"+ , "the rest will be passed as arguments to test-framework"]+ exitWith $ ExitFailure 1