22b486a · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

K Connection schema

22b486aEitan Chatav9 years ago

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+38−38

compare with dev

unifiedsplit

@@ -33,8 +33,7 @@ a `MonadPQ` constraint for running a `Manipulation` or `Query`.

34module Squeal.PostgreSQL.PQ

35 ( -- * Connection

36− Connection (Connection, unConnection)

37− , connectdb

36+ connectdb

38 , finish

37 , finish

39 , withConnection

38 , withConnection

40 -- * PQ

39 -- * PQ

@@ -62,6 +61,8 @@ module Squeal.PostgreSQL.PQ

62 , nextRow

61 , nextRow

63 , firstRow

62 , firstRow

64 , liftResult

63 , liftResult

64+ -- * Re-export

65+ , LibPQ.Connection

65 ) where

66 ) where

67import Control.Exception.Lifted

68import Control.Exception.Lifted

@@ -100,11 +101,6 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict

100import qualified Control.Monad.Trans.RWS.Lazy as Lazy

101import qualified Control.Monad.Trans.RWS.Lazy as Lazy

101import qualified Control.Monad.Trans.RWS.Strict as Strict

102import qualified Control.Monad.Trans.RWS.Strict as Strict

102

103

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.

104{- | Makes a new connection to the database server.

109

105

110This function opens a new database connection using the parameters taken

106This function opens a new database connection using the parameters taken

@@ -134,19 +130,19 @@ connectdb

134 :: forall schema io

130 :: forall schema io

135 . MonadBase IO io

131 . MonadBase IO io

136 => ByteString -- ^ conninfo

132 => ByteString -- ^ conninfo

137− -> io (Connection schema)

133+ -> io (K LibPQ.Connection schema)

138−connectdb = fmap Connection . liftBase . LibPQ.connectdb

134+connectdb = fmap K . liftBase . LibPQ.connectdb

139

135

140-- | Closes the connection to the server.

136-- | Closes the connection to the server.

141−finish :: MonadBase IO io => Connection schema -> io ()

137+finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()

142−finish = liftBase . LibPQ.finish . unConnection

138+finish = liftBase . LibPQ.finish . unK

143

139

144-- | Do `connectdb` and `finish` before and after a computation.

140-- | Do `connectdb` and `finish` before and after a computation.

145withConnection

141withConnection

146 :: forall schema0 schema1 io x

142 :: forall schema0 schema1 io x

147 . MonadBaseControl IO io

143 . MonadBaseControl IO io

148 => ByteString

144 => ByteString

149− -> (Connection schema0 -> io (x, Connection schema1))

145+ -> (K LibPQ.Connection schema0 -> io (x, K LibPQ.Connection schema1))

150 -> io x

146 -> io x

151withConnection connString action = do

147withConnection connString action = do

152 (x, _conn) <- bracket (connectdb connString) finish action

148 (x, _conn) <- bracket (connectdb connString) finish action

@@ -159,16 +155,20 @@ newtype PQ

159 (schema1 :: TablesType)

155 (schema1 :: TablesType)

160 (m :: Type -> Type)

156 (m :: Type -> Type)

161 (x :: Type) =

157 (x :: Type) =

162− PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }

158+ PQ { runPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }

163− deriving Functor

159+

160+instance Monad m => Functor (PQ schema0 schema1 m) where

161+ fmap f (PQ pq) = PQ $ \ conn -> do

162+ K x <- pq conn

163+ return $ K (f x)

164

165-- | Run a `PQ` and discard the result but keep the `Connection`.

166execPQ

167 :: Functor m

168 => PQ schema0 schema1 m x

169− -> Connection schema0

169+ -> K LibPQ.Connection schema0

170− -> m (Connection schema1)

170+ -> m (K LibPQ.Connection schema1)

171−execPQ (PQ pq) = fmap snd . pq

171+execPQ (PQ pq) conn = fmap (mapKK (\ _ -> unK conn)) $ pq conn

172

173-- | indexed analog of `<*>`

174pqAp

@@ -177,9 +177,9 @@ pqAp

177 -> PQ schema1 schema2 m x

178 -> PQ schema0 schema2 m y

179pqAp (PQ f) (PQ x) = PQ $ \ conn -> do

180− (f', conn') <- f conn

180+ K f' <- f conn

