@@ -1,3 +1,15 @@
1+{-|
2+Module: Squeal.PostgreSQL.PQ
3+Description: PQ monad
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+`Squeal.PostgreSQL.PQ` is where Squeal statements come to actually get run by
9+`LibPQ`. It contains a `PQ` indexed monad transformer to run `Definition`s and
10+a `MonadPQ` constraint for running a `Manipulation` or `Query`.
11+-}
12+
113{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
214{-# LANGUAGE
315 DataKinds
@@ -19,7 +31,36 @@
1931 , UndecidableInstances
2032#-}
2133
22−module Squeal.PostgreSQL.PQ where
34+module Squeal.PostgreSQL.PQ
35+ ( -- * Connection
36+ Connection (unConnection)
37+ , connectdb
38+ , finish
39+ , withConnection
40+ -- * PQ
41+ , PQ (runPQ)
42+ , execPQ
43+ , pqAp
44+ , pqBind
45+ , pqThen
46+ , define
47+ , thenDefine
48+ -- * MonadPQ
49+ , MonadPQ (..)
50+ , PQRun
51+ , pqliftWith
52+ -- * Result
53+ , Result (Result, unResult)
54+ , RowNumber (RowNumber, unRowNumber)
55+ , ColumnNumber (UnsafeColumnNumber, getColumnNumber)
56+ , HasColumnNumber (columnNumber)
57+ , getValue
58+ , getRow
59+ , getRows
60+ , nextRow
61+ , firstRow
62+ , liftResult
63+ ) where
2364
2465import Control.Exception.Lifted
2566import Control.Monad.Base
@@ -43,11 +84,52 @@ import Squeal.PostgreSQL.Manipulation
4384import Squeal.PostgreSQL.Query
4485import Squeal.PostgreSQL.Schema
4586
46−-- | A `Connection` consists of a `Database.PastgreSQL.LibPQ.Connection`
47−-- and a phantom `Squeal.PostgreSQL.TablesType`
87+-- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`
88+-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`
4889newtype Connection (schema :: TablesType) =
4990 Connection { unConnection :: LibPQ.Connection }
5091
92+{- | Makes a new connection to the database server.
93+
94+This function opens a new database connection using the parameters taken
95+from the string conninfo.
96+
97+The passed string can be empty to use all default parameters, or it can
98+contain one or more parameter settings separated by whitespace.
99+Each parameter setting is in the form keyword = value. Spaces around the equal
100+sign are optional. To write an empty value or a value containing spaces,
101+surround it with single quotes, e.g., keyword = 'a value'. Single quotes and
102+backslashes within the value must be escaped with a backslash, i.e., ' and \.
103+
104+To specify the schema you wish to connect with, use type application.
105+
106+>>> :set -XTypeApplication
107+>>> conn <- connectdb @MySchema "host=localhost port=5432 dbname=exampledb"
108+
109+Note that, for now, squeal doesn't offer any protection from connecting
110+with the wrong schema!
111+-}
112+connectdb
113+ :: forall schema io
114+ . MonadBase IO io
115+ => ByteString -- ^ conninfo
116+ -> io (Connection schema)
117+connectdb = fmap Connection . liftBase . LibPQ.connectdb
118+
119+-- | Closes the connection to the server.
120+finish :: MonadBase IO io => Connection schema -> io ()
121+finish = liftBase . LibPQ.finish . unConnection
122+
123+-- | Do `connectdb` and `finish` before and after a computation.
124+withConnection
125+ :: forall schema io x
126+ . MonadBaseControl IO io
127+ => ByteString
128+ -> (Connection schema -> io x)
129+ -> io x
130+withConnection connString = bracket (connectdb connString) finish
131+
132+
51133-- | We keep track of the schema via an Atkey indexed state monad transformer,
52134-- `PQ`.
53135newtype PQ
@@ -58,9 +140,7 @@ newtype PQ
58140 PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }
59141 deriving Functor
60142
61−evalPQ :: Functor m => PQ schema0 schema1 m x -> Connection schema0 -> m x
62−evalPQ (PQ pq) = fmap fst . pq
63−
143+-- | Run a `PQ` and discard the result but keep the `Connection`.
64144execPQ
65145 :: Functor m
66146 => PQ schema0 schema1 m x
@@ -89,7 +169,7 @@ pqBind f (PQ x) = PQ $ \ conn -> do
89169 (x', conn') <- x conn
90170 runPQ (f x') conn'
91171
92−-- | indexed analog of `>>`
172+-- | indexed analog of flipped `>>`
93173pqThen
94174 :: Monad m
95175 => PQ schema1 schema2 m y
@@ -99,7 +179,7 @@ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
99179
100180-- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
101181--
102−-- prop> then (define statement2) statement1 = define (statement2 . statement1)
182+-- prop> pqThen (define statement2) statement1 = define (statement2 . statement1)
103183define
104184 :: MonadBase IO io
105185 => Definition schema0 schema1
@@ -111,24 +191,58 @@ define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
111191 "define: LibPQ.exec returned no results"
112192 Just result -> return (Result result, Connection conn)
113193
114−pqThenDefine
194+-- | Chain together `define` actions.
195+thenDefine
115196 :: MonadBase IO io
116197 => Definition schema1 schema2
117198 -> PQ schema0 schema1 io x
118199 -> PQ schema0 schema2 io (Result '[])
119−pqThenDefine = pqThen . define
200+thenDefine = pqThen . define
201+
202+{- | `MonadPQ` is an `mtl` style constraint, similar to
203+`Control.Monad.State.Class.MonadState`, for using `LibPQ` to
204+
205+* `manipulateParams` runs a `Manipulation` with params from a type
206+ with a `ToParams` constraint. It calls `LibPQ.execParams` and
207+ doesn't afraid of anything.
208+
209+* `manipulate` is like `manipulateParams` for a parameter-free statement.
210+
211+* `runQueryParams` is like `manipulateParams` for query statements.
212+
213+* `traversePrepared` has the same type signature as a composition of
214+ `traverse` and `manipulateParams` but provides an optimization by
215+ preparing the statement with `LibPQ.prepare` and then traversing a
216+ `Traversable` container with `LibPQ.execPrepared`. The temporary prepared
217+ statement is then deallocated.
218+
219+* `forPrepared` is a flipped `traversePrepared`
120220
121−-- | `MonadPQ` is an `mtl` style constraint, similar to `MonadState`.
221+* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
222+ containers and returns unit.
223+
224+* `forPrepared_` is a flipped `traversePrepared_`.
225+
226+* `liftPQ` lets you lift actions from `LibPQ` that require a connection
227+ into your monad.
228+
229+To define an instance, you can minimally define only `manipulateParams`,
230+`traversePrepared`, `traversePrepared_` and `liftPQ`. Monad transformers get
231+a default instance.
232+
233+-}
122234class Monad pq => MonadPQ schema pq | pq -> schema where
123− -- | `manipulateParams` runs a `Manipulation` with params from a type
124− -- with a `ToParams` constraint
125235 manipulateParams
126236 :: ToParams x params
127− => Manipulation schema params ys -> x -> pq (Result ys)
237+ => Manipulation schema params ys
238+ -- ^ `insertInto`, `update` or `deleteFrom`
239+ -> x -> pq (Result ys)
128240 default manipulateParams
129241 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
130242 => ToParams x params
131− => Manipulation schema params ys -> x -> pq (Result ys)
243+ => Manipulation schema params ys
244+ -- ^ `insertInto`, `update` or `deleteFrom`
245+ -> x -> pq (Result ys)
132246 manipulateParams manipulation params = lift $
133247 manipulateParams manipulation params
134248
@@ -137,15 +251,22 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
137251
138252 runQueryParams
139253 :: ToParams x params
140− => Query schema params ys -> x -> pq (Result ys)
254+ => Query schema params ys
255+ -- ^ `select` and friends
256+ -> x -> pq (Result ys)
141257 runQueryParams = manipulateParams . queryStatement
142258
143− runQuery :: Query schema '[] ys -> pq (Result ys)
259+ runQuery
260+ :: Query schema '[] ys
261+ -- ^ `select` and friends
262+ -> pq (Result ys)
144263 runQuery q = runQueryParams q ()
145264
146265 traversePrepared
147266 :: (ToParams x params, Traversable list)
148− => Manipulation schema params ys -> list x -> pq (list (Result ys))
267+ => Manipulation schema params ys
268+ -- ^ `insertInto`, `update` or `deleteFrom`
269+ -> list x -> pq (list (Result ys))
149270 default traversePrepared
150271 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
151272 => (ToParams x params, Traversable list)
@@ -155,22 +276,32 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
155276
156277 forPrepared
157278 :: (ToParams x params, Traversable list)
158− => list x -> Manipulation schema params ys -> pq (list (Result ys))
279+ => list x
280+ -> Manipulation schema params ys
281+ -- ^ `insertInto`, `update` or `deleteFrom`
282+ -> pq (list (Result ys))
159283 forPrepared = flip traversePrepared
160284
161285 traversePrepared_
162286 :: (ToParams x params, Foldable list)
163− => Manipulation schema params ys -> list x -> pq ()
287+ => Manipulation schema params ys
288+ -- ^ `insertInto`, `update` or `deleteFrom`
289+ -> list x -> pq ()
164290 default traversePrepared_
165291 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
166292 => (ToParams x params, Foldable list)
167− => Manipulation schema params ys -> list x -> pq ()
293+ => Manipulation schema params ys
294+ -- ^ `insertInto`, `update` or `deleteFrom`
295+ -> list x -> pq ()
168296 traversePrepared_ manipulation params = lift $
169297 traversePrepared_ manipulation params
170298
171299 forPrepared_
172300 :: (ToParams x params, Traversable list)
173− => list x -> Manipulation schema params ys -> pq ()
301+ => list x
302+ -> Manipulation schema params ys
303+ -- ^ `insertInto`, `update` or `deleteFrom`
304+ -> pq ()
174305 forPrepared_ = flip traversePrepared_
175306
176307 liftPQ :: (LibPQ.Connection -> IO a) -> pq a
@@ -195,58 +326,64 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
195326
196327 traversePrepared
197328 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
198− PQ $ \ (Connection conn) -> do
329+ PQ $ \ (Connection conn) -> liftBase $ do
199330 let temp = "temporary_statement"
200− prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing
331+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
201332 case prepResultMaybe of
202333 Nothing -> error
203334 "traversePrepared: LibPQ.prepare returned no results"
204− Just _prepResult -> return () -- todo: check status of prepResult
335+ Just prepResult -> do
336+ status <- LibPQ.resultStatus prepResult
337+ unless (status == LibPQ.CommandOk) . error $
338+ "traversePrepared: LibPQ.prepare status " <> show status
205339 results <- for list $ \ params -> do
206340 let
207341 toParam' bytes = (bytes,LibPQ.Binary)
208342 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
209− resultMaybe <- liftBase $
210− LibPQ.execPrepared conn temp params' LibPQ.Binary
343+ resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
211344 case resultMaybe of
212345 Nothing -> error
213346 "traversePrepared: LibPQ.execParams returned no results"
214347 Just result -> return $ Result result
215− deallocResultMaybe <- liftBase $
216− LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
348+ deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
217349 case deallocResultMaybe of
218350 Nothing -> error
219351 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
220− Just _deallocResult -> return ()
221− -- todo: check status of deallocResult
352+ Just deallocResult -> do
353+ status <- LibPQ.resultStatus deallocResult
354+ unless (status == LibPQ.CommandOk) . error $
355+ "traversePrepared: DEALLOCATE status " <> show status
222356 return (results, Connection conn)
223357
224358 traversePrepared_
225359 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
226− PQ $ \ (Connection conn) -> do
360+ PQ $ \ (Connection conn) -> liftBase $ do
227361 let temp = "temporary_statement"
228− prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing
362+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
229363 case prepResultMaybe of
230364 Nothing -> error
231365 "traversePrepared_: LibPQ.prepare returned no results"
232− Just _prepResult -> return () -- todo: check status of prepResult
366+ Just prepResult -> do
367+ status <- LibPQ.resultStatus prepResult
368+ unless (status == LibPQ.CommandOk) . error $
369+ "traversePrepared: LibPQ.prepare status " <> show status
233370 for_ list $ \ params -> do
234371 let
235372 toParam' bytes = (bytes,LibPQ.Binary)
236373 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
237− resultMaybe <- liftBase $
238− LibPQ.execPrepared conn temp params' LibPQ.Binary
374+ resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
239375 case resultMaybe of
240376 Nothing -> error
241377 "traversePrepared_: LibPQ.execParams returned no results"
242378 Just _result -> return ()
243− deallocResultMaybe <- liftBase $
244− LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
379+ deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
245380 case deallocResultMaybe of
246381 Nothing -> error
247382 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
248− Just _deallocResult -> return ()
249− -- todo: check status of deallocResult
383+ Just deallocResult -> do
384+ status <- LibPQ.resultStatus deallocResult
385+ unless (status == LibPQ.CommandOk) . error $
386+ "traversePrepared: DEALLOCATE status " <> show status
250387 return ((), Connection conn)
251388
252389 liftPQ pq = PQ $ \ (Connection conn) -> do
@@ -269,9 +406,11 @@ instance MonadTrans (PQ schema schema) where
269406instance MonadBase b m => MonadBase b (PQ schema schema m) where
270407 liftBase = lift . liftBase
271408
409+-- | A snapshot of the state of a `PQ` computation.
272410type PQRun schema =
273411 forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)
274412
413+-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
275414pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
276415pqliftWith f = PQ $ \ conn ->
277416 fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
@@ -282,28 +421,22 @@ instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
282421 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
283422 restoreM = PQ . const . restoreM
284423
285−connectdb :: MonadBase IO io => ByteString -> io (Connection schema)
286−connectdb = fmap Connection . liftBase . LibPQ.connectdb
287−
288−finish :: MonadBase IO io => Connection schema -> io ()
289−finish = liftBase . LibPQ.finish . unConnection
290−
291−withConnection
292− :: forall schema io x
293− . MonadBaseControl IO io
294− => ByteString
295− -> (Connection schema -> io x)
296− -> io x
297−withConnection connString = bracket (connectdb connString) finish
298−
299−newtype Result (xs :: ColumnsType)
424+-- | Encapsulates the result of a squeal command run by @LibPQ@.
425+-- `Result`s are parameterized by a `ColumnsType` describing the column names
426+-- and their types.
427+newtype Result (columns :: ColumnsType)
300428 = Result { unResult :: LibPQ.Result }
301429
430+-- | Just newtypes around a `CInt`
302431newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
303432
304−newtype ColumnNumber n cs c =
433+-- | In addition to being newtypes around a `CInt`, a `ColumnNumber` is
434+-- parameterized by a `Nat`ural number and acts as an index into a row.
435+newtype ColumnNumber (n :: Nat) (cs :: [k]) (c :: k) =
305436 UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }
306437
438+-- | >>> getColumnNumber (columnNumber @5)
439+-- 5
307440class KnownNat n => HasColumnNumber n columns column
308441 | n columns -> column where
309442 columnNumber :: ColumnNumber n columns column
@@ -314,11 +447,13 @@ instance {-# OVERLAPPABLE #-}
314447 (KnownNat n, HasColumnNumber (n-1) columns column)
315448 => HasColumnNumber n (column' : columns) column
316449
450+-- | Get a single value corresponding to a given row and column number
451+-- from a `Result`.
317452getValue
318453 :: (FromColumnValue colty y, MonadBase IO io)
319− => RowNumber
320− -> ColumnNumber n columns colty
321− -> Result columns
454+ => RowNumber -- ^ row
455+ -> ColumnNumber n columns colty -- ^ col
456+ -> Result columns -- ^ result
322457 -> io y
323458getValue
324459 (RowNumber r)
@@ -331,47 +466,50 @@ getValue
331466 <> show numRows
332467 LibPQ.getvalue result r c
333468
469+-- | Get a row corresponding to a given row number from a `Result`.
334470getRow
335471 :: (FromRow columns y, MonadBase IO io)
336− => RowNumber -> Result columns -> io y
472+ => RowNumber
473+ -- ^ row
474+ -> Result columns
475+ -- ^ result
476+ -> io y
337477getRow (RowNumber r) (Result result :: Result columns) = liftBase $do
338478 numRows <- LibPQ.ntuples result
339479 when (numRows < r) $ error $
340480 "getRow: expected at least " <> show r <> "rows but only saw "
341481 <> show numRows
342482 let len = fromIntegral (lengthSList (Proxy @columns))
343− numCols <- LibPQ.nfields result
344− when (numCols /= len) $ error $
345− "getRow: expected at least " <> show len <> "columns but only saw "
346− <> show numCols
347483 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
348484 case fromList row' of
349485 Nothing -> error "getRow: found unexpected length"
350486 Just row -> return $ fromRow @columns row
351487
488+-- | Intended to be used for unfolding in streaming libraries, `nextRow`
489+-- takes a total number of rows (which can be found with `LibPQ.ntuples`)
490+-- and a `Result` and given a row number if it's too large returns `Nothing`,
491+-- otherwise returning the row along with the next row number.
352492nextRow
353493 :: (FromRow columns y, MonadBase IO io)
354− => Result columns -> RowNumber -> io (Maybe (RowNumber,y))
355−nextRow (Result result :: Result columns) (RowNumber r) = liftBase $ do
356− numRows <- LibPQ.ntuples result -- todo: cache this
357− if numRows < r then return Nothing else do
494+ => RowNumber -- ^ total number of rows
495+ -> Result columns -- ^ result
496+ -> RowNumber -- ^ row number
497+ -> io (Maybe (RowNumber,y))
498+nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)
499+ = liftBase $ if r >= total then return Nothing else do
358500 let len = fromIntegral (lengthSList (Proxy @columns))
359− numCols <- LibPQ.nfields result -- todo: cache this
360− when (numCols /= len) $ error $
361− "nextRow: expected at least " <> show len <> "columns but only saw "
362− <> show numCols
363501 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
364502 case fromList row' of
365503 Nothing -> error "nextRow: found unexpected length"
366504 Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)
367505
368−getRows :: (FromRow columns y, MonadBase IO io) => Result columns -> io [y]
506+-- | Get all rows from a `Result`.
507+getRows
508+ :: (FromRow columns y, MonadBase IO io)
509+ => Result columns -- ^ result
510+ -> io [y]
369511getRows (Result result :: Result columns) = liftBase $ do
370512 let len = fromIntegral (lengthSList (Proxy @columns))
371− numCols <- LibPQ.nfields result
372− when (numCols /= len) $ error $
373− "getRow: expected at least " <> show len <> "columns but only saw "
374− <> show numCols
375513 numRows <- LibPQ.ntuples result
376514 for [0 .. numRows - 1] $ \ r -> do
377515 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
@@ -379,22 +517,21 @@ getRows (Result result :: Result columns) = liftBase $ do
379517 Nothing -> error "getRows: found unexpected length"
380518 Just row -> return $ fromRow @columns row
381519
382−getRowMaybe
520+-- | Get the first row if possible from a `Result`.
521+firstRow
383522 :: (FromRow columns y, MonadBase IO io)
384− => RowNumber -> Result columns -> io (Maybe y)
385−getRowMaybe (RowNumber r) (Result result :: Result columns) = liftBase $do
523+ => Result columns -- ^ result
524+ -> io (Maybe y)
525+firstRow (Result result :: Result columns) = liftBase $ do
386526 numRows <- LibPQ.ntuples result
387− if numRows < r then return Nothing else do
527+ if numRows <= 0 then return Nothing else do
388528 let len = fromIntegral (lengthSList (Proxy @columns))
389− numCols <- LibPQ.nfields result
390− when (numCols /= len) $ error $
391− "getRow: expected at least " <> show len <> "columns but only saw "
392− <> show numCols
393− row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
529+ row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]
394530 case fromList row' of
395− Nothing -> error "getRow: found unexpected length"
531+ Nothing -> error "firstRow: found unexpected length"
396532 Just row -> return . Just $ fromRow @columns row
397533
534+-- | Lifts actions on results from `LibPQ`.
398535liftResult
399536 :: MonadBase IO io
400537 => (LibPQ.Result -> IO x)