mirror of
https://github.com/nikita-volkov/hasql.git
synced 2024-11-25 17:26:28 +03:00
A complete overhaul
This commit is contained in:
Nikita Volkov
parent
1dfed9be76
commit
39970138fa
12
CHANGELOG.md
12
CHANGELOG.md
@ -1,3 +1,15 @@
|
||||
# 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 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.
|
||||
* `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`.
|
||||
* 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.
|
||||
|
||||
# 0.5.0
|
||||
* Update the "list-t" and "monad-control" deps
|
||||
|
||||
|
||||
42
hasql.cabal
42
hasql.cabal
@ -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 @@ description:
|
||||
.
|
||||
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 @@ description:
|
||||
* 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,27 +94,21 @@ library
|
||||
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.*,
|
||||
monad-control == 1.0.*,
|
||||
transformers-base == 0.4.*,
|
||||
mtl >= 2.1 && < 2.3,
|
||||
transformers >= 0.3 && < 0.5,
|
||||
base-prelude >= 0.1.3 && < 0.2,
|
||||
base >= 4.5 && < 4.8
|
||||
@ -138,10 +132,12 @@ test-suite hspec
|
||||
build-depends:
|
||||
--
|
||||
hasql,
|
||||
hasql-backend == 0.2.*,
|
||||
hasql-backend,
|
||||
--
|
||||
hspec == 2.1.*,
|
||||
--
|
||||
vector,
|
||||
--
|
||||
mtl-prelude < 3,
|
||||
base-prelude,
|
||||
base
|
||||
@ -165,7 +161,7 @@ test-suite hspec-postgres
|
||||
build-depends:
|
||||
--
|
||||
hasql,
|
||||
hasql-postgres == 0.9.*,
|
||||
hasql-postgres == 0.10.*,
|
||||
--
|
||||
slave-thread == 0.1.*,
|
||||
--
|
||||
@ -173,6 +169,8 @@ test-suite hspec-postgres
|
||||
--
|
||||
text,
|
||||
--
|
||||
monad-control,
|
||||
either,
|
||||
mtl-prelude < 3,
|
||||
base-prelude,
|
||||
base
|
||||
@ -197,7 +195,7 @@ benchmark demo
|
||||
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
|
||||
@ -15,17 +17,17 @@ main =
|
||||
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 $
|
||||
session $ tx Nothing $ do
|
||||
H.unitTx [H.q|DROP TABLE IF EXISTS artist|]
|
||||
H.unitTx [H.q|DROP TABLE IF EXISTS artist_union|]
|
||||
H.unitTx $
|
||||
[H.q|
|
||||
CREATE TABLE "artist_union" (
|
||||
"id" BIGSERIAL,
|
||||
PRIMARY KEY ("id")
|
||||
)
|
||||
|]
|
||||
H.unit $
|
||||
H.unitTx $
|
||||
[H.q|
|
||||
CREATE TABLE "artist" (
|
||||
"id" BIGSERIAL,
|
||||
@ -39,13 +41,13 @@ main =
|
||||
let
|
||||
insertArtistUnion :: H.Tx HP.Postgres s Int64
|
||||
insertArtistUnion =
|
||||
fmap (runIdentity . fromJust) $ H.single $
|
||||
fmap (runIdentity . fromJust) $ H.maybeTx $
|
||||
[H.q|
|
||||
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 $
|
||||
fmap (runIdentity . fromJust) $ H.maybeTx $
|
||||
[H.q|
|
||||
INSERT INTO artist
|
||||
(artist_union_id,
|
||||
@ -58,7 +60,7 @@ main =
|
||||
process =
|
||||
SlaveThread.fork $ do
|
||||
session $ replicateM_ 100 $ do
|
||||
H.tx (Just (H.Serializable, True)) $ do
|
||||
tx (Just (H.Serializable, Just True)) $ do
|
||||
unionID <- insertArtistUnion
|
||||
insertArtist unionID ["a", "b", "c"]
|
||||
signal
|
||||
@ -68,32 +70,25 @@ main =
|
||||
context "RowParser" $ do
|
||||
|
||||
it "should fail on incorrect arity" $ do
|
||||
flip shouldThrow (\case H.UnparsableRow _ -> True; _ -> False) $
|
||||
flip shouldSatisfy (\case Left (H.UnparsableResult _) -> 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 (
|
||||
tx Nothing $ do
|
||||
H.unitTx [H.q|DROP TABLE IF EXISTS data|]
|
||||
H.unitTx [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.q|INSERT INTO data (field1, field2) VALUES (0, 0)|]
|
||||
mrow :: Maybe (Double, Int64, String) <-
|
||||
H.tx Nothing $
|
||||
H.single $ [H.q|SELECT * FROM data|]
|
||||
tx Nothing $
|
||||
H.maybeTx $ [H.q|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 +97,29 @@ newBatchGate amount =
|
||||
let signal = atomically $ readTVar counter >>= writeTVar counter . pred
|
||||
block = atomically $ readTVar counter >>= \x -> when (x > 0) retry
|
||||
in (signal, block)
|
||||
|
||||
|
||||
-- * Hasql utils
|
||||
-------------------------
|
||||
|
||||
newtype HSession m r =
|
||||
HSession (ReaderT (H.Pool HP.Postgres) (EitherT (H.TxError HP.Postgres) m) r)
|
||||
deriving (Functor, Applicative, Monad, MonadIO)
|
||||
|
||||
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) =
|
||||
control $ \unlift -> do
|
||||
p <- H.acquirePool backendSettings poolSettings
|
||||
r <- unlift $ runEitherT $ runReaderT m p
|
||||
H.releasePool p
|
||||
return r
|
||||
where
|
||||
backendSettings = HP.ParamSettings "localhost" 5432 "postgres" "" "postgres"
|
||||
poolSettings = fromJust $ H.poolSettings 6 30
|
||||
|
||||
@ -2,21 +2,25 @@ import BasePrelude
|
||||
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.q| SELECT (? + ?) |] 'a' 'b' :: HB.Stmt X)
|
||||
|
||||
431
library/Hasql.hs
431
library/Hasql.hs
@ -4,265 +4,236 @@
|
||||
-- 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
|
||||
(
|
||||
-- * Session
|
||||
Session,
|
||||
session,
|
||||
sessionUnlifter,
|
||||
-- * Pool
|
||||
Pool,
|
||||
acquirePool,
|
||||
releasePool,
|
||||
|
||||
-- ** Session Settings
|
||||
SessionSettings,
|
||||
sessionSettings,
|
||||
-- ** Pool Settings
|
||||
PoolSettings,
|
||||
poolSettings,
|
||||
|
||||
-- * Statement
|
||||
Bknd.Stmt,
|
||||
q,
|
||||
|
||||
-- ** Statement Execution
|
||||
unitTx,
|
||||
countTx,
|
||||
maybeTx,
|
||||
vectorTx,
|
||||
streamTx,
|
||||
|
||||
-- * Transaction
|
||||
Tx,
|
||||
tx,
|
||||
|
||||
-- ** Transaction Settings
|
||||
Mode,
|
||||
Backend.IsolationLevel(..),
|
||||
Bknd.TxMode(..),
|
||||
Bknd.TxIsolationLevel(..),
|
||||
Bknd.TxWriteMode(..),
|
||||
|
||||
-- * Statement Quasi-Quoter
|
||||
q,
|
||||
-- ** Transaction Error
|
||||
TxError(..),
|
||||
|
||||
-- * Statement Execution
|
||||
unit,
|
||||
count,
|
||||
single,
|
||||
list,
|
||||
stream,
|
||||
|
||||
-- * 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.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
|
||||
|
||||
-- A connection pool.
|
||||
newtype Pool c =
|
||||
Pool (Pool.Pool (Either (Bknd.CxError c) c))
|
||||
|
||||
-- |
|
||||
-- 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
|
||||
-- Given backend-specific connection settings and pool settings,
|
||||
-- acquire a backend connection pool,
|
||||
-- which can then be used to work with the DB.
|
||||
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)
|
||||
|
||||
-- |
|
||||
-- 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.
|
||||
--
|
||||
-- This function has the following property:
|
||||
--
|
||||
-- > (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
|
||||
|
||||
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
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
-- 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 |
|
||||
-- |
|
||||
-- Incorrect statement template.
|
||||
UnparsableTemplate Text |
|
||||
-- |
|
||||
-- An operation,
|
||||
-- which requires a database transaction was executed without one.
|
||||
NotInTransaction |
|
||||
-- |
|
||||
-- Attempt to parse a row into an incompatible type.
|
||||
-- Indicates either a mismatching schema or an incorrect query.
|
||||
UnparsableRow Text
|
||||
deriving (Show, Typeable, Eq, Ord)
|
||||
|
||||
instance Exception Error
|
||||
|
||||
|
||||
-- * Transaction
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
-- A transaction specialized for a backend @b@,
|
||||
-- associated with its intermediate results using an anonymous type-argument @s@ (same as in 'ST')
|
||||
-- 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@.
|
||||
newtype Tx b s r =
|
||||
Tx (ReaderT (Backend.Connection b) IO r)
|
||||
deriving (Functor, Applicative, Monad)
|
||||
--
|
||||
-- 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 (EitherT (TxError c) (Bknd.Tx c) r)
|
||||
deriving (Functor, Applicative, Monad, MonadError (TxError c))
|
||||
|
||||
data TxError c =
|
||||
-- |
|
||||
-- A backend-specific connection acquisition error.
|
||||
-- E.g., a failure to establish a connection.
|
||||
BackendCxError (Bknd.CxError c) |
|
||||
-- |
|
||||
-- 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.
|
||||
BackendTxError (Bknd.TxError c) |
|
||||
-- |
|
||||
-- Attempt to parse a result into an incompatible type.
|
||||
-- Indicates either a mismatching schema or an incorrect query.
|
||||
UnparsableResult Text
|
||||
|
||||
deriving instance (Show (Bknd.CxError c), Show (Bknd.TxError c)) => Show (TxError c)
|
||||
deriving instance (Eq (Bknd.CxError c), Eq (Bknd.TxError c)) => Eq (TxError c)
|
||||
|
||||
-- |
|
||||
-- A transaction mode defining how a transaction should be executed.
|
||||
--
|
||||
-- * @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.
|
||||
--
|
||||
-- * @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)
|
||||
|
||||
-- |
|
||||
-- Execute a transaction in a session.
|
||||
-- Execute a transaction on a connection pool.
|
||||
--
|
||||
-- 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 =
|
||||
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
|
||||
c <- hoistEither $ mapLeft BackendCxError e
|
||||
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
|
||||
attempt =
|
||||
do
|
||||
r <- EitherT $ fmap (either (Left . BackendTxError) Right) $
|
||||
Bknd.runTx c mode $ runEitherT m
|
||||
maybe attempt hoistEither r
|
||||
in attempt
|
||||
|
||||
|
||||
-- * Results Stream
|
||||
-- * Statements execution
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
-- Execute a statement without processing the result.
|
||||
unitTx :: Bknd.Stmt c -> Tx c s ()
|
||||
unitTx =
|
||||
Tx . lift . Bknd.unitTx
|
||||
|
||||
-- |
|
||||
-- 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 a single result row.
|
||||
-- E.g.,
|
||||
-- a @SELECT@
|
||||
-- or an @INSERT@, which produces a generated value (e.g., an auto-incremented id),
|
||||
-- or an @UPDATE@ or @DELETE@, counting the affected rows.
|
||||
maybeTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (Maybe r)
|
||||
maybeTx s =
|
||||
Tx $ do
|
||||
r <- lift $ Bknd.maybeTx s
|
||||
EitherT $ return $ traverse ((mapLeft UnparsableResult) . RowParser.parseRow) $ r
|
||||
|
||||
-- |
|
||||
-- Execute a @SELECT@ 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 UnparsableResult) . RowParser.parseRow) $ r
|
||||
|
||||
-- |
|
||||
-- Execute a @SELECT@ statement with a cursor,
|
||||
-- and produce a result 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 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 UnparsableResult $ RowParser.parseRow $ row
|
||||
|
||||
|
||||
-- * Result Stream
|
||||
-------------------------
|
||||
|
||||
-- |
|
||||
@ -273,7 +244,7 @@ tx m t =
|
||||
-- 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,69 +260,18 @@ instance ListT.MonadTransUncons (TxListT s) where
|
||||
(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 = [q|SELECT (? + ?)|]
|
||||
--
|
||||
q :: TH.QuasiQuoter
|
||||
q =
|
||||
@ -364,18 +284,17 @@ q =
|
||||
parseExp s =
|
||||
do
|
||||
n <- either (fail . showString "Parsing failure: ") return (QParser.parse (fromString s))
|
||||
return $ statementF s n
|
||||
return $ statementF s (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) |]
|
||||
|
||||
THUtil.vectorE $
|
||||
map (\x -> THUtil.purify [| Bknd.encodeValue $(TH.varE x) |]) $
|
||||
argNames
|
||||
|
||||
@ -1,15 +1,13 @@
|
||||
module Hasql.Prelude
|
||||
(
|
||||
module Exports,
|
||||
bug,
|
||||
bottom,
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
-- base-prelude
|
||||
-------------------------
|
||||
import BasePrelude as Exports
|
||||
import BasePrelude as Exports hiding (left, right, isLeft, isRight)
|
||||
|
||||
-- transformers
|
||||
-------------------------
|
||||
@ -19,21 +17,18 @@ import Control.Monad.Trans.Class as Exports
|
||||
import Control.Monad.IO.Class as Exports
|
||||
import Data.Functor.Identity as Exports
|
||||
|
||||
-- mtl
|
||||
-------------------------
|
||||
import Control.Monad.Error.Class as Exports
|
||||
|
||||
-- mmorph
|
||||
-------------------------
|
||||
import Control.Monad.Morph as Exports
|
||||
|
||||
-- monad-control
|
||||
-- either
|
||||
-------------------------
|
||||
import Control.Monad.Trans.Control as Exports hiding (embed, embed_)
|
||||
|
||||
-- transformers-base
|
||||
-------------------------
|
||||
import Control.Monad.Base as Exports
|
||||
|
||||
-- safe
|
||||
-------------------------
|
||||
import Safe as Exports
|
||||
import Control.Monad.Trans.Either as Exports
|
||||
import Data.Either.Combinators as Exports
|
||||
|
||||
-- list-t
|
||||
-------------------------
|
||||
@ -46,26 +41,3 @@ import Data.Vector as Exports (Vector)
|
||||
-- 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,23 +2,26 @@ module Hasql.RowParser where
|
||||
|
||||
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 @@ return $ flip map [2 .. 24] $ \arity ->
|
||||
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 @@ return $ flip map [2 .. 24] $ \arity ->
|
||||
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 @@ module Hasql.TH where
|
||||
|
||||
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,50 @@ applicativeE head =
|
||||
\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 =
|
||||
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)))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user