181− (x', conn'') <- x conn'

181+ K x' <- x (K (unK conn))

182− return (f' x', conn'')

182+ return $ K (f' x')

183

184-- | indexed analog of `join`

185pqJoin

@@ -194,8 +194,8 @@ pqBind

194 -> PQ schema0 schema1 m x

195 -> PQ schema0 schema2 m y

196pqBind f (PQ x) = PQ $ \ conn -> do

197− (x', conn') <- x conn

197+ K x' <- x conn

198− runPQ (f x') conn'

198+ runPQ (f x') (K (unK conn))

199

200-- | indexed analog of flipped `>>`

201pqThen

@@ -212,12 +212,12 @@ define

212 :: MonadBase IO io

213 => Definition schema0 schema1

214 -> PQ schema0 schema1 io (Result '[])

215−define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do

215+define (UnsafeDefinition q) = PQ $ \ (K conn) -> do

216 resultMaybe <- liftBase $ LibPQ.exec conn q

217 case resultMaybe of

218 Nothing -> error

219 "define: LibPQ.exec returned no results"

220− Just result -> return (Result result, Connection conn)

220+ Just result -> return $ K (Result result)

221

222-- | Chain together `define` actions.

223thenDefine

@@ -342,7 +342,7 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

342

343 manipulateParams

344 (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =

345− PQ $ \ (Connection conn) -> do

345+ PQ $ \ (K conn) -> do

346 let

347 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

348 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

@@ -350,11 +350,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

350 case resultMaybe of

351 Nothing -> error

352 "manipulateParams: LibPQ.execParams returned no results"

353− Just result -> return (Result result, Connection conn)

353+ Just result -> return $ K (Result result)

354

355 traversePrepared

356 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

357− PQ $ \ (Connection conn) -> liftBase $ do

357+ PQ $ \ (K conn) -> liftBase $ do

358 let temp = "temporary_statement"

359 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

360 case prepResultMaybe of

@@ -381,11 +381,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

381 status <- LibPQ.resultStatus deallocResult

382 unless (status == LibPQ.CommandOk) . error $

383 "traversePrepared: DEALLOCATE status " <> show status

384− return (results, Connection conn)

384+ return (K results)

385

386 traversePrepared_

387 (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =

388− PQ $ \ (Connection conn) -> liftBase $ do

388+ PQ $ \ (K conn) -> liftBase $ do

389 let temp = "temporary_statement"

390 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

391 case prepResultMaybe of

@@ -412,11 +412,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

412 status <- LibPQ.resultStatus deallocResult

413 unless (status == LibPQ.CommandOk) . error $

414 "traversePrepared: DEALLOCATE status " <> show status

415− return ((), Connection conn)

415+ return (K ())

416

417− liftPQ pq = PQ $ \ (Connection conn) -> do

417+ liftPQ pq = PQ $ \ (K conn) -> do

418 y <- liftBase $ pq conn

419− return (y, Connection conn)

419+ return (K y)

420

421instance MonadPQ schema m => MonadPQ schema (IdentityT m)

422instance MonadPQ schema m => MonadPQ schema (ReaderT r m)

@@ -432,7 +432,7 @@ instance MonadPQ schema m => MonadPQ schema (ContT r m)

432instance MonadPQ schema m => MonadPQ schema (ListT m)

433

434instance Monad m => Applicative (PQ schema schema m) where

435− pure x = PQ $ \ conn -> pure (x, conn)

435+ pure x = PQ $ \ _conn -> pure (K x)

436 (<*>) = pqAp

437

438instance Monad m => Monad (PQ schema schema m) where

@@ -440,24 +440,24 @@ instance Monad m => Monad (PQ schema schema m) where

440 (>>=) = flip pqBind

441

442instance MonadTrans (PQ schema schema) where

443− lift m = PQ $ \ conn -> do

443+ lift m = PQ $ \ _conn -> do

444 x <- m

445− return (x, conn)

445+ return (K x)

446

447instance MonadBase b m => MonadBase b (PQ schema schema m) where

448 liftBase = lift . liftBase

449

450-- | A snapshot of the state of a `PQ` computation.

451type PQRun schema =

452− forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)

452+ forall m x. Monad m => PQ schema schema m x -> m (K x schema)

453

454-- | Helper function in defining `MonadBaseControl` instance for `PQ`.

455pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

456pqliftWith f = PQ $ \ conn ->

457− fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)

457+ fmap K (f $ \ pq -> runPQ pq conn)

458

459instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where

460− type StM (PQ schema schema m) x = StM m (x, Connection schema)

460+ type StM (PQ schema schema m) x = StM m (K x schema)

461 liftBaseWith f =

462 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

463 restoreM = PQ . const . restoreM

squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+11−6

@@ -1,11 +1,13 @@

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#-}

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

19import Squeal.PostgreSQL.PQ

22import Squeal.PostgreSQL.PQ

23+import Squeal.PostgreSQL.Schema

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

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+ (result, _ :: K Connection 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+ (result, _ :: K Connection 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 Connection 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+ (result, _ :: K Connection schema) <- flip runPQ conn $

62 liftPQ m

67 liftPQ m

63 return result

68 return result