git.iko.soy/squeal
on dev help sign in
pool and migration
ccd6495Eitan Chatav
squeal-postgresql/squeal-postgresql.cabal+3
compare with dev
unifiedsplit
@@ -26,6 +26,8 @@ library
26 Squeal.PostgreSQL.Definition
26 Squeal.PostgreSQL.Definition
27 Squeal.PostgreSQL.Expression
27 Squeal.PostgreSQL.Expression
28 Squeal.PostgreSQL.Manipulation
28 Squeal.PostgreSQL.Manipulation
29+ Squeal.PostgreSQL.Migration
30+ Squeal.PostgreSQL.Pool
29 Squeal.PostgreSQL.PQ
31 Squeal.PostgreSQL.PQ
30 Squeal.PostgreSQL.Prettyprint
32 Squeal.PostgreSQL.Prettyprint
31 Squeal.PostgreSQL.Query
33 Squeal.PostgreSQL.Query
@@ -45,6 +47,7 @@ library
45 , network-ip >= 0.3.0.2
47 , network-ip >= 0.3.0.2
46 , postgresql-binary >= 0.12.1
48 , postgresql-binary >= 0.12.1
47 , postgresql-libpq >= 0.9.3.1
49 , postgresql-libpq >= 0.9.3.1
50+ , resource-pool
48 , scientific >= 0.3.5.1
51 , scientific >= 0.3.5.1
49 , text >= 1.2.2.2
52 , text >= 1.2.2.2
50 , time >= 1.8.0.2
53 , time >= 1.8.0.2
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hsnew file+9
@@ -0,0 +1,9 @@
1+module Squeal.PostgreSQL.Migration where
2+
3+import Squeal.PostgreSQL.PQ
4+
5+data Migration schema0 schema1 m x = Migration
6+ { migrateUp :: PQ schema0 schema1 m x
7+ , migrateDown :: PQ schema0 schema1 m x
8+ }
9+
squeal-postgresql/src/Squeal/PostgreSQL/Pool.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE
2+ DeriveFunctor
3+ , FlexibleContexts
4+ , FlexibleInstances
5+ , MultiParamTypeClasses
6+ , ScopedTypeVariables
7+ , UndecidableInstances
8+#-}
9+
10+module Squeal.PostgreSQL.Pool where
11+
12+import Control.Monad.Base
13+import Control.Monad.Trans
14+import Control.Monad.Trans.Control
15+import Data.Pool
16+
17+import Squeal.PostgreSQL.PQ
18+
19+newtype PoolPQ schema m x = PoolPQ { runPoolPQ :: Pool (Connection schema) -> m x }
20+ deriving Functor
21+
22+instance Monad m => Applicative (PoolPQ schema m) where
23+ pure x = PoolPQ $ \ _ -> pure x
24+ PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
25+ f' <- f pool
26+ x' <- x pool
27+ return $ f' x'
28+
29+instance Monad m => Monad (PoolPQ schema m) where
30+ return = pure
31+ PoolPQ x >>= f = PoolPQ $ \ pool -> do
32+ x' <- x pool
33+ runPoolPQ (f x') pool
34+
35+instance MonadTrans (PoolPQ schema) where
36+ lift m = PoolPQ $ \ _pool -> m
37+
38+instance MonadBase b m => MonadBase b (PoolPQ schema m) where
39+ liftBase = lift . liftBase
40+
41+instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
42+ manipulateParams manipulation params = PoolPQ $ \ pool -> do
43+ withResource pool $ \ conn -> do
44+ (result, _ :: Connection schema) <- flip runPQ conn $
45+ manipulateParams manipulation params
46+ return result
47+ traversePrepared manipulation params = PoolPQ $ \ pool ->
48+ withResource pool $ \ conn -> do
49+ (result, _ :: Connection schema) <- flip runPQ conn $
50+ traversePrepared manipulation params
51+ return result
52+ traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
53+ withResource pool $ \ conn -> do
54+ (_, _ :: Connection schema) <- flip runPQ conn $
55+ traversePrepared_ manipulation params
56+ return ()
57+ liftPQ m = PoolPQ $ \ pool ->
58+ withResource pool $ \ conn -> do
59+ (result, _ :: Connection schema) <- flip runPQ conn $
60+ liftPQ m
61+ return result