Reintroduce Session and fix Demo

CHANGELOG.md

@@ -1,14 +1,16 @@
 # 0.6.0 - Major API overhaul
-* Removed the `Session` monad, opening a direct access to the connection pool, thus providing for a simpler compatibility with other libraries.
+* 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 uncommitable transactions with the `TxWriteMode` type.
+* The transaction mode is now extended to support uncommittable transactions with the `TxWriteMode` type.
 * `Tx` now has a `MonadError` instance, which allows to handle errors while remaining in the transaction.
-* All `Tx` functions now have a "Tx" suffix.
-* There is no more `list` transaction. Instead there is `vectorTx`. 
+* All `Tx` functions are now appended with a "Tx" suffix.
+* There is no `list` transaction any more. Instead there is `vectorTx`. 
 * 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

demo/Main.hs

@@ -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 @@ main = do
 
   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.q|DROP TABLE IF EXISTS a|]
+      H.unitTx [H.q|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.q|INSERT INTO a (balance) VALUES (0)|]
 
     -- Declare a list of transfer settings, which we'll later use.
     -- The tuple structure is: 
@@ -45,24 +51,27 @@ main = do
     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.q|SELECT balance FROM a WHERE id=?|] id1
+          Identity balance2 <- MaybeT $ H.maybeTx $ [H.q|SELECT balance FROM a WHERE id=?|] id2
+          lift $ H.unitTx $ [H.q|UPDATE a SET balance=? WHERE id=?|] (balance1 - amount) id1
+          lift $ H.unitTx $ [H.q|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.q|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
+
 
 
 

hasql.cabal

@@ -109,6 +109,8 @@ library
     list-t >= 0.3.1 && < 0.5,
     mmorph == 1.0.*,
     mtl >= 2.1 && < 2.3,
+    monad-control >= 0.3 && < 1.1,
+    transformers-base == 0.4.*,
     transformers >= 0.3 && < 0.5,
     base-prelude >= 0.1.3 && < 0.2,
     base >= 4.5 && < 4.8

hspec-postgres/Main.hs

@@ -17,7 +17,7 @@ main =
       context "Unhandled transaction conflict" $ do
 
         it "should not be" $ do
-          session $ tx Nothing $ do
+          session $ H.tx Nothing $ do
             H.unitTx [H.q|DROP TABLE IF EXISTS artist|]
             H.unitTx [H.q|DROP TABLE IF EXISTS artist_union|]
             H.unitTx $
@@ -60,7 +60,7 @@ main =
             process = 
                 SlaveThread.fork $ do
                   session $ replicateM_ 100 $ do 
-                    tx (Just (H.Serializable, Just True)) $ do
+                    H.tx (Just (H.Serializable, Just True)) $ do
                       unionID <- insertArtistUnion
                       insertArtist unionID ["a", "b", "c"]
                   signal
@@ -72,7 +72,7 @@ main =
       it "should fail on incorrect arity" $ do
         flip shouldSatisfy (\case Left (H.UnparsableResult _) -> True; _ -> False) =<< do
           session $ do
-            tx Nothing $ do
+            H.tx Nothing $ do
               H.unitTx [H.q|DROP TABLE IF EXISTS data|]
               H.unitTx [H.q|CREATE TABLE data (
                               field1    DECIMAL NOT NULL,
@@ -81,7 +81,7 @@ main =
                           )|]
               H.unitTx [H.q|INSERT INTO data (field1, field2) VALUES (0, 0)|]
             mrow :: Maybe (Double, Int64, String) <- 
-              tx Nothing $  
+              H.tx Nothing $  
                 H.maybeTx $ [H.q|SELECT * FROM data|]
             return ()
 
@@ -102,22 +102,14 @@ newBatchGate amount =
 -- * Hasql utils
 -------------------------
 
-newtype HSession m r =
-  HSession (ReaderT (H.Pool HP.Postgres) (EitherT (H.TxError HP.Postgres) m) r)
-  deriving (Functor, Applicative, Monad, MonadIO)
+type Session m =
+  H.Session HP.Postgres m
 
-instance MonadTrans HSession where
-  lift = HSession . lift . lift
-
-tx :: MonadIO m => H.TxMode -> (forall s. H.Tx HP.Postgres s a) -> HSession m a
-tx mode m =
-  HSession $ ReaderT $ \p -> EitherT $ liftIO $ H.tx p mode m
-
-session :: MonadBaseControl IO m => HSession m r -> m (Either (H.TxError HP.Postgres) r)
-session (HSession m) =
+session :: MonadBaseControl IO m => Session m r -> m (Either (H.TxError HP.Postgres) r)
+session m =
   control $ \unlift -> do
     p <- H.acquirePool backendSettings poolSettings
-    r <- unlift $ runEitherT $ runReaderT m p
+    r <- unlift $ H.session p m
     H.releasePool p
     return r
   where

library/Hasql.hs

@@ -19,6 +19,10 @@ module Hasql
   PoolSettings,
   poolSettings,
 
+  -- * Session
+  Session,
+  session,
+
   -- * Statement
   Bknd.Stmt,
   q,
@@ -75,6 +79,16 @@ newtype Pool c =
 -- Given backend-specific connection settings and pool settings, 
 -- acquire a backend connection pool,
 -- which can then be used to work with the DB.
+-- 
+-- When combining Hasql with other libraries, 
+-- which throw exceptions it makes sence to utilize 
+-- @Control.Exception.'bracket'@
+-- like this:
+-- 
+-- >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 $
@@ -122,6 +136,26 @@ poolSettings size timeout =
     else Nothing
 
 
+-- * Session
+-------------------------
+
+-- |
+-- A convenience wrapper around 'ReaderT', 
+-- which provides a shared context for execution of transactions.
+type Session c m =
+  ReaderT (Pool c) (EitherT (TxError c) 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 (TxError c) a)
+session pool m =
+  runEitherT $ flip runReaderT pool $ m
+
+
 -- * Transaction
 -------------------------
 
@@ -159,19 +193,19 @@ deriving instance (Show (Bknd.CxError c), Show (Bknd.TxError c)) => Show (TxErro
 deriving instance (Eq (Bknd.CxError c), Eq (Bknd.TxError c)) => Eq (TxError c)
 
 -- |
--- Execute a transaction on a connection pool.
+-- 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 => Pool c -> Bknd.TxMode -> (forall s. Tx c s r) -> IO (Either (TxError c) r)
-tx (Pool pool) mode (Tx m) =
-  Pool.withResource pool $ \e ->
-    runEitherT $ do
+tx :: (Bknd.CxTx c, MonadBaseControl IO m) => Bknd.TxMode -> (forall s. Tx c s r) -> Session c m r
+tx mode (Tx m) =
+  ReaderT $ \(Pool pool) ->
+    Pool.withResource pool $ \e -> do
       c <- hoistEither $ mapLeft BackendCxError e
       let
         attempt =
           do
-            r <- EitherT $ fmap (either (Left . BackendTxError) Right) $ 
+            r <- EitherT $ liftBase $ fmap (either (Left . BackendTxError) Right) $ 
                  Bknd.runTx c mode $ runEitherT m
             maybe attempt hoistEither r
         in attempt

library/Hasql/Prelude.hs

@@ -17,6 +17,14 @@ import Control.Monad.Trans.Class as Exports
 import Control.Monad.IO.Class as Exports
 import Data.Functor.Identity as Exports
 
+-- transformers-base
+-------------------------
+import Control.Monad.Base as Exports
+
+-- monad-control
+-------------------------
+import Control.Monad.Trans.Control as Exports hiding (embed, embed_)
+
 -- mtl
 -------------------------
 import Control.Monad.Error.Class as Exports