nikita-volkov/hasql
1
1
Fork 0
mirror of https://github.com/nikita-volkov/hasql.git synced 2024-11-22 10:05:27 +03:00
Code Issues Projects Releases Wiki Activity

Deep isolation

Browse Source
This commit is contained in:
Nikita Volkov 2015-11-22 10:10:21 +03:00
parent 1ab1bd1e38
commit 93805d4a73
9 changed files with 113 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
benchmark/Main.hs
View File

@ -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

10
benchmark/Main/Queries.hs
View File

@ -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 " <>

10
hasql.cabal
View File

@ -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,

12
library/Hasql/Connection.hs Normal file
View File

@ -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

37
library/Hasql/Connection/Impl.hs Normal file
View File

@ -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

52
library/Hasql.hs → library/Hasql/Query.hs
View File

@ -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

36
tasty/Main.hs
View File

@ -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

20
tasty/Main/DSL.hs
View File

@ -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

18
tasty/Main/Queries.hs
View File

@ -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)"