Deep isolation

benchmark/Main.hs

@@ -2,17 +2,19 @@ module Main where
 
 import Main.Prelude
 import Criterion.Main
-import qualified Hasql as H
+import qualified Hasql.Connection as HC
+import qualified Hasql.Settings as HS
+import qualified Hasql.Query as HQ
 import qualified Hasql.Encoding as HE
 import qualified Hasql.Decoding as HD
 import qualified Main.Queries as Q
 
 
 main =
-  H.connect settings >>= either (fail . show) use
+  HC.connect settings >>= either (fail . show) use
   where
     settings =
-      H.settings host port user password database
+      HS.settings host port user password database
       where
         host = "localhost"
         port = 5432
@@ -44,7 +46,7 @@ main =
         ]
       ]
       where
-        query :: a -> H.Query a b -> IO b
+        query :: a -> HQ.Query a b -> IO b
         query params query =
           {-# SCC "query" #-} 
-          H.query connection query params >>= either (fail . show) pure
+          HQ.run query params connection >>= either (fail . show) pure

benchmark/Main/Queries.hs

@@ -1,15 +1,15 @@
 module Main.Queries where
 
 import Main.Prelude
-import qualified Hasql as H
+import qualified Hasql.Query as HQ
 import qualified Hasql.Encoding as HE
 import qualified Hasql.Decoding as HD
 
 
-select1 :: Int -> H.Query () (Vector Int64)
+select1 :: Int -> HQ.Query () (Vector Int64)
 select1 amount =
   {-# SCC "select1" #-} 
-  H.Query sql mempty decoder True
+  HQ.Query sql mempty decoder True
   where
     !sql =
       "values " <>
@@ -17,10 +17,10 @@ select1 amount =
     decoder =
       HD.rowsVector (HD.value HD.int8)
 
-select4 :: Int -> H.Query () (Vector (Int64, Int64, Int64, Int64))
+select4 :: Int -> HQ.Query () (Vector (Int64, Int64, Int64, Int64))
 select4 amount =
   {-# SCC "select4" #-} 
-  H.Query sql mempty decoder True
+  HQ.Query sql mempty decoder True
   where
     !sql =
       "values " <>

hasql.cabal

@@ -1,13 +1,15 @@
 name:
   hasql
 version:
-  0.12.1.1
+  0.13
 category:
   Hasql, Database, PostgreSQL
 synopsis:
   A very efficient PostgreSQL driver and a flexible mapping API
 description:
   This package is the root of the \"hasql\" ecosystem.
+  .
+  The API is completely disinfected from exceptions. All error-reporting is explicit and is presented using the 'Either' type.
 homepage:
   https://github.com/nikita-volkov/hasql 
 bug-reports:
@@ -47,7 +49,6 @@ library
     Hasql.Prelude
     Hasql.PTI
     Hasql.IO
-    Hasql.Settings
     Hasql.Commands
     Hasql.Decoding.Array
     Hasql.Decoding.Composite
@@ -59,10 +60,13 @@ library
     Hasql.Encoding.Value
     Hasql.Encoding.Params
     Hasql.PreparedStatementRegistry
+    Hasql.Connection.Impl
   exposed-modules:
     Hasql.Decoding
     Hasql.Encoding
-    Hasql
+    Hasql.Settings
+    Hasql.Connection
+    Hasql.Query
   build-depends:
     -- parsing:
     attoparsec >= 0.10 && < 0.14,

library/Hasql/Connection.hs

@@ -0,0 +1,12 @@
+-- |
+-- This module provides a low-level effectful API dealing with the connections to the database.
+module Hasql.Connection
+(
+  Connection,
+  ConnectionError(..),
+  connect,
+  disconnect,
+)
+where
+
+import Hasql.Connection.Impl

library/Hasql/Connection/Impl.hs

@@ -0,0 +1,37 @@
+module Hasql.Connection.Impl
+where
+
+import Hasql.Prelude
+import qualified Database.PostgreSQL.LibPQ as LibPQ
+import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry
+import qualified Hasql.IO as IO
+
+
+-- |
+-- A single connection to the database.
+data Connection =
+  Connection !LibPQ.Connection !Bool !PreparedStatementRegistry.PreparedStatementRegistry
+
+-- |
+-- Possible details of the connection acquistion error.
+type ConnectionError =
+  Maybe ByteString
+
+-- |
+-- Acquire a connection using the provided settings.
+connect :: ByteString -> IO (Either ConnectionError Connection)
+connect settings =
+  {-# SCC "connect" #-} 
+  runEitherT $ do
+    pqConnection <- lift (IO.acquireConnection settings)
+    lift (IO.checkConnectionStatus pqConnection) >>= traverse left
+    lift (IO.initConnection pqConnection)
+    integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection)
+    registry <- lift (IO.acquirePreparedStatementRegistry)
+    pure (Connection pqConnection integerDatetimes registry)
+
+-- |
+-- Release the connection.
+disconnect :: Connection -> IO ()
+disconnect (Connection pqConnection _ _) =
+  LibPQ.finish pqConnection

library/Hasql/Query.hs

@@ -1,23 +1,13 @@
 -- |
 -- This module provides a low-level effectful API dealing with connections to the database.
--- 
--- The API is completely disinfected from exceptions. All error-reporting is explicit and is presented using the 'Either' type.
-module Hasql
+module Hasql.Query
 (
-  -- * Connection settings
-  Settings.Settings(..),
-  Settings.settings,
-  -- * Connection
-  Connection,
-  ConnectionError(..),
-  connect,
-  disconnect,
-  -- * Query
   Query(..),
+  -- * Execution
   ResultsError(..),
   ResultError(..),
   RowError(..),
-  query,
+  run,
 )
 where
 
@@ -30,13 +20,9 @@ import qualified Hasql.Encoding.Params as ParamsEncoding
 import qualified Hasql.Encoding as Encoding
 import qualified Hasql.Settings as Settings
 import qualified Hasql.IO as IO
+import qualified Hasql.Connection.Impl as Connection
 
 
--- |
--- A single connection to the database.
-data Connection =
-  Connection !LibPQ.Connection !Bool !PreparedStatementRegistry.PreparedStatementRegistry
-
 -- |
 -- An error of the result-decoder.
 data ResultsError =
@@ -103,30 +89,6 @@ data RowError =
   ValueError !Text
   deriving (Show, Eq)
 
--- |
--- Possible details of the connection acquistion error.
-type ConnectionError =
-  Maybe ByteString
-
--- |
--- Acquire a connection using the provided settings.
-connect :: Settings.Settings -> IO (Either ConnectionError Connection)
-connect settings =
-  {-# SCC "connect" #-} 
-  runEitherT $ do
-    pqConnection <- lift (IO.acquireConnection settings)
-    lift (IO.checkConnectionStatus pqConnection) >>= traverse left
-    lift (IO.initConnection pqConnection)
-    integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection)
-    registry <- lift (IO.acquirePreparedStatementRegistry)
-    pure (Connection pqConnection integerDatetimes registry)
-
--- |
--- Release the connection.
-disconnect :: Connection -> IO ()
-disconnect (Connection pqConnection _ _) =
-  LibPQ.finish pqConnection
-
 
 -- |
 -- A specification of a strictly single-statement query, which can be parameterized and prepared.
@@ -180,9 +142,9 @@ instance Profunctor Query where
     Query p1 (contramap f1 p2) (fmap f2 p3) p4
 
 -- |
--- Execute a parametric query, producing either a deserialization failure or a successful result.
-query :: Connection -> Query a b -> a -> IO (Either ResultsError b)
-query (Connection pqConnection integerDatetimes registry) (Query template encoder decoder preparable) params =
+-- Execute the query, producing either a deserialization failure or a successful result.
+run :: Query a b -> a -> Connection.Connection -> IO (Either ResultsError b)
+run (Query template encoder decoder preparable) params (Connection.Connection pqConnection integerDatetimes registry) =
   {-# SCC "query" #-} 
   fmap (mapLeft coerceResultsError) $ runEitherT $ do
     EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceEncoder encoder) preparable params

tasty/Main.hs

@@ -9,9 +9,9 @@ import qualified Test.Tasty.SmallCheck as SmallCheck
 import qualified Test.Tasty.QuickCheck as QuickCheck
 import qualified Test.QuickCheck as QuickCheck
 import qualified Main.DSL as DSL
-import qualified Hasql as H
-import qualified Hasql.Encoding as HE
-import qualified Hasql.Decoding as HD
+import qualified Hasql.Query as Query
+import qualified Hasql.Encoding as Encoding
+import qualified Hasql.Decoding as Decoding
 
 main =
   defaultMain tree
@@ -27,28 +27,28 @@ tree =
         DSL.session $ do
           let
             query =
-              H.Query sql mempty HD.unit True
+              Query.Query sql mempty Decoding.unit True
               where
                 sql =
                   "drop type if exists mood"
             in DSL.query () query
           let
             query =
-              H.Query sql mempty HD.unit True
+              Query.Query sql mempty Decoding.unit True
               where
                 sql =
                   "create type mood as enum ('sad', 'ok', 'happy')"
             in DSL.query () query
           let
             query =
-              H.Query sql encoder decoder True
+              Query.Query sql encoder decoder True
               where
                 sql =
                   "select ($1 :: mood)"
                 decoder =
-                  (HD.singleRow (HD.value (HD.enum (Just . id))))
+                  (Decoding.singleRow (Decoding.value (Decoding.enum (Just . id))))
                 encoder =
-                  HE.value (HE.enum id)
+                  Encoding.value (Encoding.enum id)
             in DSL.query "ok" query
       in actual
     ,
@@ -63,26 +63,26 @@ tree =
               DSL.query "ok" query
               where
                 query =
-                  H.Query sql encoder decoder True
+                  Query.Query sql encoder decoder True
                   where
                     sql =
                       "select $1"
                     encoder =
-                      HE.value HE.text
+                      Encoding.value Encoding.text
                     decoder =
-                      (HD.singleRow (HD.value (HD.text)))
+                      (Decoding.singleRow (Decoding.value (Decoding.text)))
             effect2 =
               DSL.query 1 query
               where
                 query =
-                  H.Query sql encoder decoder True
+                  Query.Query sql encoder decoder True
                   where
                     sql =
                       "select $1"
                     encoder =
-                      HE.value HE.int8
+                      Encoding.value Encoding.int8
                     decoder =
-                      (HD.singleRow (HD.value HD.int8))
+                      (Decoding.singleRow (Decoding.value Decoding.int8))
             in (,) <$> effect1 <*> effect2
       in actual
     ,
@@ -107,12 +107,12 @@ tree =
             DSL.query () $ Queries.plain $
             "insert into a (name) values ('a')"  
           deleteRows =
-            DSL.query () $ H.Query sql def decoder False
+            DSL.query () $ Query.Query sql def decoder False
             where
               sql =
                 "delete from a"
               decoder =
-                HD.rowsAffected
+                Decoding.rowsAffected
       in actual
     ,
     HUnit.testCase "Result of an auto-incremented column" $
@@ -121,8 +121,8 @@ tree =
         DSL.session $ do
           DSL.query () $ Queries.plain $ "drop table if exists a"
           DSL.query () $ Queries.plain $ "create table a (id serial not null, v char not null, primary key (id))"
-          id1 <- DSL.query () $ H.Query "insert into a (v) values ('a') returning id" def (HD.singleRow (HD.value HD.int4)) False
-          id2 <- DSL.query () $ H.Query "insert into a (v) values ('b') returning id" def (HD.singleRow (HD.value HD.int4)) False
+          id1 <- DSL.query () $ Query.Query "insert into a (v) values ('a') returning id" def (Decoding.singleRow (Decoding.value Decoding.int4)) False
+          id2 <- DSL.query () $ Query.Query "insert into a (v) values ('b') returning id" def (Decoding.singleRow (Decoding.value Decoding.int4)) False
           DSL.query () $ Queries.plain $ "drop table if exists a"
           pure (id1, id2)
       in HUnit.assertEqual "" (Right (1, 2)) =<< actualIO

tasty/Main/DSL.hs

@@ -1,18 +1,20 @@
 module Main.DSL where
 
 import Main.Prelude
-import qualified Hasql as H
+import qualified Hasql.Connection as HC
+import qualified Hasql.Query as HQ
+import qualified Hasql.Settings as HS
 import qualified Hasql.Encoding as HE
 import qualified Hasql.Decoding as HD
 
 
 newtype Session a =
-  Session (ReaderT H.Connection (EitherT H.ResultsError IO) a)
+  Session (ReaderT HC.Connection (EitherT HQ.ResultsError IO) a)
   deriving (Functor, Applicative, Monad, MonadIO)
 
 data SessionError =
-  ConnectionError (H.ConnectionError) |
-  ResultsError (H.ResultsError)
+  ConnectionError (HC.ConnectionError) |
+  ResultsError (HQ.ResultsError)
   deriving (Show, Eq)
 
 session :: Session a -> IO (Either SessionError a)
@@ -20,10 +22,10 @@ session (Session impl) =
   runEitherT $ acquire >>= \connection -> use connection <* release connection
   where
     acquire =
-      EitherT $ fmap (mapLeft ConnectionError) $ H.connect settings
+      EitherT $ fmap (mapLeft ConnectionError) $ HC.connect settings
       where
         settings =
-          H.settings host port user password database
+          HS.settings host port user password database
           where
             host = "localhost"
             port = 5432
@@ -34,8 +36,8 @@ session (Session impl) =
       bimapEitherT ResultsError id $
       runReaderT impl connection
     release connection =
-      lift $ H.disconnect connection
+      lift $ HC.disconnect connection
 
-query :: a -> H.Query a b -> Session b
+query :: a -> HQ.Query a b -> Session b
 query params query =
-  Session $ ReaderT $ \connection -> EitherT $ H.query connection query params
+  Session $ ReaderT $ EitherT . HQ.run query params

tasty/Main/Queries.hs

@@ -1,34 +1,34 @@
 module Main.Queries where
 
 import Main.Prelude hiding (def)
-import qualified Hasql as H
+import qualified Hasql.Query as HQ
 import qualified Hasql.Encoding as HE
 import qualified Hasql.Decoding as HD
 import qualified Main.Prelude as Prelude
 
 
-def :: ByteString -> H.Query () ()
+def :: ByteString -> HQ.Query () ()
 def sql =
-  H.Query sql Prelude.def Prelude.def False
+  HQ.Query sql Prelude.def Prelude.def False
 
-plain :: ByteString -> H.Query () ()
+plain :: ByteString -> HQ.Query () ()
 plain sql =
-  H.Query sql mempty HD.unit False
+  HQ.Query sql mempty HD.unit False
 
-dropType :: ByteString -> H.Query () ()
+dropType :: ByteString -> HQ.Query () ()
 dropType name =
   plain $
     "drop type if exists " <> name
 
-createEnum :: ByteString -> [ByteString] -> H.Query () ()
+createEnum :: ByteString -> [ByteString] -> HQ.Query () ()
 createEnum name values =
   plain $
     "create type " <> name <> " as enum (" <> 
     mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values)) <> ")"
 
-selectList :: H.Query () ([] (Int64, Int64))
+selectList :: HQ.Query () ([] (Int64, Int64))
 selectList =
-  H.Query sql mempty decoder True
+  HQ.Query sql mempty decoder True
   where
     sql =
       "values (1,2), (3,4), (5,6)"