hasql 0.5.0 → 0.6.0

raw patch · 10 files changed

+509/−388 lines, 10 filesdep +eitherdep +mtldep +resource-pooldep −bytestringdep −ex-pooldep −loch-thdep ~hasql-backenddep ~hasql-postgresdep ~list-tPVP ok

version bump matches the API change (PVP)

Dependencies added: either, mtl, resource-pool

Dependencies removed: bytestring, ex-pool, loch-th, placeholders, safe, time

Dependency ranges changed: hasql-backend, hasql-postgres, list-t, monad-control, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• demo/Main.hs +28/−19
• hasql.cabal +20/−20
• hspec-postgres/Main.hs +59/−27
• hspec/Main.hs +30/−8
• library/Hasql.hs +247/−248
• library/Hasql/Prelude.hs +15/−34
• library/Hasql/QParser.hs +34/−22
• library/Hasql/RowParser.hs +12/−9
• library/Hasql/TH.hs +50/−1

@@ -1,3 +1,17 @@+# 0.6.0 - Major API overhaul+* The connection pool acquisition is now explicit and is no longer handled by the `Session` monad. This should provide for a simpler integration with other libraries.+* The `Session` monad is now merely a convenience thing for providing a context to multiple transactions. One can run it as many times as he wants - it won't reestablish any resources any more.+* The connection timeout is now set using `Int` for simplicity.+* There are no exceptions any more. All the error-reporting is typed and done explicitly, using `Either`.+* The error types are now mostly backend-specific.+* The transaction mode is now extended to support uncommittable transactions with the `TxWriteMode` type.+* All `Tx` functions are now appended with a "Tx" suffix.+* Added `vectorTx` and `maybeTx` and updated the semantics of `singleTx`.+* `q` statement quasi-quoter is now renamed to more meaningful `stmt`.+* The `Statement` type is renamed to `Stmt` and is now exported from the main API.+* `RowParser` is now uninstantiable. This enforces the idiomatic usage of the library.+* Statement templates now support UTF-8.+ # 0.5.0 * Update the "list-t" and "monad-control" deps 

@@ -1,16 +1,17 @@ -- You can execute this file with 'cabal bench demo'. {-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} -import Control.Monad+import Control.Monad hiding (forM_, mapM_, forM, mapM) import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Data.Functor.Identity+import Data.Foldable  -- Import the API from the "hasql" library import qualified Hasql as H --- Import the backend settings from the "hasql-postgres" library+-- Import the backend API from the "hasql-postgres" library import qualified Hasql.Postgres as HP  @@ -18,23 +19,28 @@    let postgresSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres" -  -- Prepare session settings with a smart constructor,+  -- Prepare the pool settings with a smart constructor,   -- which checks the inputted values on correctness.-  -- Set the connections pool size to 6 and the timeout to 30.-  sessionSettings <- maybe (fail "Improper session settings") return $ -                     H.sessionSettings 6 30+  -- Set the connection pool size to 6 and the timeout to 30 seconds.+  poolSettings <- maybe (fail "Improper session settings") return $ +                  H.poolSettings 6 30 -  -- Run a database session,-  -- while automatically managing the resources and exceptions.-  H.session postgresSettings sessionSettings $ do+  -- Acquire the database connections pool.+  -- Gotta help the compiler with the type signature of the pool a bit.+  pool :: H.Pool HP.Postgres +       <- H.acquirePool postgresSettings poolSettings +  -- Provide a context for execution of transactions.+  -- 'Session' is merely a convenience wrapper around 'ReaderT'.+  H.session pool $ do+     -- Execute a group of statements without any locking and ACID guarantees:     H.tx Nothing $ do-      H.unit [H.q|DROP TABLE IF EXISTS a|]-      H.unit [H.q|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|]+      H.unitTx [H.stmt|DROP TABLE IF EXISTS a|]+      H.unitTx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|]       -- Insert three rows:       replicateM_ 3 $ do -        H.unit [H.q|INSERT INTO a (balance) VALUES (0)|]+        H.unitTx [H.stmt|INSERT INTO a (balance) VALUES (0)|]      -- Declare a list of transfer settings, which we'll later use.     -- The tuple structure is: @@ -45,23 +51,26 @@     forM_ transfers $ \(id1, id2, amount) -> do       -- Run a transaction with ACID guarantees.       -- Hasql will automatically roll it back and retry it in case of conflicts.-      H.tx (Just (H.Serializable, True)) $ do+      H.tx (Just (H.Serializable, (Just True))) $ do         -- Use MaybeT to handle empty results:         runMaybeT $ do           -- To distinguish results rows containing just one column,            -- we use 'Identity' as a sort of a single element tuple.-          Identity balance1 <- MaybeT $ H.single $ [H.q|SELECT balance FROM a WHERE id=?|] id1-          Identity balance2 <- MaybeT $ H.single $ [H.q|SELECT balance FROM a WHERE id=?|] id2-          lift $ H.unit $ [H.q|UPDATE a SET balance=? WHERE id=?|] (balance1 - amount) id1-          lift $ H.unit $ [H.q|UPDATE a SET balance=? WHERE id=?|] (balance2 + amount) id2+          Identity balance1 <- MaybeT $ H.maybeTx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id1+          Identity balance2 <- MaybeT $ H.maybeTx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id2+          lift $ H.unitTx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance1 - amount) id1+          lift $ H.unitTx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance2 + amount) id2      -- Output all the updated rows:     do       -- Unfortunately in this case there's no way to infer the type of the results,       -- so we need to specify it explicitly:-      rows :: [(Int, Int)] <- H.tx Nothing $ H.list $ [H.q|SELECT * FROM a|]-      forM_ rows $ \(id, amount) -> do+      rows <- H.tx Nothing $ H.vectorTx $ [H.stmt|SELECT * FROM a|]+      forM_ rows $ \(id :: Int, amount :: Int) -> do         liftIO $ putStrLn $ "ID: " ++ show id ++ ", Amount: " ++ show amount++  -- Release all previously acquired resources. Just for fun.+  H.releasePool pool   

