From 81c9d9996cac9fcccec59fb85441688bb46735aa Mon Sep 17 00:00:00 2001
From: Nikita Volkov <nikita.y.volkov@mail.ru>
Date: Thu, 23 Oct 2014 20:04:11 +0400
Subject: [PATCH] Make the API Session-centric

---
 hasql.cabal              |  2 +
 library/Hasql.hs         | 89 ++++++++++++++++++++--------------------
 library/Hasql/Prelude.hs |  8 ++++
 3 files changed, 54 insertions(+), 45 deletions(-)

diff --git a/hasql.cabal b/hasql.cabal
index 0f9dcc3..9c48064 100644
--- a/hasql.cabal
+++ b/hasql.cabal
@@ -65,6 +65,8 @@ library
     loch-th == 0.2.*,
     placeholders == 0.1.*,
     -- general:
+    monad-control == 0.3.*,
+    transformers-base == 0.4.*,
     safe >= 0.3.8 && < 0.4,
     mmorph == 1.0.*,
     mtl-prelude == 2.*,
diff --git a/library/Hasql.hs b/library/Hasql.hs
index 7f7148b..f561c5e 100644
--- a/library/Hasql.hs
+++ b/library/Hasql.hs
@@ -1,22 +1,21 @@
 module Hasql
 (
-  -- * Connections Pool
-  Pool,
-  PoolSettings,
-  poolSettings,
-  acquirePool,
-  releasePool,
-
   -- * Session
   Session,
   sessionInner,
-  
+
+  -- * Error
+  Error(..),
+
   -- * Transaction
   Tx,
   Mode,
   Backend.IsolationLevel(..),
   txSession,
 
+  -- * Statement Quasi-Quoter
+  QQ.q,
+
   -- * Statement Execution
   StatementTx,
   unitTx,
@@ -24,17 +23,11 @@ module Hasql
   streamTx,
   cursorStreamTx,
 
-  -- * Statement Quasi-Quoter
-  QQ.q,
-
-  -- ** Error
-  Error(..),
-
-  -- ** Results Stream
+  -- * Results Stream
   TxStream,
   TxStreamT,
 
-  -- ** Row parser
+  -- * Row parser
   RowParser.RowParser(..),
 )
 where
@@ -49,6 +42,38 @@ import qualified ListT
 import qualified Data.Pool as Pool
 
 
+-- * Session
+-------------------------
+
+-- |
+-- A monad transformer,
+-- which executes transactions.
+type Session b =
+  ReaderT (Pool b)
+
+-- |
+-- Given backend settings, pool settings, and a session monad transformer 
+-- execute it in the inner monad.
+sessionInner :: 
+  Backend.Backend b => MonadBaseControl IO m =>
+  b -> PoolSettings -> Session b m r -> m r
+sessionInner backend settings reader =
+  join $ liftM restoreM $ liftBaseWith $ \runInIO ->
+    mask $ \unmask -> do
+      p <- acquirePool backend settings
+      r <- ($ releasePool p) $ onException $ unmask $ runInIO $ runReaderT reader p
+      releasePool p
+      return r
+
+-- |
+-- Execute a transaction in a session.
+txSession :: 
+  Backend.Backend b => MonadBase IO m =>
+  Mode -> (forall s. Tx b s r) -> Session b m r
+txSession m t =
+  ReaderT $ \p -> liftBase $ usePool (\c -> runTx c m t) p
+
+
 -- * Connections Pool
 -------------------------
 
@@ -102,22 +127,6 @@ usePool f (Pool p) =
   Pool.withResource p f
 
 
--- * Session
--------------------------
-
--- |
--- A session monad transformer, 
--- which is an adaptation of the 'ReaderT' API over the connections pool.
-type Session b =
-  ReaderT (Pool b)
-
--- |
--- Run the session monad transformer in the inner monad.
-sessionInner :: Pool b -> Session b m r -> m r
-sessionInner pool reader =
-  runReaderT reader pool
-
-
 -- * Transaction
 -------------------------
 
@@ -142,12 +151,10 @@ newtype Tx b s r =
 type Mode =
   Maybe (Backend.IsolationLevel, Bool)
 
--- |
--- Execute a transaction on a connection.
-txIO ::
+runTx ::
   Backend b => 
   Backend.Connection b -> Mode -> (forall s. Tx b s r) -> IO r
-txIO connection mode (Tx reader) =
+runTx connection mode (Tx reader) =
   handle backendHandler $ 
     maybe (const id) inTransaction mode connection (runReaderT reader connection)
   where
@@ -173,14 +180,6 @@ txIO connection mode (Tx reader) =
         Backend.UnexpectedResultStructure t -> throwIO $ UnexpectedResultStructure t
         Backend.TransactionConflict -> $bug "Unexpected TransactionConflict exception"
 
--- |
--- Execute a transaction in a session.
-txSession :: 
-  Backend.Backend b => MonadIO m =>
-  Mode -> (forall s. Tx b s r) -> Session b m r
-txSession m t =
-  ReaderT $ \p -> liftIO $ usePool (\c -> txIO c m t) p
-
 
 -- * Results Stream
 -------------------------
@@ -236,7 +235,7 @@ data Error =
 instance Exception Error
 
 
--- * Transactions
+-- * Statements execution
 -------------------------
 
 -- |
diff --git a/library/Hasql/Prelude.hs b/library/Hasql/Prelude.hs
index a1a9990..2b36edd 100644
--- a/library/Hasql/Prelude.hs
+++ b/library/Hasql/Prelude.hs
@@ -19,6 +19,14 @@ import MTLPrelude as Exports hiding (shift)
 -------------------------
 import Control.Monad.Morph as Exports
 
+-- monad-control
+-------------------------
+import Control.Monad.Trans.Control as Exports
+
+-- transformers-base
+-------------------------
+import Control.Monad.Base as Exports
+
 -- safe
 -------------------------
 import Safe as Exports