-
Notifications
You must be signed in to change notification settings - Fork 0
/
Control.Monad.Postgres.Base.purs
156 lines (142 loc) · 6.88 KB
/
Control.Monad.Postgres.Base.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
module Control.Monad.Postgres.Base where
import Prelude
import Control.Alt (class Alt)
import Control.Alternative (class Plus)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, throwError)
import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, bracket, kill, never, uninterruptible)
import Control.Monad.Morph (class MFunctor, class MMonad)
import Control.Monad.Postgres.Cursor (class MonadCursor, CursorT)
import Control.Monad.Postgres.Session (class MonadSession, SessionT, exec, exec_, query)
import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, ask, local, runReaderT)
import Control.Monad.Rec.Class (class MonadRec)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.Parallel (class Parallel, parallel, sequential)
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Postgres (RepT)
import Data.Postgres.Query (class AsQuery, asQuery)
import Data.Postgres.Raw (Raw)
import Data.Postgres.Result (class FromRow, fromRow)
import Data.Tuple.Nested ((/\))
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Aff.Postgres.Pool (Pool)
import Effect.Aff.Postgres.Pool as Pool
import Effect.Aff.Unlift (class MonadUnliftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Unlift (class MonadUnliftEffect)
import Prim.Row (class Union)
-- | Monad handling pool resource acquisition & release
-- |
-- | ```
-- | runPostgres
-- | {connectionString: "postgresql://postgres:postgres@localhost:5432"}
-- | $ session do
-- | exec_ "create table foo (bar int);"
-- | exec_ "insert into foo values (1);"
-- | res <- query "select * from foo"
-- | pure $ res == 1
-- | ```
-- |
-- | Is equivalent to:
-- | ```
-- | do
-- | pool <- liftEffect $ Pool.make {connectionString: "postgresql://postgres:postgres@localhost:5432"}
-- | finally (Pool.end pool) do
-- | client <- Pool.connect pool
-- | finally (liftEffect $ Pool.release pool client) do
-- | Client.exec_ "create table foo (bar int);" client
-- | Client.exec_ "insert into foo values (1);" client
-- | res <- Client.query "select * from foo" client
-- | pure $ res == 1
-- | ```
newtype PostgresT :: forall k. (k -> Type) -> k -> Type
newtype PostgresT m a = PostgresT (ReaderT Pool m a)
derive instance Newtype (PostgresT m a) _
derive newtype instance (Functor m) => Functor (PostgresT m)
derive newtype instance (Apply m) => Apply (PostgresT m)
derive newtype instance (Applicative m) => Applicative (PostgresT m)
derive newtype instance (Plus m) => Plus (PostgresT m)
derive newtype instance (Alt m) => Alt (PostgresT m)
derive newtype instance (Bind m) => Bind (PostgresT m)
derive newtype instance (Monad m) => Monad (PostgresT m)
derive newtype instance (MonadEffect m) => MonadEffect (PostgresT m)
derive newtype instance (MonadAff m) => MonadAff (PostgresT m)
derive newtype instance (MonadUnliftEffect m) => MonadUnliftEffect (PostgresT m)
derive newtype instance (MonadUnliftAff m) => MonadUnliftAff (PostgresT m)
derive newtype instance MonadRec m => MonadRec (PostgresT m)
derive newtype instance MonadTrans (PostgresT)
derive newtype instance (MonadThrow e m) => MonadThrow e (PostgresT m)
derive newtype instance (MonadError e m) => MonadError e (PostgresT m)
derive newtype instance (MonadFork f m) => MonadFork f (PostgresT m)
derive newtype instance MFunctor PostgresT
derive newtype instance MMonad PostgresT
instance (Apply m, Apply p, Parallel p m) => Parallel (PostgresT p) (PostgresT m) where
parallel = wrap <<< parallel <<< unwrap
sequential = wrap <<< sequential <<< unwrap
instance (Monad m, MonadKill e f m) => MonadKill e f (PostgresT m) where
kill a b = lift $ kill a b
instance (Monad m, MonadBracket e f (ReaderT Pool m), MonadBracket e f m) => MonadBracket e f (PostgresT m) where
bracket acq rel m = wrap $ bracket (unwrap acq) (\a b -> unwrap $ rel a b) (unwrap <<< m)
uninterruptible a = wrap $ uninterruptible $ unwrap a
never = lift $ never
instance Monad m => MonadAsk Pool (PostgresT m) where
ask = wrap ask
instance Monad m => MonadReader Pool (PostgresT m) where
local f m = wrap $ local f $ unwrap m
instance (MonadBracket e f m, MonadAff m) => MonadSession (PostgresT m) where
query = session <<< query
exec = session <<< exec
exec_ = session <<< exec_
-- | Typeclass generalizing `PostgresT`. Allows for dependency-injecting different
-- | implementations of the idea of a postgres connection.
-- |
-- | - `session` - Session monad (for `PostgresT` this is `SessionT`)
-- | - `cursor` - Cursor session monad (for `PostgresT` this is `CursorT`)
-- | - `ct` - Open type parameter for cursor type. Don't pin this to a concrete type.
class (MonadSession session, MonadCursor cursor ct) <= MonadPostgres m session cursor ct | m -> ct cursor session where
-- | Run a session in `m`.
session :: session ~> m
-- | Run a session in `m`, wrapped in a transaction.
-- |
-- | If any errors are raised, the transaction is rolled back and
-- | the error rethrown.
transaction :: session ~> m
-- | `cursor`, but using a custom deserialize function for the data
-- | yielded by the cursor
cursorWith :: forall q. AsQuery q => (Array Raw -> RepT ct) -> String -> q -> cursor ~> m
instance (MonadBracket e f m, MonadAff m, MonadSession (SessionT m), MonadCursor (CursorT t (SessionT m)) t) => MonadPostgres (PostgresT m) (SessionT m) (CursorT ct (SessionT m)) ct where
session m = do
pool <- ask
let
acq = liftAff $ Pool.connect pool
rel _ c = liftEffect $ Pool.release pool c
lift $ bracket acq rel (runReaderT m)
transaction m =
let
begin = void $ exec "begin;"
commit = m <* exec "commit;"
rollback e = exec "rollback;" *> throwError e
in
session $ begin *> catchError commit rollback
cursorWith f cur q m =
transaction do
q' <- liftEffect $ asQuery q
exec_ $ "declare " <> cur <> " cursor for (" <> (unwrap q').text <> ");"
runReaderT (unwrap m) (cur /\ f)
-- | Create a server-side cursor for a query in a transaction,
-- | and execute a `CursorT` with a view to the new cursor.
cursor :: forall @cursort t session cursor q a. MonadPostgres t session cursor cursort => AsQuery q => FromRow cursort => String -> q -> cursor a -> t a
cursor = cursorWith fromRow
-- | Execute a `PostgresT` using an existing connection pool.
-- |
-- | This will not invoke `Pool.end` after executing.
withPool :: forall m a. PostgresT m a -> Pool -> m a
withPool = runReaderT <<< unwrap
-- | Create a new connection pool from the provided config and execute
-- | the postgres monad, invoking `Effect.Aff.Postgres.Pool.end` afterwards.
runPostgres :: forall m a missing trash r e f. MonadBracket e f m => MonadAff m => Union r missing (Pool.Config trash) => Record r -> PostgresT m a -> m a
runPostgres cfg m =
let
acq = liftEffect $ Pool.make @r @missing @trash cfg
rel _ p = liftAff $ Pool.end p
in
bracket acq rel $ withPool m