@@ -1,7 +1,7 @@ name:   hasql version:-  0.5.0+  0.6.0 synopsis:   A minimalistic general high level API for relational databases description:@@ -10,7 +10,7 @@   .   Features:   .-  * Concise and crisp API. Just a few functions and two monads doing all the+  * Concise and crisp API. Just a few functions and one monad doing all the   boilerplate job for you.   .   * A powerful transaction abstraction, which provides @@ -31,7 +31,7 @@   * Automated management of resources related to connections, transactions and   cursors.   .-  * A built-in connections pool.+  * A built-in connection pool.   .   * Compile-time generation of templates. You just can't write a statement with an   incorrect number of placeholders.@@ -94,25 +94,21 @@   exposed-modules:     Hasql   build-depends:-    hasql-backend == 0.2.*,-    -- template-haskell:+    -- +    resource-pool == 0.2.*,+    hasql-backend == 0.3.*,+    --      template-haskell >= 2.8 && < 2.10,-    -- parsing:+    --      attoparsec >= 0.10 && < 0.13,-    -- database:-    ex-pool == 0.2.*,-    -- data:+    --      vector < 0.11,-    time >= 1.4 && < 1.6,-    bytestring == 0.10.*,     text >= 1.0 && < 1.3,-    -- errors:-    loch-th == 0.2.*,-    placeholders == 0.1.*,-    -- general:-    safe == 0.3.*,-    list-t >= 0.4 && < 0.5,+    -- +    either >= 4.3 && < 4.4,+    list-t >= 0.3.1 && < 0.5,     mmorph == 1.0.*,+    mtl >= 2.1 && < 2.3,     monad-control == 1.0.*,     transformers-base == 0.4.*,     transformers >= 0.3 && < 0.5,@@ -138,10 +134,12 @@   build-depends:     --      hasql,-    hasql-backend == 0.2.*,+    hasql-backend,     --      hspec == 2.1.*,     -- +    vector,+    --      mtl-prelude < 3,     base-prelude,     base@@ -165,7 +163,7 @@   build-depends:     --      hasql,-    hasql-postgres == 0.9.*,+    hasql-postgres == 0.10.*,     --      slave-thread == 0.1.*,     -- @@ -173,6 +171,8 @@     --      text,     -- +    monad-control,+    either,     mtl-prelude < 3,     base-prelude,     base@@ -197,7 +197,7 @@     Haskell2010   build-depends:     hasql,-    hasql-postgres == 0.9.*,+    hasql-postgres == 0.10.*,     transformers >= 0.3 && < 0.5,     base >= 4.5 && < 4.8 

