git.iko.soy/squeal
on dev help sign in
Merge pull request #22 from morphismtech/0.2-Konstant
ef0f540Eitan Chatav
squeal-postgresql/exe/Example.hs+5−1
compare with dev
unifiedsplit
@@ -122,7 +122,11 @@ main = do
122
122
123main2 :: IO ()
123main2 :: IO ()
124main2 = void $
124main2 = void $
125− withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $
125+ withConnection "host=localhost port=5432 dbname=exampledb" . goPQ $
126 define setup
126 define setup
127 & pqThen session
127 & pqThen session
128 & thenDefine teardown
128 & thenDefine teardown
129+ where
130+ goPQ pq conn = do
131+ SOP.K x <- runPQ pq conn
132+ return (x, SOP.K (SOP.unK conn))
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+37−1
@@ -34,6 +34,7 @@ module Squeal.PostgreSQL.Definition
34 , (>>>)
34 , (>>>)
35 -- * Create
35 -- * Create
36 , createTable
36 , createTable
37+ , createTableIfNotExists
37 , TableConstraintExpression (..)
38 , TableConstraintExpression (..)
38 , Column (..)
39 , Column (..)
39 , check
40 , check
@@ -122,7 +123,42 @@ createTable
122 -- ^ constraints that must hold for the table
123 -- ^ constraints that must hold for the table
123 -> Definition schema (Create table (constraints :=> columns) schema)
124 -> Definition schema (Create table (constraints :=> columns) schema)
124createTable table columns constraints = UnsafeDefinition $
125createTable table columns constraints = UnsafeDefinition $
126+ "CREATE TABLE" <+> renderCreation table columns constraints
127+
128+-- | `createTable` adds a table to the schema.
129+--
130+-- >>> :set -XOverloadedLabels
131+-- >>> :{
132+-- renderDefinition $
133+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil
134+-- :}
135+-- "CREATE TABLE tab (a int, b real);"
136+createTableIfNotExists
137+ :: ( Has table schema (constraints :=> columns)
138+ , SOP.SListI columns
139+ , SOP.SListI constraints )
140+ => Alias table -- ^ the name of the table to add
141+ -> NP (Aliased TypeExpression) columns
142+ -- ^ the names and datatype of each column
143+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
144+ -- ^ constraints that must hold for the table
145+ -> Definition schema schema
146+createTableIfNotExists table columns constraints = UnsafeDefinition $
147+ "CREATE TABLE IF NOT EXISTS"
148+ <+> renderCreation table columns constraints
149+
150+-- helper function for `createTable` and `createTableIfNotExists`
151+renderCreation
152+ :: ( KnownSymbol table
153+ , SOP.SListI columns
154+ , SOP.SListI constraints )
155+ => Alias table -- ^ the name of the table to add
156+ -> NP (Aliased TypeExpression) columns
157+ -- ^ the names and datatype of each column
158+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
159+ -- ^ constraints that must hold for the table
160+ -> ByteString
125− "CREATE TABLE" <+> renderAlias table
161+renderCreation table columns constraints = renderAlias table
126 <+> parenthesized
162 <+> parenthesized
127 ( renderCommaSeparated renderColumnDef columns
163 ( renderCommaSeparated renderColumnDef columns
128 <> ( case constraints of
164 <> ( case constraints of
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+207−28
@@ -1,37 +1,216 @@
1+{-# LANGUAGE
2+ ScopedTypeVariables
3+ , OverloadedStrings
4+ , DataKinds
5+ , GADTs
6+ , LambdaCase
7+ , OverloadedLabels
8+ , TypeApplications
9+ , FlexibleContexts
10+ , TypeOperators
11+#-}
12+
1module Squeal.PostgreSQL.Migration
13module Squeal.PostgreSQL.Migration
2− ( Migration
14+ ( -- * Migration
3−-- , up
15+ Migration (..)
4− , MigrationResult
16+ , migrateUp
17+ , migrateDown
18+ -- * Step
19+ , Step (..)
20+ -- * MigrationTable
21+ , MigrationTable
22+ , createMigration
23+ , insertStep
24+ , deleteStep
25+ , selectStep
5 ) where
26 ) where
6
27
7import Control.Category
28import Control.Category
29+import Control.Monad
8−-- import Control.Exception.Lifted
30+import Control.Monad.Base
31+import Control.Monad.Trans.Control
32+import Generics.SOP (K(..))
9import Data.Function ((&))
33import Data.Function ((&))
34+import Data.Text (Text)
35+import Prelude hiding (id, (.))
10
36
11−import Squeal.PostgreSQL.PQ
37+import Squeal.PostgreSQL
12−-- import Squeal.PostgreSQL.Transaction
38+import Squeal.PostgreSQL.Transaction
13
39
40+-- | A `Step` of a `Migration`, should contain an inverse pair of
41+-- `up` and `down` instructions.
14−data Migration schema0 schema1 = Migration
42+data Step io schema0 schema1 = Step
15− { migrateUp :: PQ schema0 schema1 IO MigrationResult
43+ { name :: Text -- ^ The `name` of a `Step`.
16− , migrateDown :: PQ schema1 schema0 IO MigrationResult
44+ -- Each `name` in a `Migration` should be unique.
45+ , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Step`.
46+ , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Step`.
17 }
47 }
18
48
49+-- | A `Migration` is a chain of `Step`s
50+data Migration io schema0 schema1 where
51+ Done :: Migration io schema schema
52+ (:>>)
53+ :: Step io schema0 schema1
54+ -> Migration io schema1 schema2
55+ -> Migration io schema0 schema2
56+infixl 7 :>>
19−instance Category Migration where
57+instance Category (Migration io) where
20− id = Migration (return MigrationSuccess) (return MigrationSuccess)
58+ id = Done
21− migration1 . migration0 = Migration
59+ (.) migration = \case
22− { migrateUp = migrateUp migration0 & pqThen (migrateUp migration1)
60+ Done -> migration
23− , migrateDown = migrateDown migration1 & pqThen (migrateDown migration0)
61+ step :>> steps -> step :>> (steps >>> migration)
24− }
62+
25−
63+
26−-- up
64+-- | Run a `Migration` by creating the `MigrationTable`
27−-- :: Migration schema0 schema1
65+-- if it does not exist and then for each each `Step`
28−-- -> Connection schema0
66+-- query to see if the `Step` is executed. If not, then
29−-- -> IO (MigrationResult, Connection schema1)
67+-- execute the `Step` and insert its row in `MigrationTable`.
30−-- up (Migration mUp _) conn0 = do
68+migrateUp
31−-- (begin _conn0) <- runPQ (begin (TransactionMode ReadCommitted ReadWrite)) conn0
69+ :: MonadBaseControl IO io
32−-- & pqThen (Prelude.id mUp `onException` rollback)
70+ => Migration io schema0 schema1 -- ^ migration to run
33−-- & pqBind (\ result ->
71+ -> PQ
34−-- commit & pqThen (return result))
72+ ("migration" ::: MigrationTable ': schema0)
35−
73+ ("migration" ::: MigrationTable ': schema1)
36−data MigrationResult
74+ io ()
37− = MigrationSuccess
75+migrateUp migration =
76+ define createMigration
77+ & pqThen (begin (TransactionMode RepeatableRead ReadWrite))
78+ & pqThen (upSteps migration)
79+ & pqThen (void commit)
80+ where
81+
82+ upSteps
83+ :: MonadBaseControl IO io
84+ => Migration io schema0 schema1
85+ -> PQ
86+ ("migration" ::: MigrationTable ': schema0)
87+ ("migration" ::: MigrationTable ': schema1)
88+ io ()
89+ upSteps = \case
90+ Done -> return ()
91+ step :>> steps -> onExceptionRollback $
92+ upStep step
93+ & pqThen (upSteps steps)
94+
95+ queryExecuted
96+ :: MonadBase IO io
97+ => Step io schema0 schema1 -> PQ
98+ ("migration" ::: MigrationTable ': schema0)
99+ ("migration" ::: MigrationTable ': schema0)
100+ io RowNumber
101+ queryExecuted =
102+ ntuples <=< runQueryParams selectStep . Only . name
103+
104+ upStep
105+ :: MonadBase IO io
106+ => Step io schema0 schema1 -> PQ
107+ ("migration" ::: MigrationTable ': schema0)
108+ ("migration" ::: MigrationTable ': schema1)
109+ io ()
110+ upStep step =
111+ queryExecuted step
112+ & pqBind (\ (RowNumber executed) ->
113+ if executed == 1 -- up step has already been executed
114+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas
115+ else
116+ pqEmbed (up step) -- safely switch schemas
117+ & pqThen (manipulateParams insertStep (Only (name step)) & void))
118+ -- insert up step execution record
119+
120+-- | Rewind a `Migration` by creating the `MigrationTable`
121+-- if it does not exist and then for each each `Step`
122+-- query to see if the `Step` is executed. If it is, then
123+-- rewind the `Step` and delete its row in `MigrationTable`.
124+migrateDown
125+ :: MonadBaseControl IO io
126+ => Migration io schema0 schema1 -- ^ migration to rewind
127+ -> PQ
128+ ("migration" ::: MigrationTable ': schema1)
129+ ("migration" ::: MigrationTable ': schema0)
130+ io ()
131+migrateDown migration =
132+ define createMigration
133+ & pqThen (begin (TransactionMode RepeatableRead ReadWrite) & void)
134+ & pqThen (downSteps migration)
135+ & pqThen (void commit)
136+ where
137+
138+ queryExecuted
139+ :: MonadBase IO io
140+ => Step io schema0 schema1 -> PQ
141+ ("migration" ::: MigrationTable ': schema1)
142+ ("migration" ::: MigrationTable ': schema1)
143+ io RowNumber
144+ queryExecuted =
145+ ntuples <=< runQueryParams selectStep . Only . name
146+
147+ downStep
148+ :: MonadBase IO io
149+ => Step io schema0 schema1 -> PQ
150+ ("migration" ::: MigrationTable ': schema1)
151+ ("migration" ::: MigrationTable ': schema0)
152+ io ()
153+ downStep step =
154+ queryExecuted step
155+ & pqBind (\ (RowNumber executed) ->
156+ if executed == 0 -- up step has not been executed
157+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas
158+ else
159+ pqEmbed (down step) -- safely switch schemas
160+ & pqThen (manipulateParams deleteStep (Only (name step)) & void))
161+ -- delete up step execution record
162+
163+ downSteps
164+ :: MonadBaseControl IO io
165+ => Migration io schema0 schema1 -> PQ
166+ ("migration" ::: MigrationTable ': schema1)
167+ ("migration" ::: MigrationTable ': schema0)
168+ io ()
169+ downSteps = \case
170+ Done -> return ()
171+ step :>> steps -> onExceptionRollback $
172+ downSteps steps
173+ & pqThen (downStep step)
174+
175+-- | The `TableType` for a Squeal migration.
176+type MigrationTable =
177+ '[ "unique_name" ::: 'Unique '["name"]] :=>
178+ '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
179+ , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
180+ ]
181+
182+-- | Creates a `MigrationTable` if it does not already exist.
183+createMigration
184+ :: Has "migration" schema MigrationTable
185+ => Definition schema schema
186+createMigration =
187+ createTableIfNotExists #migration
188+ ( (text & notNull) `As` #name :*
189+ (timestampWithTimeZone & notNull & default_ currentTimestamp)
190+ `As` #executed_at :* Nil )
191+ ( unique (Column #name :* Nil) `As` #unique_name :* Nil )
192+
193+-- | Inserts a `Step` into the `MigrationTable`
194+insertStep
195+ :: Has "migration" schema MigrationTable
196+ => Manipulation schema '[ 'NotNull 'PGtext] '[]
197+insertStep = insertRow_ #migration
198+ ( Set (param @1) `As` #name :*
199+ Default `As` #executed_at :* Nil )
200+
201+-- | Deletes a `Step` from the `MigrationTable`
202+deleteStep
203+ :: Has "migration" schema MigrationTable
204+ => Manipulation schema '[ 'NotNull 'PGtext ] '[]
205+deleteStep = deleteFrom_ #migration (#name .== param @1)
206+
207+-- | Selects a `Step` from the `MigrationTable`, returning
208+-- the time at which it was executed.
209+selectStep
210+ :: Has "migration" schema MigrationTable
211+ => Query schema '[ 'NotNull 'PGtext ]
212+ '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
213+selectStep = select
214+ (#executed_at `As` #executed_at :* Nil)
215+ ( from (table (#migration `As` #m))
216+ & where_ (#name .== param @1))
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+73−70
@@ -33,13 +33,13 @@ a `MonadPQ` constraint for running a `Manipulation` or `Query`.
33
33
34module Squeal.PostgreSQL.PQ
34module Squeal.PostgreSQL.PQ
35 ( -- * Connection
35 ( -- * Connection
36− Connection (Connection, unConnection)
37− , connectdb
36+ connectdb
38 , finish
37 , finish
39 , withConnection
38 , withConnection
40 -- * PQ
39 -- * PQ
41 , PQ (PQ, runPQ)
40 , PQ (PQ, runPQ)
42 , execPQ
41 , execPQ
42+ , pqEmbed
43 , pqAp
43 , pqAp
44 , pqBind
44 , pqBind
45 , pqJoin
45 , pqJoin
@@ -51,7 +51,6 @@ module Squeal.PostgreSQL.PQ
51 , PQRun
51 , PQRun
52 , pqliftWith
52 , pqliftWith
53 -- * Result
53 -- * Result
54− , Result (Result, unResult)
55 , RowNumber (RowNumber, unRowNumber)
54 , RowNumber (RowNumber, unRowNumber)
56 , ColumnNumber (UnsafeColumnNumber, getColumnNumber)
55 , ColumnNumber (UnsafeColumnNumber, getColumnNumber)
57 , HasColumnNumber (columnNumber)
56 , HasColumnNumber (columnNumber)
@@ -62,6 +61,9 @@ module Squeal.PostgreSQL.PQ
62 , nextRow
61 , nextRow
63 , firstRow
62 , firstRow
64 , liftResult
63 , liftResult
64+ -- * Re-export
65+ , LibPQ.Connection
66+ , LibPQ.Result
65 ) where
67 ) where
66
68
67import Control.Exception.Lifted
69import Control.Exception.Lifted
@@ -100,11 +102,6 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict
100import qualified Control.Monad.Trans.RWS.Lazy as Lazy
102import qualified Control.Monad.Trans.RWS.Lazy as Lazy
101import qualified Control.Monad.Trans.RWS.Strict as Strict
103import qualified Control.Monad.Trans.RWS.Strict as Strict
102
104
103−-- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`
104−-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`
105−newtype Connection (schema :: TablesType) =
106− Connection { unConnection :: LibPQ.Connection }
107−
108{- | Makes a new connection to the database server.
105{- | Makes a new connection to the database server.
109
106
110This function opens a new database connection using the parameters taken
107This function opens a new database connection using the parameters taken
@@ -134,19 +131,19 @@ connectdb
134 :: forall schema io
131 :: forall schema io
135 . MonadBase IO io
132 . MonadBase IO io
136 => ByteString -- ^ conninfo
133 => ByteString -- ^ conninfo
137− -> io (Connection schema)
134+ -> io (K LibPQ.Connection schema)
138−connectdb = fmap Connection . liftBase . LibPQ.connectdb
135+connectdb = fmap K . liftBase . LibPQ.connectdb
139
136
140-- | Closes the connection to the server.
137-- | Closes the connection to the server.
141−finish :: MonadBase IO io => Connection schema -> io ()
138+finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()
142−finish = liftBase . LibPQ.finish . unConnection
139+finish = liftBase . LibPQ.finish . unK
143
140
144-- | Do `connectdb` and `finish` before and after a computation.
141-- | Do `connectdb` and `finish` before and after a computation.
145withConnection
142withConnection
146 :: forall schema0 schema1 io x
143 :: forall schema0 schema1 io x
147 . MonadBaseControl IO io
144 . MonadBaseControl IO io
148 => ByteString
145 => ByteString
149− -> (Connection schema0 -> io (x, Connection schema1))
146+ -> (K LibPQ.Connection schema0 -> io (x, K LibPQ.Connection schema1))
150 -> io x
147 -> io x
151withConnection connString action = do
148withConnection connString action = do
152 (x, _conn) <- bracket (connectdb connString) finish action
149 (x, _conn) <- bracket (connectdb connString) finish action
@@ -159,16 +156,28 @@ newtype PQ
159 (schema1 :: TablesType)
156 (schema1 :: TablesType)
160 (m :: Type -> Type)
157 (m :: Type -> Type)
161 (x :: Type) =
158 (x :: Type) =
162− PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }
159+ PQ { runPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
163− deriving Functor
160+
161+instance Monad m => Functor (PQ schema0 schema1 m) where
162+ fmap f (PQ pq) = PQ $ \ conn -> do
163+ K x <- pq conn
164+ return $ K (f x)
164
165
165-- | Run a `PQ` and discard the result but keep the `Connection`.
166-- | Run a `PQ` and discard the result but keep the `Connection`.
166execPQ
167execPQ
167 :: Functor m
168 :: Functor m
168 => PQ schema0 schema1 m x
169 => PQ schema0 schema1 m x
169− -> Connection schema0
170+ -> K LibPQ.Connection schema0
170− -> m (Connection schema1)
171+ -> m (K LibPQ.Connection schema1)
171−execPQ (PQ pq) = fmap snd . pq
172+execPQ (PQ pq) conn = fmap (mapKK (\ _ -> unK conn)) $ pq conn
173+
174+pqEmbed
175+ :: Monad m
176+ => PQ schema0 schema1 m x
177+ -> PQ (table ': schema0) (table : schema1) m x
178+pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
179+ K x <- pq (K conn)
180+ return $ K x
172
181
173-- | indexed analog of `<*>`
182-- | indexed analog of `<*>`
174pqAp
183pqAp
@@ -177,9 +186,9 @@ pqAp
177 -> PQ schema1 schema2 m x
186 -> PQ schema1 schema2 m x
178 -> PQ schema0 schema2 m y
187 -> PQ schema0 schema2 m y
179pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
188pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
180− (f', conn') <- f conn
189+ K f' <- f conn
181− (x', conn'') <- x conn'
190+ K x' <- x (K (unK conn))
182− return (f' x', conn'')
191+ return $ K (f' x')
183
192
184-- | indexed analog of `join`
193-- | indexed analog of `join`
185pqJoin
194pqJoin
@@ -194,8 +203,8 @@ pqBind
194 -> PQ schema0 schema1 m x
203 -> PQ schema0 schema1 m x
195 -> PQ schema0 schema2 m y
204 -> PQ schema0 schema2 m y
196pqBind f (PQ x) = PQ $ \ conn -> do
205pqBind f (PQ x) = PQ $ \ conn -> do
197− (x', conn') <- x conn
206+ K x' <- x conn
198− runPQ (f x') conn'
207+ runPQ (f x') (K (unK conn))
199
208
200-- | indexed analog of flipped `>>`
209-- | indexed analog of flipped `>>`
201pqThen
210pqThen
@@ -211,20 +220,20 @@ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
211define
220define
212 :: MonadBase IO io
221 :: MonadBase IO io
213 => Definition schema0 schema1
222 => Definition schema0 schema1
214− -> PQ schema0 schema1 io (Result '[])
223+ -> PQ schema0 schema1 io (K LibPQ.Result '[])
215−define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
224+define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
216 resultMaybe <- liftBase $ LibPQ.exec conn q
225 resultMaybe <- liftBase $ LibPQ.exec conn q
217 case resultMaybe of
226 case resultMaybe of
218 Nothing -> error
227 Nothing -> error
219 "define: LibPQ.exec returned no results"
228 "define: LibPQ.exec returned no results"
220− Just result -> return (Result result, Connection conn)
229+ Just result -> return $ K (K result)
221
230
222-- | Chain together `define` actions.
231-- | Chain together `define` actions.
223thenDefine
232thenDefine
224 :: MonadBase IO io
233 :: MonadBase IO io
225 => Definition schema1 schema2
234 => Definition schema1 schema2
226 -> PQ schema0 schema1 io x
235 -> PQ schema0 schema1 io x
227− -> PQ schema0 schema2 io (Result '[])
236+ -> PQ schema0 schema2 io (K LibPQ.Result '[])
228thenDefine = pqThen . define
237thenDefine = pqThen . define
229
238
230{- | `MonadPQ` is an `mtl` style constraint, similar to
239{- | `MonadPQ` is an `mtl` style constraint, similar to
@@ -264,41 +273,41 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
264 :: ToParams x params
273 :: ToParams x params
265 => Manipulation schema params ys
274 => Manipulation schema params ys
266 -- ^ `insertInto`, `update` or `deleteFrom`
275 -- ^ `insertInto`, `update` or `deleteFrom`
267− -> x -> pq (Result ys)
276+ -> x -> pq (K LibPQ.Result ys)
268 default manipulateParams
277 default manipulateParams
269 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
278 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
270 => ToParams x params
279 => ToParams x params
271 => Manipulation schema params ys
280 => Manipulation schema params ys
272 -- ^ `insertInto`, `update` or `deleteFrom`
281 -- ^ `insertInto`, `update` or `deleteFrom`
273− -> x -> pq (Result ys)
282+ -> x -> pq (K LibPQ.Result ys)
274 manipulateParams manipulation params = lift $
283 manipulateParams manipulation params = lift $
275 manipulateParams manipulation params
284 manipulateParams manipulation params
276
285
277− manipulate :: Manipulation schema '[] ys -> pq (Result ys)
286+ manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)
278 manipulate statement = manipulateParams statement ()
287 manipulate statement = manipulateParams statement ()
279
288
280 runQueryParams
289 runQueryParams
281 :: ToParams x params
290 :: ToParams x params
282 => Query schema params ys
291 => Query schema params ys
283 -- ^ `select` and friends
292 -- ^ `select` and friends
284− -> x -> pq (Result ys)
293+ -> x -> pq (K LibPQ.Result ys)
285 runQueryParams = manipulateParams . queryStatement
294 runQueryParams = manipulateParams . queryStatement
286
295
287 runQuery
296 runQuery
288 :: Query schema '[] ys
297 :: Query schema '[] ys
289 -- ^ `select` and friends
298 -- ^ `select` and friends
290− -> pq (Result ys)
299+ -> pq (K LibPQ.Result ys)
291 runQuery q = runQueryParams q ()
300 runQuery q = runQueryParams q ()
292
301
293 traversePrepared
302 traversePrepared
294 :: (ToParams x params, Traversable list)
303 :: (ToParams x params, Traversable list)
295 => Manipulation schema params ys
304 => Manipulation schema params ys
296 -- ^ `insertInto`, `update` or `deleteFrom`
305 -- ^ `insertInto`, `update` or `deleteFrom`
297− -> list x -> pq (list (Result ys))
306+ -> list x -> pq (list (K LibPQ.Result ys))
298 default traversePrepared
307 default traversePrepared
299 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
308 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
300 => (ToParams x params, Traversable list)
309 => (ToParams x params, Traversable list)
301− => Manipulation schema params ys -> list x -> pq (list (Result ys))
310+ => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))
302 traversePrepared manipulation params = lift $
311 traversePrepared manipulation params = lift $
303 traversePrepared manipulation params
312 traversePrepared manipulation params
304
313
@@ -307,7 +316,7 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
307 => list x
316 => list x
308 -> Manipulation schema params ys
317 -> Manipulation schema params ys
309 -- ^ `insertInto`, `update` or `deleteFrom`
318 -- ^ `insertInto`, `update` or `deleteFrom`
310− -> pq (list (Result ys))
319+ -> pq (list (K LibPQ.Result ys))
311 forPrepared = flip traversePrepared
320 forPrepared = flip traversePrepared
312
321
313 traversePrepared_
322 traversePrepared_
@@ -342,7 +351,7 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
342
351
343 manipulateParams
352 manipulateParams
344 (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
353 (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
345− PQ $ \ (Connection conn) -> do
354+ PQ $ \ (K conn) -> do
346 let
355 let
347 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
356 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
348 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
357 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
@@ -350,11 +359,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
350 case resultMaybe of
359 case resultMaybe of
351 Nothing -> error
360 Nothing -> error
352 "manipulateParams: LibPQ.execParams returned no results"
361 "manipulateParams: LibPQ.execParams returned no results"
353− Just result -> return (Result result, Connection conn)
362+ Just result -> return $ K (K result)
354
363
355 traversePrepared
364 traversePrepared
356 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
365 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
357− PQ $ \ (Connection conn) -> liftBase $ do
366+ PQ $ \ (K conn) -> liftBase $ do
358 let temp = "temporary_statement"
367 let temp = "temporary_statement"
359 prepResultMaybe <- LibPQ.prepare conn temp q Nothing
368 prepResultMaybe <- LibPQ.prepare conn temp q Nothing
360 case prepResultMaybe of
369 case prepResultMaybe of
@@ -372,7 +381,7 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
372 case resultMaybe of
381 case resultMaybe of
373 Nothing -> error
382 Nothing -> error
374 "traversePrepared: LibPQ.execParams returned no results"
383 "traversePrepared: LibPQ.execParams returned no results"
375− Just result -> return $ Result result
384+ Just result -> return $ K result
376 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
385 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
377 case deallocResultMaybe of
386 case deallocResultMaybe of
378 Nothing -> error
387 Nothing -> error
@@ -381,11 +390,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
381 status <- LibPQ.resultStatus deallocResult
390 status <- LibPQ.resultStatus deallocResult
382 unless (status == LibPQ.CommandOk) . error $
391 unless (status == LibPQ.CommandOk) . error $
383 "traversePrepared: DEALLOCATE status " <> show status
392 "traversePrepared: DEALLOCATE status " <> show status
384− return (results, Connection conn)
393+ return (K results)
385
394
386 traversePrepared_
395 traversePrepared_
387 (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =
396 (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =
388− PQ $ \ (Connection conn) -> liftBase $ do
397+ PQ $ \ (K conn) -> liftBase $ do
389 let temp = "temporary_statement"
398 let temp = "temporary_statement"
390 prepResultMaybe <- LibPQ.prepare conn temp q Nothing
399 prepResultMaybe <- LibPQ.prepare conn temp q Nothing
391 case prepResultMaybe of
400 case prepResultMaybe of
@@ -412,11 +421,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
412 status <- LibPQ.resultStatus deallocResult
421 status <- LibPQ.resultStatus deallocResult
413 unless (status == LibPQ.CommandOk) . error $
422 unless (status == LibPQ.CommandOk) . error $
414 "traversePrepared: DEALLOCATE status " <> show status
423 "traversePrepared: DEALLOCATE status " <> show status
415− return ((), Connection conn)
424+ return (K ())
416
425
417− liftPQ pq = PQ $ \ (Connection conn) -> do
426+ liftPQ pq = PQ $ \ (K conn) -> do
418 y <- liftBase $ pq conn
427 y <- liftBase $ pq conn
419− return (y, Connection conn)
428+ return (K y)
420
429
421instance MonadPQ schema m => MonadPQ schema (IdentityT m)
430instance MonadPQ schema m => MonadPQ schema (IdentityT m)
422instance MonadPQ schema m => MonadPQ schema (ReaderT r m)
431instance MonadPQ schema m => MonadPQ schema (ReaderT r m)
@@ -432,7 +441,7 @@ instance MonadPQ schema m => MonadPQ schema (ContT r m)
432instance MonadPQ schema m => MonadPQ schema (ListT m)
441instance MonadPQ schema m => MonadPQ schema (ListT m)
433
442
434instance Monad m => Applicative (PQ schema schema m) where
443instance Monad m => Applicative (PQ schema schema m) where
435− pure x = PQ $ \ conn -> pure (x, conn)
444+ pure x = PQ $ \ _conn -> pure (K x)
436 (<*>) = pqAp
445 (<*>) = pqAp
437
446
438instance Monad m => Monad (PQ schema schema m) where
447instance Monad m => Monad (PQ schema schema m) where
@@ -440,34 +449,28 @@ instance Monad m => Monad (PQ schema schema m) where
440 (>>=) = flip pqBind
449 (>>=) = flip pqBind
441
450
442instance MonadTrans (PQ schema schema) where
451instance MonadTrans (PQ schema schema) where
443− lift m = PQ $ \ conn -> do
452+ lift m = PQ $ \ _conn -> do
444 x <- m
453 x <- m
445− return (x, conn)
454+ return (K x)
446
455
447instance MonadBase b m => MonadBase b (PQ schema schema m) where
456instance MonadBase b m => MonadBase b (PQ schema schema m) where
448 liftBase = lift . liftBase
457 liftBase = lift . liftBase
449
458
450-- | A snapshot of the state of a `PQ` computation.
459-- | A snapshot of the state of a `PQ` computation.
451type PQRun schema =
460type PQRun schema =
452− forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)
461+ forall m x. Monad m => PQ schema schema m x -> m (K x schema)
453
462
454-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
463-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
455pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
464pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
456pqliftWith f = PQ $ \ conn ->
465pqliftWith f = PQ $ \ conn ->
457− fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
466+ fmap K (f $ \ pq -> runPQ pq conn)
458
467
459instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
468instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
460− type StM (PQ schema schema m) x = StM m (x, Connection schema)
469+ type StM (PQ schema schema m) x = StM m (K x schema)
461 liftBaseWith f =
470 liftBaseWith f =
462 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
471 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
463 restoreM = PQ . const . restoreM
472 restoreM = PQ . const . restoreM
464
473
465−-- | Encapsulates the result of a squeal command run by @LibPQ@.
466−-- `Result`s are parameterized by a `ColumnsType` describing the column names
467−-- and their types.
468−newtype Result (columns :: RelationType)
469− = Result { unResult :: LibPQ.Result }
470−
471-- | Just newtypes around a `CInt`
474-- | Just newtypes around a `CInt`
472newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
475newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
473
476
@@ -494,12 +497,12 @@ getValue
494 :: (FromColumnValue colty y, MonadBase IO io)
497 :: (FromColumnValue colty y, MonadBase IO io)
495 => RowNumber -- ^ row
498 => RowNumber -- ^ row
496 -> ColumnNumber n columns colty -- ^ col
499 -> ColumnNumber n columns colty -- ^ col
497− -> Result columns -- ^ result
500+ -> K LibPQ.Result columns -- ^ result
498 -> io y
501 -> io y
499getValue
502getValue
500 (RowNumber r)
503 (RowNumber r)
501 (UnsafeColumnNumber c :: ColumnNumber n columns colty)
504 (UnsafeColumnNumber c :: ColumnNumber n columns colty)
502− (Result result)
505+ (K result)
503 = fmap (fromColumnValue @colty . K) $ liftBase $ do
506 = fmap (fromColumnValue @colty . K) $ liftBase $ do
504 numRows <- LibPQ.ntuples result
507 numRows <- LibPQ.ntuples result
505 when (numRows < r) $ error $
508 when (numRows < r) $ error $
@@ -512,10 +515,10 @@ getRow
512 :: (FromRow columns y, MonadBase IO io)
515 :: (FromRow columns y, MonadBase IO io)
513 => RowNumber
516 => RowNumber
514 -- ^ row
517 -- ^ row
515− -> Result columns
518+ -> K LibPQ.Result columns
516 -- ^ result
519 -- ^ result
517 -> io y
520 -> io y
518−getRow (RowNumber r) (Result result :: Result columns) = liftBase $ do
521+getRow (RowNumber r) (K result :: K LibPQ.Result columns) = liftBase $ do
519 numRows <- LibPQ.ntuples result
522 numRows <- LibPQ.ntuples result
520 when (numRows < r) $ error $
523 when (numRows < r) $ error $
521 "getRow: expected at least " <> show r <> "rows but only saw "
524 "getRow: expected at least " <> show r <> "rows but only saw "
@@ -527,8 +530,8 @@ getRow (RowNumber r) (Result result :: Result columns) = liftBase $ do
527 Just row -> return $ fromRow @columns row
530 Just row -> return $ fromRow @columns row
528
531
529-- | Returns the number of rows (tuples) in the query result.
532-- | Returns the number of rows (tuples) in the query result.
530−ntuples :: MonadBase IO io => Result columns -> io RowNumber
533+ntuples :: MonadBase IO io => K LibPQ.Result columns -> io RowNumber
531−ntuples (Result result) = liftBase $ RowNumber <$> LibPQ.ntuples result
534+ntuples (K result) = liftBase $ RowNumber <$> LibPQ.ntuples result
532
535
533-- | Intended to be used for unfolding in streaming libraries, `nextRow`
536-- | Intended to be used for unfolding in streaming libraries, `nextRow`
534-- takes a total number of rows (which can be found with `ntuples`)
537-- takes a total number of rows (which can be found with `ntuples`)
@@ -537,10 +540,10 @@ ntuples (Result result) = liftBase $ RowNumber <$> LibPQ.ntuples result
537nextRow
540nextRow
538 :: (FromRow columns y, MonadBase IO io)
541 :: (FromRow columns y, MonadBase IO io)
539 => RowNumber -- ^ total number of rows
542 => RowNumber -- ^ total number of rows
540− -> Result columns -- ^ result
543+ -> K LibPQ.Result columns -- ^ result
541 -> RowNumber -- ^ row number
544 -> RowNumber -- ^ row number
542 -> io (Maybe (RowNumber,y))
545 -> io (Maybe (RowNumber,y))
543−nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)
546+nextRow (RowNumber total) (K result :: K LibPQ.Result columns) (RowNumber r)
544 = liftBase $ if r >= total then return Nothing else do
547 = liftBase $ if r >= total then return Nothing else do
545 let len = fromIntegral (lengthSList (Proxy @columns))
548 let len = fromIntegral (lengthSList (Proxy @columns))
546 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
549 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
@@ -551,9 +554,9 @@ nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)
551-- | Get all rows from a `Result`.
554-- | Get all rows from a `Result`.
552getRows
555getRows
553 :: (FromRow columns y, MonadBase IO io)
556 :: (FromRow columns y, MonadBase IO io)
554− => Result columns -- ^ result
557+ => K LibPQ.Result columns -- ^ result
555 -> io [y]
558 -> io [y]
556−getRows (Result result :: Result columns) = liftBase $ do
559+getRows (K result :: K LibPQ.Result columns) = liftBase $ do
557 let len = fromIntegral (lengthSList (Proxy @columns))
560 let len = fromIntegral (lengthSList (Proxy @columns))
558 numRows <- LibPQ.ntuples result
561 numRows <- LibPQ.ntuples result
559 for [0 .. numRows - 1] $ \ r -> do
562 for [0 .. numRows - 1] $ \ r -> do
@@ -565,9 +568,9 @@ getRows (Result result :: Result columns) = liftBase $ do
565-- | Get the first row if possible from a `Result`.
568-- | Get the first row if possible from a `Result`.
566firstRow
569firstRow
567 :: (FromRow columns y, MonadBase IO io)
570 :: (FromRow columns y, MonadBase IO io)
568− => Result columns -- ^ result
571+ => K LibPQ.Result columns -- ^ result
569 -> io (Maybe y)
572 -> io (Maybe y)
570−firstRow (Result result :: Result columns) = liftBase $ do
573+firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
571 numRows <- LibPQ.ntuples result
574 numRows <- LibPQ.ntuples result
572 if numRows <= 0 then return Nothing else do
575 if numRows <= 0 then return Nothing else do
573 let len = fromIntegral (lengthSList (Proxy @columns))
576 let len = fromIntegral (lengthSList (Proxy @columns))
@@ -580,5 +583,5 @@ firstRow (Result result :: Result columns) = liftBase $ do
580liftResult
583liftResult
581 :: MonadBase IO io
584 :: MonadBase IO io
582 => (LibPQ.Result -> IO x)
585 => (LibPQ.Result -> IO x)
583− -> Result results -> io x
586+ -> K LibPQ.Result results -> io x
584−liftResult f (Result result) = liftBase $ f result
587+liftResult f (K result) = liftBase $ f result
squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+11−6
@@ -1,11 +1,13 @@
1{-# LANGUAGE
1{-# LANGUAGE
2+ DataKinds
2− DeriveFunctor
3+ , DeriveFunctor
3 , FlexibleContexts
4 , FlexibleContexts
4 , FlexibleInstances
5 , FlexibleInstances
5 , MultiParamTypeClasses
6 , MultiParamTypeClasses
6 , RankNTypes
7 , RankNTypes
7 , ScopedTypeVariables
8 , ScopedTypeVariables
8 , TypeFamilies
9 , TypeFamilies
10+ , TypeInType
9 , UndecidableInstances
11 , UndecidableInstances
10#-}
12#-}
11
13
@@ -15,10 +17,13 @@ import Control.Monad.Base
15import Control.Monad.Trans
17import Control.Monad.Trans
16import Control.Monad.Trans.Control
18import Control.Monad.Trans.Control
17import Data.Pool
19import Data.Pool
20+import Generics.SOP (K(..))
18
21
19import Squeal.PostgreSQL.PQ
22import Squeal.PostgreSQL.PQ
23+import Squeal.PostgreSQL.Schema
20
24
25+newtype PoolPQ (schema :: TablesType) m x =
21−newtype PoolPQ schema m x = PoolPQ { runPoolPQ :: Pool (Connection schema) -> m x }
26+ PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }
22 deriving Functor
27 deriving Functor
23
28
24instance Monad m => Applicative (PoolPQ schema m) where
29instance Monad m => Applicative (PoolPQ schema m) where
@@ -43,22 +48,22 @@ instance MonadBase b m => MonadBase b (PoolPQ schema m) where
43instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
48instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
44 manipulateParams manipulation params = PoolPQ $ \ pool -> do
49 manipulateParams manipulation params = PoolPQ $ \ pool -> do
45 withResource pool $ \ conn -> do
50 withResource pool $ \ conn -> do
46− (result, _ :: Connection schema) <- flip runPQ conn $
51+ (K result :: K (K Result ys) schema) <- flip runPQ conn $
47 manipulateParams manipulation params
52 manipulateParams manipulation params
48 return result
53 return result
49 traversePrepared manipulation params = PoolPQ $ \ pool ->
54 traversePrepared manipulation params = PoolPQ $ \ pool ->
50 withResource pool $ \ conn -> do
55 withResource pool $ \ conn -> do
51− (result, _ :: Connection schema) <- flip runPQ conn $
56+ (K result :: K (list (K Result ys)) schema) <- flip runPQ conn $
52 traversePrepared manipulation params
57 traversePrepared manipulation params
53 return result
58 return result
54 traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
59 traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
55 withResource pool $ \ conn -> do
60 withResource pool $ \ conn -> do
56− (_, _ :: Connection schema) <- flip runPQ conn $
61+ (_ :: K () schema) <- flip runPQ conn $
57 traversePrepared_ manipulation params
62 traversePrepared_ manipulation params
58 return ()
63 return ()
59 liftPQ m = PoolPQ $ \ pool ->
64 liftPQ m = PoolPQ $ \ pool ->
60 withResource pool $ \ conn -> do
65 withResource pool $ \ conn -> do
61− (result, _ :: Connection schema) <- flip runPQ conn $
66+ (K result :: K result schema) <- flip runPQ conn $
62 liftPQ m
67 liftPQ m
63 return result
68 return result
64
69
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+2
@@ -41,6 +41,7 @@ module Squeal.PostgreSQL.Schema
41 , ColumnType
41 , ColumnType
42 , ColumnsType
42 , ColumnsType
43 , RelationType
43 , RelationType
44+ , NilRelation
44 , RelationsType
45 , RelationsType
45 , TableType
46 , TableType
46 , TablesType
47 , TablesType
@@ -281,6 +282,7 @@ type TablesType = [(Symbol,TableType)]
281-- >>> :kind Relation
282-- >>> :kind Relation
282-- Relation :: [(Symbol, NullityType)]
283-- Relation :: [(Symbol, NullityType)]
283type RelationType = [(Symbol,NullityType)]
284type RelationType = [(Symbol,NullityType)]
285+type family NilRelation :: RelationType where NilRelation = '[]
284
286
285-- | `RelationsType` is a row of `RelationType`s, thought of as a product.
287-- | `RelationsType` is a row of `RelationType`s, thought of as a product.
286type RelationsType = [(Symbol,RelationType)]
288type RelationsType = [(Symbol,RelationType)]
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+19−3
@@ -6,6 +6,8 @@
6 , LambdaCase
6 , LambdaCase
7 , OverloadedStrings
7 , OverloadedStrings
8 , MultiParamTypeClasses
8 , MultiParamTypeClasses
9+ , TypeFamilies
10+ , TypeInType
9#-}
11#-}
10
12
11module Squeal.PostgreSQL.Transaction
13module Squeal.PostgreSQL.Transaction
@@ -14,19 +16,25 @@ module Squeal.PostgreSQL.Transaction
14 , begin
16 , begin
15 , commit
17 , commit
16 , rollback
18 , rollback
19+ , onExceptionRollback
17 , TransactionMode (..)
20 , TransactionMode (..)
18 , IsolationLevel (..)
21 , IsolationLevel (..)
19 , ReadWriteMode (..)
22 , ReadWriteMode (..)
20 ) where
23 ) where
21
24
22import Control.Exception.Lifted
25import Control.Exception.Lifted
26+import Control.Monad.Base
23import Control.Monad.Trans.Control
27import Control.Monad.Trans.Control
24import Data.ByteString
28import Data.ByteString
25import Data.Monoid
29import Data.Monoid
30+import Generics.SOP
31+
32+import qualified Database.PostgreSQL.LibPQ as LibPQ
26
33
27import Squeal.PostgreSQL.Manipulation
34import Squeal.PostgreSQL.Manipulation
28import Squeal.PostgreSQL.Prettyprint
35import Squeal.PostgreSQL.Prettyprint
29import Squeal.PostgreSQL.PQ
36import Squeal.PostgreSQL.PQ
37+import Squeal.PostgreSQL.Schema
30
38
31transactionally
39transactionally
32 :: (MonadBaseControl IO tx, MonadPQ schema tx)
40 :: (MonadBaseControl IO tx, MonadPQ schema tx)
@@ -43,16 +51,24 @@ transactionally_
43 => tx x -> tx x
51 => tx x -> tx x
44transactionally_ = transactionally (TransactionMode ReadCommitted ReadWrite)
52transactionally_ = transactionally (TransactionMode ReadCommitted ReadWrite)
45
53
46−begin :: MonadPQ schema tx => TransactionMode -> tx (Result '[])
54+begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)
47begin mode = manipulate . UnsafeManipulation $
55begin mode = manipulate . UnsafeManipulation $
48 "BEGIN" <+> renderTransactionMode mode <> ";"
56 "BEGIN" <+> renderTransactionMode mode <> ";"
49
57
50−commit :: MonadPQ schema tx => tx (Result '[])
58+commit :: MonadPQ schema tx => tx (K Result NilRelation)
51commit = manipulate $ UnsafeManipulation "COMMIT;"
59commit = manipulate $ UnsafeManipulation "COMMIT;"
52
60
53−rollback :: MonadPQ schema tx => tx (Result '[])
61+rollback :: MonadPQ schema tx => tx (K Result NilRelation)
54rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
62rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
55
63
64+onExceptionRollback
65+ :: MonadBaseControl IO io
66+ => PQ schema0 schema1 io x
67+ -> PQ schema0 schema1 io x
68+onExceptionRollback u = PQ $ \ conn -> mask $ \ restore ->
69+ restore (runPQ u conn) `onException`
70+ liftBase (LibPQ.exec (unK conn) "ROLLBACK")
71+
56data TransactionMode = TransactionMode
72data TransactionMode = TransactionMode
57 { isolationLevel :: IsolationLevel
73 { isolationLevel :: IsolationLevel
58 , readWriteMode :: ReadWriteMode
74 , readWriteMode :: ReadWriteMode