hasql-postgres 0.7.1 → 0.7.2
raw patch · 10 files changed
+459/−417 lines, 10 filesdep +mmorphdep +transformersdep ~list-tPVP ok
version bump matches the API change (PVP)
Dependencies added: mmorph, transformers
Dependency ranges changed: list-t
API changes (from Hackage documentation)
Files
- hasql-postgres.cabal +13/−11
- library/Hasql/Postgres.hs +64/−86
- library/Hasql/Postgres/Prelude.hs +9/−2
- library/Hasql/Postgres/ResultHandler.hs +0/−75
- library/Hasql/Postgres/ResultParser.hs +0/−185
- library/Hasql/Postgres/Session/Execution.hs +122/−0
- library/Hasql/Postgres/Session/ResultProcessing.hs +128/−0
- library/Hasql/Postgres/Session/Transaction.hs +116/−0
- library/Hasql/Postgres/StatementPreparer.hs +0/−58
- tests/Main.hs +7/−0
hasql-postgres.cabal view
@@ -1,7 +1,7 @@ name: hasql-postgres version:- 0.7.1+ 0.7.2 synopsis: A "PostgreSQL" backend for the "hasql" library description:@@ -56,17 +56,17 @@ default-language: Haskell2010 other-modules:+ Hasql.Postgres.Connector Hasql.Postgres.Prelude Hasql.Postgres.ErrorCode Hasql.Postgres.PTI Hasql.Postgres.Mapping Hasql.Postgres.Statement- Hasql.Postgres.StatementPreparer Hasql.Postgres.TemplateConverter Hasql.Postgres.TemplateConverter.Parser- Hasql.Postgres.ResultHandler- Hasql.Postgres.Connector- Hasql.Postgres.ResultParser+ Hasql.Postgres.Session.ResultProcessing+ Hasql.Postgres.Session.Transaction+ Hasql.Postgres.Session.Execution exposed-modules: Hasql.Postgres build-depends:@@ -89,12 +89,13 @@ hashable >= 1.1 && < 1.3, -- control: either == 4.*,- list-t >= 0.2.3 && < 0.3,+ list-t < 0.4,+ mmorph == 1.0.*,+ transformers >= 0.2 && < 0.5, -- errors: loch-th == 0.2.*, placeholders == 0.1.*, -- general:- mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8 @@ -141,12 +142,13 @@ hashable >= 1.1 && < 1.3, -- control: either == 4.*,- list-t >= 0.2.3 && < 0.3,+ list-t < 0.4,+ mmorph == 1.0.*,+ transformers >= 0.2 && < 0.5, -- errors: loch-th == 0.2.*, placeholders == 0.1.*, -- general:- mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8 @@ -186,7 +188,7 @@ bytestring >= 0.10 && < 0.11, hashable >= 1.1 && < 1.3, -- general:- list-t == 0.2.*,+ list-t < 0.4, mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8@@ -228,7 +230,7 @@ -- general: monad-control == 0.3.*, deepseq == 1.3.*,- list-t == 0.2.*,+ list-t < 0.4, mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8
library/Hasql/Postgres.hs view
@@ -21,13 +21,11 @@ import qualified Database.PostgreSQL.LibPQ as PQ import qualified Hasql.Backend as Backend import qualified Hasql.Postgres.Connector as Connector-import qualified Hasql.Postgres.ResultParser as ResultParser-import qualified Hasql.Postgres.ResultHandler as ResultHandler import qualified Hasql.Postgres.Statement as Statement-import qualified Hasql.Postgres.StatementPreparer as StatementPreparer-import qualified Hasql.Postgres.TemplateConverter as TemplateConverter import qualified Hasql.Postgres.PTI as PTI import qualified Hasql.Postgres.Mapping as Mapping+import qualified Hasql.Postgres.Session.Transaction as Transaction+import qualified Hasql.Postgres.Session.Execution as Execution import qualified Language.Haskell.TH as TH import qualified Data.Attoparsec.ByteString.Char8 as Atto import qualified Data.Text.Encoding as Text@@ -52,16 +50,17 @@ Result Mapping.Environment (Maybe ByteString) data Connection Postgres = Connection {- connection :: !PQ.Connection, - preparer :: !StatementPreparer.StatementPreparer,- transactionState :: !(IORef (Maybe Word)),- environment :: Mapping.Environment+ connection :: !PQ.Connection,+ executionEnv :: !Execution.Env,+ transactionEnv :: !Transaction.Env,+ mappingEnv :: !Mapping.Environment } connect p = do r <- Connector.open settings c <- either (\e -> throwIO $ Backend.CantConnect $ fromString $ show e) return r- Connection <$> pure c <*> StatementPreparer.new c <*> newIORef Nothing <*> getIntegerDatetimes c+ ee <- Execution.newEnv c+ Connection <$> pure c <*> pure ee <*> Transaction.newEnv ee <*> getIntegerDatetimes c where settings = Connector.Settings (host p) (port p) (user p) (password p) (database p)@@ -74,94 +73,73 @@ _ -> False disconnect c = PQ.finish (connection c)- execute s c = - ResultHandler.unit =<< execute (liftStatement c s) c- executeAndGetMatrix s c =- execute (liftStatement c s) c >>=- (fmap . fmap . fmap) (Result (environment c)) . ResultHandler.rowsVector- executeAndStream s c =- do- name <- declareCursor- return $ - let loop = do- chunk <- lift $ fetchFromCursor name- null <- lift $ ListT.null chunk- guard $ not null- (fmap . fmap) packResult chunk <> loop- in loop- where- packResult = - Result (environment c)- nextName = - do- counterM <- readIORef (transactionState c)- counter <- maybe (throwIO Backend.NotInTransaction) return counterM- writeIORef (transactionState c) (Just (succ counter))- return $ fromString $ 'v' : show counter- declareCursor =- do- name <- nextName- ResultHandler.unit =<< execute (Statement.declareCursor name (liftStatement c s)) c- return name- fetchFromCursor name =- ResultHandler.rowsStream =<< execute (Statement.fetchFromCursor name) c- closeCursor name =- ResultHandler.unit =<< execute (Statement.closeCursor name) c- executeAndCountEffects s c =- do- b <- ResultHandler.rowsAffected =<< execute (liftStatement c s) c- case Atto.parseOnly (Atto.decimal <* Atto.endOfInput) b of- Left m -> - throwIO $ Backend.UnexpectedResult (fromString m)- Right r ->- return r- beginTransaction (isolation, write) c = - do- writeIORef (transactionState c) (Just 0)- ResultHandler.unit =<< execute (Statement.beginTransaction (statementIsolation, write)) c+ execute s = + do s' <- liftStatement s+ liftExecution $ Execution.unitResult =<< Execution.statement s'+ executeAndGetMatrix s =+ do s' <- liftStatement s+ c <- id+ (fmap . fmap . fmap . fmap) (Result (mappingEnv c)) $ liftExecution $ + Execution.vectorResult =<< Execution.statement s'+ executeAndStream s =+ do s' <- liftStatement s+ c <- id+ return $ return $ liftTransactionStream (Transaction.streamWithCursor s') c+ executeAndCountEffects s =+ do s' <- liftStatement s+ liftExecution $ Execution.countResult =<< Execution.statement s'+ beginTransaction (isolation, write) = + liftTransaction $ Transaction.beginTransaction (mapIsolation isolation, write) where- statementIsolation =- case isolation of+ mapIsolation =+ \case Backend.Serializable -> Statement.Serializable Backend.RepeatableReads -> Statement.RepeatableRead Backend.ReadCommitted -> Statement.ReadCommitted Backend.ReadUncommitted -> Statement.ReadCommitted- finishTransaction commit c =- do- ResultHandler.unit =<< execute (bool Statement.abortTransaction Statement.commitTransaction commit) c- writeIORef (transactionState c) Nothing+ finishTransaction commit =+ liftTransaction $ Transaction.finishTransaction commit -liftStatement :: Backend.Connection Postgres -> Backend.Statement Postgres -> Statement.Statement-liftStatement c (template, arguments, preparable) =++-- |+-- Just a convenience alias to a function on connection.+-- Useful since most of the 'Backend' API is made up of such functions.+type M a =+ Backend.Connection Postgres -> a++liftExecution :: Execution.M a -> M (IO a)+liftExecution m =+ \c -> Execution.run (executionEnv c) m >>= either (throwIO . mapExecutionError) return++liftTransaction :: Transaction.M a -> M (IO a)+liftTransaction m =+ \c -> Transaction.run (transactionEnv c) m >>= either (throwIO . mapError) return+ where+ mapError =+ \case+ Transaction.NotInTransaction -> Backend.NotInTransaction+ Transaction.ExecutionError e -> mapExecutionError e++liftStatement :: Backend.Statement Postgres -> M Statement.Statement+liftStatement (template, arguments, preparable) c = (,,) template (map liftArgument arguments) preparable where liftArgument (StatementArgument o f) = - (,) o ((,) <$> f (environment c) <*> pure PQ.Binary)--execute :: Statement.Statement -> Backend.Connection Postgres -> IO ResultParser.Result-execute s c =- ResultParser.parse (connection c) =<< do- let (template, params, preparable) = s- convertedTemplate <- convertTemplate template- case preparable of- True -> do- let (tl, vl) = unzip params- key <- StatementPreparer.prepare convertedTemplate tl (preparer c)- PQ.execPrepared (connection c) key vl PQ.Binary- False -> do- let params' = map (\(t, v) -> (\(vb, vf) -> (t, vb, vf)) <$> v) params- PQ.execParams (connection c) convertedTemplate params' PQ.Binary+ (,) o ((,) <$> f (mappingEnv c) <*> pure PQ.Binary) -convertTemplate :: ByteString -> IO ByteString-convertTemplate t =- case TemplateConverter.convert t of- Left m -> - throwIO $ Backend.UnparsableTemplate $ - "Template: " <> Text.decodeLatin1 t <> ". " <>- "Error: " <> m <> "."- Right r ->- return r+liftTransactionStream :: Transaction.Stream -> M (Backend.Stream Postgres)+liftTransactionStream s c =+ (fmap . fmap) (Result (mappingEnv c)) $ hoist (flip liftTransaction c) s +mapExecutionError :: Execution.Error -> Backend.Error+mapExecutionError =+ \case+ Execution.UnexpectedResult m -> Backend.UnexpectedResult m+ Execution.ErroneousResult m -> Backend.ErroneousResult m+ Execution.UnparsableTemplate t m -> Backend.UnparsableTemplate $+ "Message: " <> m <> "; " <>+ "Template: " <> fromString (show t)+ Execution.TransactionConflict -> Backend.TransactionConflict -- * Mappings
library/Hasql/Postgres/Prelude.hs view
@@ -14,9 +14,12 @@ ------------------------- import BasePrelude as Exports hiding (assert, left, right) --- mtl-prelude+-- transformers --------------------------import MTLPrelude as Exports hiding (shift)+import Control.Monad.IO.Class as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch) -- either -------------------------@@ -25,6 +28,10 @@ -- list-t ------------------------- import ListT as Exports (ListT)++-- mmorph+-------------------------+import Control.Monad.Morph as Exports -- hashable -------------------------
− library/Hasql/Postgres/ResultHandler.hs
@@ -1,75 +0,0 @@--- |--- Backend-aware parsed results' handlers.-module Hasql.Postgres.ResultHandler where--import Hasql.Postgres.Prelude-import qualified Hasql.Backend as Backend-import qualified Hasql.Postgres.ResultParser as Result-import qualified Hasql.Postgres.ErrorCode as ErrorCode---type ResultHandler a =- Result.Result -> IO a--{-# INLINE unit #-}-unit :: ResultHandler ()-unit =- resultHandler $ \case- Result.CommandOK _ -> Right $ return ()- _ -> Left "Not a unit"--{-# INLINE rowsStream #-}-rowsStream :: ResultHandler Result.RowsStream-rowsStream =- resultHandler $ \case- Result.Rows s _ _ -> Right s- _ -> Left "Not a rows result"--{-# INLINE rowsVector #-}-rowsVector :: ResultHandler Result.RowsVector-rowsVector =- resultHandler $ \case- Result.Rows _ v _ -> Right v- _ -> Left "Not a rows result"--{-# INLINE rowsList #-}-rowsList :: ResultHandler Result.RowsList-rowsList =- resultHandler $ \case- Result.Rows _ _ l -> Right l- _ -> Left "Not a rows result"--{-# INLINE rowsAffected #-}-rowsAffected :: ResultHandler ByteString-rowsAffected =- resultHandler $ \case- Result.CommandOK (Just v) -> Right $ return v- _ -> Left "Not a number of affected rows"--{-# INLINE resultHandler #-}-resultHandler :: (Result.Result -> Either Text (IO a)) -> ResultHandler a-resultHandler partial result =- case partial result of- Right io -> - io- Left text -> - -- Handle erroneous results with unexpected result as a fallback.- case result of- Result.StatusError _ c _ _ _ | elem c codes ->- throwIO Backend.TransactionConflict- where- codes =- [- ErrorCode.transaction_rollback,- ErrorCode.transaction_integrity_constraint_violation,- ErrorCode.serialization_failure,- ErrorCode.statement_completion_unknown,- ErrorCode.deadlock_detected- ]- _ ->- maybe- (throwIO $ Backend.UnexpectedResult text)- (throwIO . Backend.ErroneousResult)- (Result.erroneousResultText result)--
− library/Hasql/Postgres/ResultParser.hs
@@ -1,185 +0,0 @@-module Hasql.Postgres.ResultParser-( - Result(..), - StatusErrorStatus(..),- RowsStream(..),- RowsVector(..),- RowsList(..),- parse,- erroneousResultText,-)-where--import Hasql.Postgres.Prelude-import qualified Database.PostgreSQL.LibPQ as L-import qualified Data.Vector as Vector-import qualified Data.Vector.Mutable as MVector-import qualified ListT-import qualified Data.Text.Encoding as Text-import qualified Data.Text as Text---data Result =- -- |- -- Out-of-memory conditions or serious errors such as inability to send the command to the server.- -- May contain some description.- NoResult (Maybe ByteString) |- -- |- -- A failure with comprehensive description.- -- - -- The fields are: status, code, message, detail, hint.- StatusError StatusErrorStatus ByteString (Maybe ByteString) (Maybe ByteString) (Maybe ByteString) |- -- |- -- Command executed fine.- -- - -- The fields are: a number of affected rows.- CommandOK (Maybe ByteString) |- -- |- -- Command executed fine and returns rows.- -- - -- The fields are generators of respective rows representations.- Rows (IO RowsStream) (IO RowsVector) (IO RowsList)--data StatusErrorStatus =- BadResponse | NonfatalError | FatalError- deriving (Show, Typeable, Eq, Ord, Enum, Bounded)---parse :: L.Connection -> Maybe L.Result -> IO Result-parse c =- \case- Nothing ->- NoResult <$> L.errorMessage c- Just r ->- L.resultStatus r >>=- \case- L.CommandOk ->- CommandOK <$> L.cmdTuples r- L.TuplesOk ->- return $ Rows <$> getRowsStream <*> getRowsVector <*> getRowsList $ r- L.BadResponse ->- statusError BadResponse- L.NonfatalError ->- statusError NonfatalError- L.FatalError ->- statusError FatalError- r ->- $bug $ "Unsupported result status: " <> show r- where- statusError s =- StatusError s <$> state <*> message <*> detail <*> hint- where- state = fromJust <$> L.resultErrorField r L.DiagSqlstate- message = L.resultErrorField r L.DiagMessagePrimary- detail = L.resultErrorField r L.DiagMessageDetail- hint = L.resultErrorField r L.DiagMessageHint---{-# INLINE erroneousResultText #-}-erroneousResultText :: Result -> Maybe Text-erroneousResultText =- \case- NoResult (Just bs) -> - Just $ "Unable to send command to the server due to: " <> Text.decodeLatin1 bs- NoResult Nothing -> - Just $ "Unable to send command to the server"- StatusError status code message details hint ->- Just $ - "A status error. " <> formatFields fields- where- formatFields = - formatList . map formatField . catMaybes- where- formatList items =- Text.intercalate "; " items <> "."- formatField (n, v) =- n <> ": \"" <> v <> "\""- fields =- [- Just ("Status", fromString $ show status),- Just ("Code", Text.decodeLatin1 code),- fmap (("Message",) . Text.decodeLatin1) $ message,- fmap (("Details",) . Text.decodeLatin1) $ details,- fmap (("Hint",) . Text.decodeLatin1) $ hint- ]- _ -> - Nothing------ * Rows processing----------------------------type Row =- Vector (Maybe ByteString)---type RowsStream =- ListT IO Row--getRowsStream :: L.Result -> IO RowsStream-getRowsStream r =- do- nr <- L.ntuples r- nc <- L.nfields r- return $ - let- loop ir = - if ir < nr- then do - row <- - liftIO $ do- mv <- MVector.new (colInt nc)- forM_ [0..pred nc] $ \ic ->- MVector.write mv (colInt ic) =<< L.getvalue r ir ic- Vector.unsafeFreeze mv- ListT.cons row (loop (succ ir))- else mzero- in - loop 0---type RowsVector =- Vector Row--getRowsVector :: L.Result -> IO RowsVector-getRowsVector r =- do- nr <- L.ntuples r- nc <- L.nfields r- mvx <- MVector.new (rowInt nr)- forM_ [0..pred nr] $ \ir -> do- mvy <- MVector.new (colInt nc)- forM_ [0..pred nc] $ \ic -> do- MVector.write mvy (colInt ic) =<< L.getvalue r ir ic- vy <- Vector.unsafeFreeze mvy- MVector.write mvx (rowInt ir) vy- Vector.unsafeFreeze mvx---type RowsList =- [Row]--getRowsList :: L.Result -> IO RowsList-getRowsList r =- do- nr <- L.ntuples r- nc <- L.nfields r- mvx <- MVector.new (rowInt nr)- forM [0..pred nr] $ \ir -> do- mvy <- MVector.new (colInt nc)- forM_ [0..pred nc] $ \ic -> do- MVector.write mvy (colInt ic) =<< L.getvalue r ir ic- Vector.unsafeFreeze mvy----- * Utils----------------------------{-# INLINE colInt #-}-colInt :: L.Column -> Int-colInt (L.Col n) = fromIntegral n--{-# INLINE rowInt #-}-rowInt :: L.Row -> Int-rowInt (L.Row n) = fromIntegral n
+ library/Hasql/Postgres/Session/Execution.hs view
@@ -0,0 +1,122 @@+module Hasql.Postgres.Session.Execution where++import Hasql.Postgres.Prelude+import qualified Data.HashTable.IO as Hashtables+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Hasql.Postgres.Statement as Statement+import qualified Hasql.Postgres.TemplateConverter as TemplateConverter+import qualified Hasql.Postgres.Session.ResultProcessing as ResultProcessing+++-- * Environment+-------------------------++type Env =+ (PQ.Connection, IORef Word16, Hashtables.BasicHashTable LocalKey RemoteKey)++newEnv :: PQ.Connection -> IO Env+newEnv c =+ (,,) <$> pure c <*> newIORef 0 <*> Hashtables.new+++-- |+-- Local statement key.+data LocalKey =+ LocalKey !ByteString ![Word32]+ deriving (Show, Eq)++instance Hashable LocalKey where+ hashWithSalt salt (LocalKey template types) =+ hashWithSalt salt template++localKey :: ByteString -> [PQ.Oid] -> LocalKey+localKey t ol =+ LocalKey t (map oidMapper ol)+ where+ oidMapper (PQ.Oid x) = fromIntegral x+++-- |+-- Remote statement key.+type RemoteKey =+ ByteString+++data Error =+ UnexpectedResult Text |+ ErroneousResult Text |+ UnparsableTemplate ByteString Text |+ TransactionConflict+++-- * Monad+-------------------------++newtype M r =+ M (ReaderT Env (EitherT Error IO) r)+ deriving (Functor, Applicative, Monad, MonadIO)++run :: Env -> M r -> IO (Either Error r)+run e (M m) =+ runEitherT $ runReaderT m e++throwError :: Error -> M a+throwError = M . lift . left++prepare :: ByteString -> [PQ.Oid] -> M RemoteKey+prepare s tl =+ do+ (c, counter, table) <- M $ ask+ let lk = localKey s tl+ rk <- liftIO $ Hashtables.lookup table lk+ ($ rk) $ ($ return) $ maybe $ do+ w <- liftIO $ readIORef counter+ let rk = fromString $ show w+ unitResult =<< do liftIO $ PQ.prepare c rk s (partial (not . null) tl)+ liftIO $ Hashtables.insert table lk rk+ liftIO $ writeIORef counter (succ w)+ return rk++statement :: Statement.Statement -> M (Maybe PQ.Result)+statement s =+ do+ (c, _, _) <- M $ ask+ let (template, params, preparable) = s+ convertedTemplate <-+ either (throwError . UnparsableTemplate template) return $ + TemplateConverter.convert template+ case preparable of+ True -> do+ let (tl, vl) = unzip params+ key <- prepare convertedTemplate tl+ liftIO $ PQ.execPrepared c key vl PQ.Binary+ False -> do+ let params' = map (\(t, v) -> (\(vb, vf) -> (t, vb, vf)) <$> v) params+ liftIO $ PQ.execParams c convertedTemplate params' PQ.Binary++liftResultProcessing :: ResultProcessing.M a -> M a+liftResultProcessing m =+ M $ ReaderT $ \(c, _, _) -> + EitherT $ fmap (either (Left . mapError) Right) $ ResultProcessing.run c m+ where+ mapError =+ \case+ ResultProcessing.UnexpectedResult t -> UnexpectedResult t+ ResultProcessing.ErroneousResult t -> ErroneousResult t+ ResultProcessing.TransactionConflict -> TransactionConflict++{-# INLINE unitResult #-}+unitResult :: Maybe PQ.Result -> M ()+unitResult =+ liftResultProcessing . (ResultProcessing.unit <=< ResultProcessing.just)++{-# INLINE vectorResult #-}+vectorResult :: Maybe PQ.Result -> M (Vector (Vector (Maybe ByteString)))+vectorResult =+ liftResultProcessing . (ResultProcessing.vector <=< ResultProcessing.just)++{-# INLINE countResult #-}+countResult :: Maybe PQ.Result -> M Word64+countResult =+ liftResultProcessing . (ResultProcessing.count <=< ResultProcessing.just)+
+ library/Hasql/Postgres/Session/ResultProcessing.hs view
@@ -0,0 +1,128 @@+module Hasql.Postgres.Session.ResultProcessing where++import Hasql.Postgres.Prelude+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Hasql.Postgres.ErrorCode as ErrorCode+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Attoparsec.ByteString.Char8 as Atto+import qualified Data.Vector as Vector+import qualified Data.Vector.Mutable as MVector+import qualified ListT+++newtype M r =+ M (EitherT Error (ReaderT PQ.Connection IO) r)+ deriving (Functor, Applicative, Monad, MonadIO)++data Error =+ UnexpectedResult Text |+ ErroneousResult Text |+ TransactionConflict++run :: PQ.Connection -> M r -> IO (Either Error r)+run e (M m) =+ flip runReaderT e $ runEitherT m++just :: Maybe PQ.Result -> M PQ.Result+just =+ ($ return) $ maybe $ M $ do+ m <- lift $ ask >>= liftIO . PQ.errorMessage+ left $ ErroneousResult $ case m of+ Nothing -> + "Sending a command to the server failed"+ Just m ->+ "Sending a command to the server failed due to: " <> + TE.decodeLatin1 m++checkStatus :: (PQ.ExecStatus -> Bool) -> PQ.Result -> M ()+checkStatus g r =+ do+ s <- liftIO $ PQ.resultStatus r+ unless (g s) $ do+ case s of+ PQ.BadResponse -> failWithErroneousResult "Bad response"+ PQ.NonfatalError -> failWithErroneousResult "Non-fatal error"+ PQ.FatalError -> failWithErroneousResult "Fatal error"+ _ -> M $ left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show s)+ where+ failWithErroneousResult status =+ do+ code <- liftIO $ PQ.resultErrorField r PQ.DiagSqlstate+ let transactionConflict =+ case code of+ Just x -> + elem x $+ [+ ErrorCode.transaction_rollback,+ ErrorCode.transaction_integrity_constraint_violation,+ ErrorCode.serialization_failure,+ ErrorCode.statement_completion_unknown,+ ErrorCode.deadlock_detected+ ]+ Nothing ->+ False+ in when transactionConflict $ M $ left $ TransactionConflict+ message <- liftIO $ PQ.resultErrorField r PQ.DiagMessagePrimary+ detail <- liftIO $ PQ.resultErrorField r PQ.DiagMessageDetail+ hint <- liftIO $ PQ.resultErrorField r PQ.DiagMessageHint+ M $ left $ ErroneousResult $ erroneousResultMessage status code message detail hint+ erroneousResultMessage status code message details hint =+ formatFields fields+ where+ formatFields = + formatList . map formatField . catMaybes+ where+ formatList items =+ T.intercalate "; " items <> "."+ formatField (n, v) =+ n <> ": \"" <> v <> "\""+ fields =+ [+ Just ("Status", fromString $ show status),+ fmap (("Code",) . TE.decodeLatin1) $ code,+ fmap (("Message",) . TE.decodeLatin1) $ message,+ fmap (("Details",) . TE.decodeLatin1) $ details,+ fmap (("Hint",) . TE.decodeLatin1) $ hint+ ]++unit :: PQ.Result -> M ()+unit r =+ checkStatus (\case PQ.CommandOk -> True; _ -> False) r++count :: PQ.Result -> M Word64+count r =+ do checkStatus (\case PQ.CommandOk -> True; _ -> False) r+ (liftIO $ PQ.cmdTuples r) >>= + maybe (M $ left $ UnexpectedResult $ "No number of affected rows")+ (parseWord64)++parseWord64 :: ByteString -> M Word64+parseWord64 b =+ either (\m -> M $ left $ UnexpectedResult $ "Couldn't parse Word64: " <> fromString m)+ (return)+ (Atto.parseOnly (Atto.decimal <* Atto.endOfInput) b)++vector :: PQ.Result -> M (Vector (Vector (Maybe ByteString)))+vector r =+ do+ checkStatus (\case PQ.TuplesOk -> True; _ -> False) r+ liftIO $ do+ nr <- PQ.ntuples r+ nc <- PQ.nfields r+ mvx <- MVector.new (rowInt nr)+ forM_ [0..pred nr] $ \ir -> do+ mvy <- MVector.new (colInt nc)+ forM_ [0..pred nc] $ \ic -> do+ MVector.write mvy (colInt ic) =<< PQ.getvalue r ir ic+ vy <- Vector.unsafeFreeze mvy+ MVector.write mvx (rowInt ir) vy+ Vector.unsafeFreeze mvx++{-# INLINE colInt #-}+colInt :: PQ.Column -> Int+colInt (PQ.Col n) = fromIntegral n++{-# INLINE rowInt #-}+rowInt :: PQ.Row -> Int+rowInt (PQ.Row n) = fromIntegral n
+ library/Hasql/Postgres/Session/Transaction.hs view
@@ -0,0 +1,116 @@+module Hasql.Postgres.Session.Transaction where++import Hasql.Postgres.Prelude+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Data.HashTable.IO as Hashtables+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Builder as BB+import qualified Data.ByteString.Lazy.Builder.ASCII as BB+import qualified Data.ByteString.Lazy as BL+import qualified Data.Vector as Vector+import qualified Hasql.Postgres.Session.Execution as Execution+import qualified Hasql.Postgres.Statement as Statement+++-- * Environment+-------------------------++data Env =+ Env {+ executionEnv :: Execution.Env,+ nameCounter :: IORef (Maybe Word16)+ }++newEnv :: Execution.Env -> IO Env+newEnv execution =+ Env <$> pure execution <*> newIORef Nothing+++-- * Monad+-------------------------++newtype M r =+ M (ReaderT Env (EitherT Error IO) r)+ deriving (Functor, Applicative, Monad, MonadIO)++data Error =+ NotInTransaction |+ ExecutionError Execution.Error++run :: Env -> M r -> IO (Either Error r)+run e (M m) =+ runEitherT $ runReaderT m e++throwError :: Error -> M a+throwError e = M $ lift $ left $ e++liftExecution :: Execution.M a -> M a+liftExecution m =+ M $ ReaderT $ \e ->+ EitherT $ fmap (either (Left . ExecutionError) Right) $ + Execution.run (executionEnv e) m++-- |+-- Requires to be in transaction.+nextName :: M ByteString+nextName =+ do+ e <- M $ ask+ transactionState <- liftIO $ readIORef (nameCounter e)+ counter <- maybe (throwError NotInTransaction) return transactionState+ liftIO $ writeIORef (nameCounter e) (Just $ succ counter)+ return $ fromString $ 'x' : show counter++-- |+-- Returns a cursor identifier.+declareCursor :: Statement.Statement -> M Statement.Cursor+declareCursor s =+ do+ name <- nextName+ liftExecution $ + Execution.unitResult =<< + Execution.statement (Statement.declareCursor name s)+ return name++fetchFromCursor :: Statement.Cursor -> M (Vector (Vector (Maybe ByteString)))+fetchFromCursor cursor =+ liftExecution $+ Execution.vectorResult =<< + Execution.statement (Statement.fetchFromCursor cursor)++beginTransaction :: Statement.TransactionMode -> M ()+beginTransaction mode =+ do+ e <- M $ ask+ liftIO $ writeIORef (nameCounter e) (Just 0)+ liftExecution $ + Execution.unitResult =<< + Execution.statement (Statement.beginTransaction mode)++finishTransaction :: Bool -> M ()+finishTransaction commit =+ do+ liftExecution $ + Execution.unitResult =<< + Execution.statement (bool Statement.abortTransaction Statement.commitTransaction commit)+ e <- M $ ask+ liftIO $ writeIORef (nameCounter e) Nothing+++-- * Stream+-------------------------++type Stream =+ ListT M (Vector (Maybe ByteString))++streamWithCursor :: Statement.Statement -> Stream+streamWithCursor statement =+ do+ cursor <- lift $ declareCursor statement+ let loop = do+ chunk <- lift $ fetchFromCursor cursor+ guard $ not $ Vector.null chunk+ Vector.foldl step mempty chunk <> loop+ step z r = z <> pure r+ in loop+
− library/Hasql/Postgres/StatementPreparer.hs
@@ -1,58 +0,0 @@--- |--- A backend-aware component, which prepares statements.-module Hasql.Postgres.StatementPreparer where--import Hasql.Postgres.Prelude-import qualified Data.HashTable.IO as Hashtables-import qualified Database.PostgreSQL.LibPQ as PQ-import qualified Hasql.Postgres.ResultParser as Result-import qualified Hasql.Postgres.ResultHandler as ResultHandler-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy.Builder as BB-import qualified Data.ByteString.Lazy.Builder.ASCII as BB-import qualified Data.ByteString.Lazy as BL----type StatementPreparer =- (PQ.Connection, IORef Word16, Hashtables.BasicHashTable LocalKey RemoteKey)----- |--- Local statement key.-data LocalKey =- LocalKey !ByteString ![PQ.Oid]- deriving (Show, Eq)---- |--- Optimized by ignoring the OIDs.-instance Hashable LocalKey where- hashWithSalt s (LocalKey b _) = hashWithSalt s b----- |--- Remote statement key.-type RemoteKey =- ByteString---new :: PQ.Connection -> IO StatementPreparer-new connection =- (,,) <$> pure connection <*> newIORef 0 <*> Hashtables.new--prepare :: ByteString -> [PQ.Oid] -> StatementPreparer -> IO RemoteKey-prepare s tl (c, counter, table) =- do- let k = LocalKey s tl- r <- Hashtables.lookup table k- case r of- Just r -> - return r- Nothing ->- do- w <- readIORef counter- n <- return (BL.toStrict $ BB.toLazyByteString $ BB.word16Dec w)- ResultHandler.unit =<< Result.parse c =<< PQ.prepare c n s (partial (not . null) tl)- Hashtables.insert table k n- writeIORef counter (succ w)- return n
tests/Main.hs view
@@ -35,6 +35,13 @@ htfMain $ htf_thisModulesTests +test_sameStatementUsedOnDifferentTypes =+ session1 $ do+ liftIO . assertEqual (Just (Identity ("abc" :: Text))) =<< do + H.tx Nothing $ H.single $ [H.q|SELECT ?|] ("abc" :: Text)+ liftIO . assertEqual (Just (Identity True)) =<< do + H.tx Nothing $ H.single $ [H.q|SELECT ?|] True+ test_rendering = assertEqual (Just $ head rows) =<< do session1 $ do