@@ -1,5 +1,7 @@ import BasePrelude import MTLPrelude+import Control.Monad.Trans.Either+import Control.Monad.Trans.Control import Test.Hspec import Data.Text (Text) import qualified Hasql as H@@ -10,23 +12,42 @@ main =    hspec $ do +    context "Tx" $ do++      it "does not commit if in uncommitting mode" $ do+        flip shouldBe (Right (Nothing :: Maybe (Identity Int))) =<< do+          session $ do+            H.tx Nothing $ do+              H.unitTx $ [H.stmt|DROP TABLE IF EXISTS a|]+              H.unitTx $ [H.stmt|CREATE TABLE a (x INT8 NOT NULL, PRIMARY KEY (x))|]+            H.tx (Just (H.Serializable, Just False)) $ do+              H.unitTx $ [H.stmt|INSERT INTO a (x) VALUES (2)|]+            H.tx Nothing $ do+              H.maybeTx $ [H.stmt|SELECT x FROM a WHERE x = 2|]++    context "UTF-8 templates" $ do++      it "encode properly" $ do+        flip shouldBe (Right (Just (Identity ("Ёжик" :: Text)))) =<< do+          session $ H.tx Nothing $ H.maybeTx $ [H.stmt| SELECT 'Ёжик' |]+     context "Bug" $ do        context "Unhandled transaction conflict" $ do          it "should not be" $ do           session $ H.tx Nothing $ do-            H.unit [H.q|DROP TABLE IF EXISTS artist|]-            H.unit [H.q|DROP TABLE IF EXISTS artist_union|]-            H.unit $-              [H.q|+            H.unitTx [H.stmt|DROP TABLE IF EXISTS artist|]+            H.unitTx [H.stmt|DROP TABLE IF EXISTS artist_union|]+            H.unitTx $+              [H.stmt|                 CREATE TABLE "artist_union" (                   "id" BIGSERIAL,                   PRIMARY KEY ("id")                 )               |]-            H.unit $-              [H.q|+            H.unitTx $+              [H.stmt|                 CREATE TABLE "artist" (                   "id" BIGSERIAL,                   "artist_union_id" INT8 NOT NULL,@@ -39,14 +60,14 @@           let              insertArtistUnion :: H.Tx HP.Postgres s Int64             insertArtistUnion =-              fmap (runIdentity . fromJust) $ H.single $-              [H.q| +              fmap (runIdentity . fromJust) $ H.maybeTx $+              [H.stmt|                  INSERT INTO artist_union DEFAULT VALUES RETURNING id               |]             insertArtist :: Int64 -> [Text] -> H.Tx HP.Postgres s Int64             insertArtist unionID artistNames = -              fmap (runIdentity . fromJust) $ H.single $-              [H.q| +              fmap (runIdentity . fromJust) $ H.maybeTx $+              [H.stmt|                  INSERT INTO artist                   (artist_union_id,                     names)@@ -58,7 +79,7 @@             process =                  SlaveThread.fork $ do                   session $ replicateM_ 100 $ do -                    H.tx (Just (H.Serializable, True)) $ do+                    H.tx (Just (H.Serializable, Just True)) $ do                       unionID <- insertArtistUnion                       insertArtist unionID ["a", "b", "c"]                   signal@@ -68,32 +89,25 @@     context "RowParser" $ do        it "should fail on incorrect arity" $ do-        flip shouldThrow (\case H.UnparsableRow _ -> True; _ -> False) $+        flip shouldSatisfy (\case Left (H.ResultError _) -> True; _ -> False) =<< do           session $ do             H.tx Nothing $ do-              H.unit [H.q|DROP TABLE IF EXISTS data|]-              H.unit [H.q|CREATE TABLE data (-                              field1    DECIMAL NOT NULL,-                              field2    BIGINT  NOT NULL,-                              PRIMARY KEY (field1)-                          )|]-              H.unit [H.q|INSERT INTO data (field1, field2) VALUES (0, 0)|]+              H.unitTx [H.stmt|DROP TABLE IF EXISTS data|]+              H.unitTx [H.stmt|CREATE TABLE data (+                                   field1    DECIMAL NOT NULL,+                                   field2    BIGINT  NOT NULL,+                                   PRIMARY KEY (field1)+                               )|]+              H.unitTx [H.stmt|INSERT INTO data (field1, field2) VALUES (0, 0)|]             mrow :: Maybe (Double, Int64, String) <-                H.tx Nothing $  -                H.single $ [H.q|SELECT * FROM data|]+                H.maybeTx $ [H.stmt|SELECT * FROM data|]             return ()   -- * Helpers ------------------------- -session :: (forall s. H.Session HP.Postgres s IO r) -> IO r-session =-  H.session backendSettings poolSettings-  where-    backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"-    poolSettings = fromJust $ H.sessionSettings 6 30- newBatchGate :: Int -> IO (IO (), IO ()) newBatchGate amount =   do@@ -102,3 +116,21 @@       let signal = atomically $ readTVar counter >>= writeTVar counter . pred           block = atomically $ readTVar counter >>= \x -> when (x > 0) retry           in (signal, block)+++-- * Hasql utils+-------------------------++type Session m =+  H.Session HP.Postgres m++session :: MonadBaseControl IO m => Session m r -> m (Either (H.SessionError HP.Postgres) r)+session m =+  control $ \unlift -> do+    p <- H.acquirePool backendSettings poolSettings+    r <- unlift $ H.session p m+    H.releasePool p+    return r+  where+    backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"+    poolSettings = fromJust $ H.poolSettings 6 30

@@ -2,21 +2,43 @@ import Test.Hspec import qualified Hasql as H import qualified Hasql.Backend as HB+import qualified Data.Vector as V   data X-instance HB.Backend X where-  data StatementArgument X = -    StatementArgument String-    deriving (Eq, Show)-instance HB.Mapping X Char where-  renderValue = StatementArgument . show +data instance HB.StmtParam X = +  StmtParam String +  deriving (Eq, Show) +deriving instance Show (HB.Stmt X)+deriving instance Eq (HB.Stmt X)++instance HB.CxValue X Char where+  encodeValue = StmtParam . show+ main =    hspec $ do     context "Quasi quoter" $ do       it "generates a proper statement" $ do         (flip shouldBe)-          (" SELECT ? ", [HB.renderValue 'a'], True)-          ([H.q| SELECT ? |] 'a' :: HB.Statement X)+          (HB.Stmt "SELECT (? + ?)" (V.fromList [HB.encodeValue 'a', HB.encodeValue 'b']) True)+          ([H.stmt| SELECT (? + ?) |] 'a' 'b' :: HB.Stmt X)+      it "does not drop quotes" $ do+        let +          HB.Stmt t _ _ =+            [H.stmt| SELECT "a", 'b' |]+        (flip shouldBe)+          "SELECT \"a\", 'b'"+          t+      it "cleans whitespace" $ do+        let +          HB.Stmt t _ _ =+            [H.stmt| CREATE TABLE data (+                       field1    DECIMAL NOT NULL,+                       field2    BIGINT  NOT NULL,+                       PRIMARY KEY (field1)+                     ) |]+        (flip shouldBe)+          "CREATE TABLE data ( field1 DECIMAL NOT NULL, field2 BIGINT NOT NULL, PRIMARY KEY (field1) )"+          t

@@ -4,265 +4,316 @@ -- For an introduction to the package  -- and links to more documentation please refer to  -- <../ the package's index page>.+-- +-- This API is completely disinfected from exceptions. +-- All error-reporting is explicit and +-- is presented using the 'Either' type. module Hasql (+  -- * Pool+  Pool,+  acquirePool,+  releasePool,++  -- ** Pool Settings+  PoolSettings,+  poolSettings,+   -- * Session   Session,   session,-  sessionUnlifter, -  -- ** Session Settings-  SessionSettings,-  sessionSettings,+  -- ** Session Error+  SessionError(..), +  -- * Statement+  Bknd.Stmt,+  stmt,++  -- ** Statement Execution+  unitTx,+  countTx,+  singleTx,+  maybeTx,+  listTx,+  vectorTx,+  streamTx,+   -- * Transaction   Tx,   tx,    -- ** Transaction Settings-  Mode,-  Backend.IsolationLevel(..),--  -- * Statement Quasi-Quoter-  q,--  -- * Statement Execution-  unit,-  count,-  single,-  list,-  stream,+  Bknd.TxMode(..),+  Bknd.TxIsolationLevel(..),+  Bknd.TxWriteMode(..), -  -- * Results Stream+  -- ** Result Stream   TxListT, -  -- * Row parser-  RowParser.RowParser(..),-  -  -- * Error-  Error(..),+  -- * Row Parser+  RowParser.RowParser, ) where -import Hasql.Prelude hiding (Error)-import Hasql.Backend (Backend)-import Hasql.RowParser (RowParser)-import qualified Hasql.Backend as Backend+import Hasql.Prelude+import qualified Hasql.Backend as Bknd import qualified Hasql.RowParser as RowParser import qualified Hasql.QParser as QParser import qualified ListT import qualified Data.Pool as Pool+import qualified Data.Text as Text import qualified Data.Vector as Vector+import qualified Data.Vector.Mutable as MVector import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified Hasql.TH as THUtil  --- * Session+-- * Resources -------------------------  -- |--- A monad transformer,--- which executes transactions.--- --- * @b@ is a backend.--- --- * @s@ is an anonymous variable, --- used to associate 'sessionUnlifter' with a specific session. --- --- * @m@ is an inner (transformed) monad.--- --- * @r@ is a result.-newtype Session b s m r =-  Session (ReaderT (Pool.Pool (Backend.Connection b)) m r)-  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)--instance MonadTransControl (Session b s) where-  type StT (Session b s) a = a-  liftWith onRunner =-    Session $ ReaderT $ \e -> onRunner $ \(Session (ReaderT f)) -> f e-  restoreT = -    Session . ReaderT . const--instance (MonadBase IO m) => MonadBase IO (Session b s m) where-  liftBase = Session . liftBase--instance (MonadBaseControl IO m) => MonadBaseControl IO (Session b s m) where-  type StM (Session b s m) a = ComposeSt (Session b s) m a-  liftBaseWith = defaultLiftBaseWith-  restoreM = defaultRestoreM----- |--- Given backend settings, session settings, and a session monad transformer,--- execute it in the inner monad.--- --- It uses the same trick as 'ST' with the anonymous @s@ type argument--- to prohibit the use of the result of--- 'sessionUnlifter' outside of its creator session.-session :: -  (Backend.Backend b, MonadBaseControl IO m) =>-  b -> SessionSettings -> (forall s. Session b s m r) -> m r-session backend (SessionSettings size timeout) s =-  control $ \runInIO ->-    mask $ \unmask -> do-      p <- Pool.createPool (Backend.connect backend) Backend.disconnect 1 timeout size-      r <- try $ unmask $ runInIO $ runSession p s-      Pool.purgePool p-      either (throwIO :: SomeException -> IO r) return r+-- A connection pool. +newtype Pool c =+  Pool (Pool.Pool (Either (Bknd.CxError c) c))  -- |--- Get a session unlifting function, --- which allows to execute a session in the inner monad--- using the resources of the current session.--- --- Using this function in combination with 'lift'--- you can interleave 'Session' with other monad transformers.+-- Given backend-specific connection settings and pool settings, +-- acquire a backend connection pool,+-- which can then be used to work with the DB. -- --- This function has the following property:+-- When combining Hasql with other libraries, +-- which throw exceptions it makes sence to utilize +-- @Control.Exception.'bracket'@+-- like this: -- --- > (sessionUnlifter >>= \unlift -> lift (unlift m)) ≡ m-sessionUnlifter :: (MonadBaseControl IO m) => Session b s m (Session b s m r -> m r)-sessionUnlifter =-  Session $ ReaderT $ return . runSession+-- >bracket (acquirePool bkndStngs poolStngs) (releasePool) $ \pool -> do+-- >  session pool $ do+-- >    ...+-- >  ... any other IO code+acquirePool :: Bknd.Cx c => Bknd.CxSettings c -> PoolSettings -> IO (Pool c)+acquirePool cxSettings (PoolSettings size timeout) =+  fmap Pool $+  Pool.createPool (Bknd.acquireCx cxSettings) +                  (either (const $ return ()) Bknd.releaseCx) +                  (1)+                  (fromIntegral timeout) +                  (size) -runSession :: (MonadBaseControl IO m) => Pool.Pool (Backend.Connection b) -> Session b s m r -> m r-runSession e (Session r) =-  control $ \runInIO -> -    catch (runInIO (runReaderT r e)) $ \case-      Backend.CantConnect t -> throwIO $ CantConnect t-      Backend.ConnectionLost t -> throwIO $ ConnectionLost t-      Backend.ErroneousResult t -> throwIO $ ErroneousResult t-      Backend.UnexpectedResult t -> throwIO $ UnexpectedResult t-      Backend.UnparsableTemplate t -> throwIO $ UnparsableTemplate t-      Backend.TransactionConflict -> $bug "Unexpected TransactionConflict exception"-      Backend.NotInTransaction -> throwIO $ NotInTransaction+-- |+-- Release all connections acquired by the pool.+releasePool :: Pool c -> IO ()+releasePool (Pool p) =+  Pool.destroyAllResources p  --- ** Session Settings+-- ** Pool Settings -------------------------  -- |--- Settings of a session.-data SessionSettings =-  SessionSettings !Word32 !NominalDiffTime+-- Settings of a pool.+data PoolSettings =+  PoolSettings !Int !Int  -- | --- A smart constructor for session settings.-sessionSettings :: -  Word32+-- A smart constructor for pool settings.+poolSettings :: +  Int   -- ^   -- The maximum number of connections to keep open.    -- The smallest acceptable value is 1.   -- Requests for connections will block if this limit is reached.   -> -  NominalDiffTime+  Int   -- ^-  -- The amount of time for which an unused connection is kept open. -  -- The smallest acceptable value is 0.5 seconds.+  -- The amount of seconds for which an unused connection is kept open. +  -- The smallest acceptable value is 1.   -> -  Maybe SessionSettings+  Maybe PoolSettings   -- ^-  -- Maybe session settings, if they are correct.-sessionSettings size timeout =-  if size > 0 && timeout >= 0.5-    then Just $ SessionSettings size timeout+  -- Maybe pool settings, if they are correct.+poolSettings size timeout =+  if size > 0 && timeout >= 1+    then Just $ PoolSettings size timeout     else Nothing  --- ** Error+-- * Session -------------------------  -- |--- The only exception type that this API can raise.-data Error =-  -- |-  -- Cannot connect to a server.-  CantConnect Text |-  -- |-  -- The connection got interrupted.-  ConnectionLost Text |-  -- |-  -- An error returned from the database.-  ErroneousResult Text |-  -- |-  -- Unexpected result structure.-  -- Indicates usage of inappropriate statement executor.-  UnexpectedResult Text |+-- A convenience wrapper around 'ReaderT', +-- which provides a shared context for execution and error-handling of transactions.+newtype Session c m r =+  Session (ReaderT (Pool c) (EitherT (SessionError c) m) r)+  deriving (Functor, Applicative, Monad, MonadIO, MonadError (SessionError c))++instance MonadTrans (Session c) where+  lift = Session . lift . lift++instance MonadTransControl (Session c) where+  type StT (Session c) a = Either (SessionError c) a+  liftWith onUnlift =+    Session $ ReaderT $ \e -> +      lift $ onUnlift $ \(Session m) -> +        runEitherT $ flip runReaderT e $ m+  restoreT = +    Session . ReaderT . const . EitherT++deriving instance MonadBase IO m => MonadBase IO (Session c m)++instance (MonadBaseControl IO m) => MonadBaseControl IO (Session c m) where+  type StM (Session c m) a = ComposeSt (Session c) m a+  liftBaseWith = defaultLiftBaseWith+  restoreM = defaultRestoreM++instance MFunctor (Session c) where+  hoist f (Session m) = +    Session $ ReaderT $ \e ->+      EitherT $ f $ runEitherT $ flip runReaderT e $ m++-- |+-- Execute a session using an established connection pool.+-- +-- This is merely a wrapper around 'runReaderT',+-- so you can run it around every transaction,+-- if you want.+session :: Pool c -> Session c m a -> m (Either (SessionError c) a)+session pool m =+  runEitherT $ flip runReaderT pool $ case m of Session m -> m+++-- * Transaction+-------------------------++-- |+-- A transaction specialized for a backend connection @c@, +-- associated with its intermediate results using an anonymous type-argument @s@ (same trick as in 'ST')+-- and producing a result @r@.+-- +-- Running `IO` in `Tx` is prohibited. +-- The motivation is identical to `STM`: +-- the `Tx` block may get executed multiple times if any transaction conflicts arise. +-- This will result in your effectful `IO` code being executed +-- an unpredictable amount of times as well, +-- which, chances are, is not what you want.+newtype Tx c s r =+  Tx { unwrapTx :: EitherT (SessionError c) (Bknd.Tx c) r }+  deriving (Functor, Applicative, Monad)+++data SessionError c =   -- |-  -- Incorrect statement template.-  UnparsableTemplate Text |+  -- A backend-specific connection acquisition error.+  -- E.g., a failure to establish a connection.+  CxError (Bknd.CxError c) |   -- |-  -- An operation, -  -- which requires a database transaction was executed without one.-  NotInTransaction |+  -- A backend-specific transaction error.+  -- It should cover all possible failures related to an established connection,+  -- including the loss of connection, query errors and database failures.+  TxError (Bknd.TxError c) |   -- |-  -- Attempt to parse a row into an incompatible type.+  -- Attempt to parse a result into an incompatible type.   -- Indicates either a mismatching schema or an incorrect query.-  UnparsableRow Text-  deriving (Show, Typeable, Eq, Ord)+  ResultError Text -instance Exception Error+deriving instance (Show (Bknd.CxError c), Show (Bknd.TxError c)) => Show (SessionError c)+deriving instance (Eq (Bknd.CxError c), Eq (Bknd.TxError c)) => Eq (SessionError c) +-- |+-- Execute a transaction in a session.+-- +-- This function ensures on the type level, +-- that it's impossible to return @'TxListT' s m r@ from it.+tx :: (Bknd.CxTx c, MonadBaseControl IO m) => Bknd.TxMode -> (forall s. Tx c s r) -> Session c m r+tx mode (Tx m) =+  Session $ ReaderT $ \(Pool pool) ->+    Pool.withResource pool $ \e -> do+      c <- hoistEither $ mapLeft CxError e+      let+        attempt =+          do+            r <- EitherT $ liftBase $ fmap (either (Left . TxError) Right) $ +                 Bknd.runTx c mode $ runEitherT m+            maybe attempt hoistEither r+        in attempt --- * Transaction++-- * Statements execution -------------------------  -- |--- A transaction specialized for a backend @b@, --- associated with its intermediate results using an anonymous type-argument @s@ (same as in 'ST')--- and producing a result @r@.-newtype Tx b s r =-  Tx (ReaderT (Backend.Connection b) IO r)-  deriving (Functor, Applicative, Monad)+-- Execute a statement without processing the result.+unitTx :: Bknd.Stmt c -> Tx c s ()+unitTx = +  Tx . lift . Bknd.unitTx  -- |--- A transaction mode defining how a transaction should be executed.+-- Execute a statement and count the amount of affected rows.+-- Useful for resolving how many rows were updated or deleted.+countTx :: Bknd.CxValue c Word64 => Bknd.Stmt c -> Tx c s Word64+countTx =+  Tx . lift . Bknd.countTx++-- |+-- Execute a statement,+-- which produces exactly one result row.+-- E.g., @INSERT@, which returns an autoincremented identifier,+-- or @SELECT COUNT@, or @SELECT EXISTS@. -- --- * @Just (isolationLevel, write)@ indicates that a database transaction--- should be established with a specified isolation level and a boolean, --- defining, whether it would perform any modification operations.+-- Please note that using this executor for selecting rows is conceptually wrong, +-- since in that case the results are always optional. +-- Use 'maybeTx', 'listTx' or 'vectorTx' instead. -- --- * @Nothing@ indicates that there should be no database transaction established on--- the backend and therefore it should be executed with no ACID guarantees,--- but also without any induced overhead.-type Mode =-  Maybe (Backend.IsolationLevel, Bool)+-- If the result is empty this executor will raise 'ResultError'.+singleTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s r+singleTx =+  join . fmap (maybe (Tx $ left $ ResultError "No rows on 'singleTx'") return) .+  maybeTx  -- |--- Execute a transaction in a session.+-- Execute a statement,+-- which optionally produces a single result row.+maybeTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (Maybe r)+maybeTx =+  fmap (fmap Vector.unsafeHead . mfilter (not . Vector.null) . Just) . vectorTx++-- |+-- Execute a statement,+-- and produce a list of results.+listTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s [r]+listTx =+  fmap toList . vectorTx++-- |+-- Execute a statement,+-- and produce a vector of results.+vectorTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (Vector r)+vectorTx s =+  Tx $ do+    r <- lift $ Bknd.vectorTx s+    EitherT $ return $ traverse ((mapLeft ResultError) . RowParser.parseRow) $ r++-- |+-- Execute a @SELECT@ statement with a cursor,+-- and produce a result stream. -- --- This function ensures on the type level, --- that it's impossible to return @'TxListT' s m r@ from it.-tx :: -  (Backend.Backend b, MonadBase IO m) =>-  Mode -> (forall s. Tx b s r) -> Session b s m r-tx m t =-  Session $ ReaderT $ \p -> liftBase $ Pool.withResource p $ \c -> runTx c m t-  where-    runTx ::-      Backend b => -      Backend.Connection b -> Mode -> (forall s. Tx b s r) -> IO r-    runTx connection mode (Tx reader) =-      maybe (const id) inTransaction mode connection (runReaderT reader connection)-      where-        inTransaction ::-          Backend b => -          Backend.TransactionMode -> Backend.Connection b -> IO r -> IO r-        inTransaction mode c io =-          let -            io' = -              Backend.beginTransaction mode c *> io <* Backend.finishTransaction True c-            in-              try io' >>= \case-                Left Backend.TransactionConflict -> do-                  Backend.finishTransaction False c-                  inTransaction mode c io-                Left e -> throwIO e-                Right r -> return r+-- Cursor allows you to fetch virtually limitless results in a constant memory+-- at a cost of a small overhead.+-- Note that in most databases cursors require establishing a database transaction,+-- so depending on a backend the transaction may result in an error,+-- if you run it improperly.+streamTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (TxListT s (Tx c s) r)+streamTx s =+  Tx $ do+    r <- lift $ Bknd.streamTx s+    return $ TxListT $ do+      row <- hoist (Tx . lift) r+      lift $ Tx $ EitherT $ return $ mapLeft ResultError $ RowParser.parseRow $ row  --- * Results Stream+-- * Result Stream -------------------------  -- |@@ -273,7 +324,7 @@ -- which uses the same trick as the 'ST' monad to associate with the -- context transaction and become impossible to be used outside of it. -- This lets the library ensure that it is safe to automatically--- release all the resources associated with this stream.+-- release all the connections associated with this stream. --  -- All the functions of the \"list-t\" library are applicable to this type, -- amongst which are 'ListT.head', 'ListT.toList', 'ListT.fold', 'ListT.traverse_'.@@ -289,72 +340,21 @@     (unsafeCoerce :: TxListT s m r -> ListT.ListT m r)  --- * Statements execution------------------------------ |--- Execute a statement, which produces no result.-unit :: Backend b => Backend.Statement b -> Tx b s ()-unit s =-  Tx $ ReaderT $ Backend.execute s---- |--- Execute a statement and count the amount of affected rows.--- Useful for resolving how many rows were updated or deleted.-count :: (Backend b, Backend.Mapping b Word64) => Backend.Statement b -> Tx b s Word64-count s =-  Tx $ ReaderT $ Backend.executeAndCountEffects s---- |--- Execute a statement,--- which produces a single result row: --- a @SELECT@ --- or an @INSERT@, which produces a generated value (e.g., an auto-incremented id).-single :: (Backend b, RowParser b r) => Backend.Statement b -> Tx b s (Maybe r)-single s =-  headMay <$> list s---- |--- Execute a @SELECT@ statement,--- and produce a list of results.-list :: (Backend b, RowParser b r) => Backend.Statement b -> Tx b s [r]-list s =-  Tx $ ReaderT $ \c -> do-    m <- Backend.executeAndGetMatrix s c-    traverse (either (throwIO . UnparsableRow) return . RowParser.parseRow) $ Vector.toList m---- |--- Execute a @SELECT@ statement with a cursor,--- and produce a results stream.--- --- Cursor allows you to fetch virtually limitless results in a constant memory--- at a cost of a small overhead.--- Note that in most databases cursors require establishing a database transaction,--- so a 'NotInTransaction' error will be raised if you run it improperly.-stream :: (Backend b, RowParser b r) => Backend.Statement b -> TxListT s (Tx b s) r-stream s =-  do-    s <- lift $ Tx $ ReaderT $ \c -> Backend.executeAndStream s c-    TxListT $ hoist (Tx . lift) $ do-      row <- s-      either (lift . throwIO . UnparsableRow) return $ RowParser.parseRow row-- -- * Statements quasi-quotation -------------------------  -- | -- Produces a lambda-expression,  -- which takes as many parameters as there are placeholders in the quoted text--- and results in a 'Backend.Statement'. +-- and results in a 'Bknd.Stmt'.  --  -- E.g.: -- --- >selectFive :: Statement b--- >selectFive = [q|SELECT (? + ?)|] 2 3+-- >selectSum :: Int -> Int -> Stmt c+-- >selectSum = [stmt|SELECT (? + ?)|] -- -q :: TH.QuasiQuoter-q = +stmt :: TH.QuasiQuoter+stmt =    TH.QuasiQuoter     (parseExp)     (const $ fail "Pattern context is not supported")@@ -363,19 +363,18 @@   where     parseExp s =       do-        n <- either (fail . showString "Parsing failure: ") return (QParser.parse (fromString s))-        return $ statementF s n+        (t, n) <- either (fail . showString "Parsing failure: ") return (QParser.parse (fromString s))+        return $ statementF (Text.unpack t) (fromIntegral n)     statementF s n =       TH.LamE         (map TH.VarP argNames)-        (THUtil.purify [|(,,) $(pure statementE) $(pure argsE) True|])+        (THUtil.purify [|Bknd.Stmt $(pure statementE) $(pure argsE) True|])       where         argNames =            map (TH.mkName . ('_' :) . show) [1 .. n]         statementE =            TH.LitE (TH.StringL s)-        argsE = -          TH.ListE $ flip map argNames $ \x ->-            THUtil.purify-            [| Backend.renderValue $(TH.varE x) |]-        +        argsE =+          THUtil.vectorE $+          map (\x -> THUtil.purify [| Bknd.encodeValue $(TH.varE x) |]) $+          argNames

@@ -1,40 +1,44 @@ module Hasql.Prelude (    module Exports,-  bug,-  bottom, ) where   -- base-prelude --------------------------import BasePrelude as Exports+import BasePrelude as Exports hiding (left, right, isLeft, isRight)  -- transformers --------------------------import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch)-import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) import Control.Monad.Trans.Class as Exports import Control.Monad.IO.Class as Exports import Data.Functor.Identity as Exports --- mmorph+-- transformers-base --------------------------import Control.Monad.Morph as Exports+import Control.Monad.Base as Exports  -- monad-control ------------------------- import Control.Monad.Trans.Control as Exports hiding (embed, embed_) --- transformers-base+-- mtl --------------------------import Control.Monad.Base as Exports+import Control.Monad.Error.Class as Exports hiding (Error) --- safe+-- mmorph --------------------------import Safe as Exports+import Control.Monad.Morph as Exports +-- either+-------------------------+import Control.Monad.Trans.Either as Exports+import Data.Either.Combinators as Exports+ -- list-t ------------------------- import ListT as Exports (ListT)@@ -46,26 +50,3 @@ -- text ------------------------- import Data.Text as Exports (Text)---- bytestring---------------------------import Data.ByteString as Exports (ByteString)---- time---------------------------import Data.Time as Exports---- placeholders---------------------------import Development.Placeholders as Exports---- custom---------------------------import qualified Debug.Trace.LocationTH---bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]-  where-    msg = "A \"hasql\" package bug: " :: String--bottom = [e| $bug "Bottom evaluated" |]

@@ -2,37 +2,49 @@  import Hasql.Prelude hiding (takeWhile) import Data.Attoparsec.Text hiding (Result)-import qualified Data.Text as Text+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB   -- |--- The amount of placeholders.-type Result =-  (Word)--parse :: Text -> Either String Result+-- Produces a whitespace-cleaned text and a count of placeholders in it.+parse :: Text -> Either String (Text, Int) parse = -  parseOnly $ flip execStateT 0 $-    statement *>-    (lift endOfInput <|> -     (void (lift (char ';')) <* fail "A semicolon detected. Only single statements are allowed"))-  where-    statement =-      skipMany1 $ -        void (lift stringLit) <|> -        void (lift (char '?') <* modify succ) <|>-        void (lift (notChar ';'))+  parseOnly $ singleTemplate +singleTemplate :: Parser (Text, Int)+singleTemplate =+  template <* +  ((endOfInput) <|>+   (() <$ skipSpace <* char ';' <* fail "A semicolon detected. Only single statements are allowed"))++template :: Parser (Text, Int)+template =+  flip runStateT 0 $ do+    lift $ skipSpace+    fmap (TL.toStrict . TLB.toLazyText . mconcat) $ +      many $ +        (mempty <$ lift trailingWhitespace) <|>+        (TLB.singleton ' ' <$ lift (takeWhile1 isSpace)) <|>+        (TLB.fromText <$> lift stringLit) <|>+        (TLB.singleton <$> lift (char '?') <* modify succ) <|>+        (TLB.singleton <$> lift (notChar ';'))++trailingWhitespace :: Parser ()+trailingWhitespace =+  () <$ takeWhile1 isSpace <* endOfInput+ stringLit :: Parser Text stringLit =   do     quote <-        char '"' <|> char '\''-    text <- +    content <-        fmap mconcat $ many $ -        string "\\\\" <|> -        string (fromString ['\\', quote]) <|> -        (Text.singleton <$> notChar quote)+        TLB.fromText <$> string "\\\\" <|> +        TLB.fromText <$> string (fromString ['\\', quote]) <|> +        TLB.singleton <$> notChar quote     char quote-    return text-+    return $ TL.toStrict . TLB.toLazyText $+      TLB.singleton quote <> content <> TLB.singleton quote

@@ -2,23 +2,26 @@  import Hasql.Prelude import Language.Haskell.TH-import qualified Hasql.Backend as Backend+import qualified Hasql.Backend as Bknd import qualified Data.Vector as Vector import qualified Hasql.TH as THUtil  -class RowParser b r where-  parseRow :: Vector.Vector (Backend.Result b) -> Either Text r+-- |+-- This class is only intended to be used with the supplied instances,+-- which should be enough to cover all use cases.+class RowParser c r where+  parseRow :: Bknd.ResultRow c -> Either Text r -instance RowParser b () where+instance RowParser c () where   parseRow row =      if Vector.null row       then Right ()       else Left "Not an empty row" -instance Backend.Mapping b v => RowParser b (Identity v) where+instance Bknd.CxValue c v => RowParser c (Identity v) where   parseRow row = do-    Identity <$> Backend.parseResult (Vector.unsafeHead row)+    Identity <$> Bknd.decodeValue (Vector.unsafeHead row)  -- Generate tuple instaces using Template Haskell: return $ flip map [2 .. 24] $ \arity ->@@ -28,9 +31,9 @@     varTypes =       map VarT varNames     connectionType =-      VarT (mkName "b")+      VarT (mkName "c")     constraints =-      map (\t -> ClassP ''Backend.Mapping [connectionType, t]) varTypes+      map (\t -> ClassP ''Bknd.CxValue [connectionType, t]) varTypes     head =       AppT (AppT (ConT ''RowParser) connectionType) (foldl AppT (TupleT arity) varTypes)     parseRowDec =@@ -54,7 +57,7 @@               i <- [0 .. pred arity]               return $ THUtil.purify $                 [|-                  Backend.parseResult+                  Bknd.decodeValue                     (Vector.unsafeIndex $(varE rowVarName) $(litE (IntegerL $ fromIntegral i)) )                 |]     in InstanceD constraints head [parseRowDec]

@@ -4,6 +4,8 @@  import Hasql.Prelude import Language.Haskell.TH+import qualified Data.Vector as Vector+import qualified Data.Vector.Mutable as MVector   applicativeE :: Exp -> [Exp] -> Exp@@ -18,7 +20,54 @@           \case             e : o : t -> UInfixE e o (reduce t)             e : [] -> e-            _ -> $bug $ "Unexpected queue size. Exps: " <> show exps+            _ -> error $ "Unexpected queue size. Exps: " <> show exps  purify :: Q a -> a purify = unsafePerformIO . runQ++-- |+-- Produce a lambda expression of a given arity,+-- which efficiently constructs a vector of a size equal to the arity.+vectorLamE :: Int -> Exp+vectorLamE arity =+  LamE (map VarP argNames) body+  where+    argNames = +      map (mkName . ('_' :) . show) [1 .. arity]+    body =+      vectorE $ map VarE argNames++vectorE :: [Exp] -> Exp+vectorE cellExps =+  if null cellExps+    then+      VarE 'Vector.empty+    else+      AppE (VarE 'runST) $ DoE $ +        pure vectorDeclarationStmt <> cellAssignmentStmts <> pure freezingStmt+  where+    vectorVarName =+      mkName "v"+    vectorDeclarationStmt =+      (BindS +        (VarP vectorVarName) +        (AppE +          (VarE 'MVector.unsafeNew) +          (LitE (IntegerL (fromIntegral (length cellExps))))))+    cellAssignmentStmts =+      map (NoBindS . uncurry cellAssignmentExp) $ zip [0..] cellExps+      where+        cellAssignmentExp index exp =+          (AppE+            (AppE+              (AppE+                (VarE 'MVector.unsafeWrite)+                (VarE vectorVarName))+              (LitE (IntegerL (fromIntegral index))))+            (exp))+    freezingStmt =+      (NoBindS+        (AppE+          (VarE 'Vector.unsafeFreeze)+          (VarE vectorVarName)))+