-
Notifications
You must be signed in to change notification settings - Fork 20
/
PostgreSQL.purs
333 lines (299 loc) · 9.86 KB
/
PostgreSQL.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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
module Database.PostgreSQL
( module Row
, module Value
, PGError(..)
, PGErrorDetail
, Database
, PoolConfiguration
, Pool
, Connection
, Query(..)
, newPool
, withConnection
, withTransaction
, defaultPoolConfiguration
, command
, execute
, query
, scalar
) where
import Prelude
import Control.Monad.Error.Class (catchError, throwError)
import Data.Array (head)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), either, hush)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.String (Pattern(..))
import Data.String as String
import Data.Traversable (traverse)
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), fromSQLRow, toSQLRow)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect (Effect)
import Effect.Aff (Aff, bracket)
import Effect.Aff.Compat (EffectFnAff, fromEffectFnAff)
import Effect.Class (liftEffect)
import Effect.Exception (Error)
import Foreign (Foreign)
type Database = String
-- | PostgreSQL connection pool configuration.
type PoolConfiguration =
{ database :: Database
, host :: Maybe String
, idleTimeoutMillis :: Maybe Int
, max :: Maybe Int
, password :: Maybe String
, port :: Maybe Int
, user :: Maybe String
}
defaultPoolConfiguration :: Database -> PoolConfiguration
defaultPoolConfiguration database =
{ database
, host: Nothing
, idleTimeoutMillis: Nothing
, max: Nothing
, password: Nothing
, port: Nothing
, user: Nothing
}
-- | PostgreSQL connection pool.
foreign import data Pool :: Type
-- | PostgreSQL connection.
foreign import data Connection :: Type
-- | PostgreSQL query with parameter (`$1`, `$2`, …) and return types.
newtype Query i o = Query String
derive instance newtypeQuery :: Newtype (Query i o) _
-- | Create a new connection pool.
newPool :: PoolConfiguration -> Effect Pool
newPool cfg =
ffiNewPool $ cfg'
where
cfg' =
{ user: toNullable cfg.user
, password: toNullable cfg.password
, host: toNullable cfg.host
, port: toNullable cfg.port
, database: cfg.database
, max: toNullable cfg.max
, idleTimeoutMillis: toNullable cfg.idleTimeoutMillis
}
-- | Configuration which we actually pass to FFI.
type PoolConfiguration' =
{ user :: Nullable String
, password :: Nullable String
, host :: Nullable String
, port :: Nullable Int
, database :: String
, max :: Nullable Int
, idleTimeoutMillis :: Nullable Int
}
foreign import ffiNewPool
:: PoolConfiguration'
-> Effect Pool
-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
:: forall a
. Pool
-> (Either PGError Connection -> Aff a)
-> Aff a
withConnection p k =
bracket (connect p) cleanup run
where
cleanup (Left _) = pure unit
cleanup (Right { done }) = liftEffect done
run (Left err) = k (Left err)
run (Right { connection }) = k (Right connection)
connect
:: Pool
-> Aff (Either PGError ConnectResult)
connect =
fromEffectFnAff
<<< ffiConnect
{ nullableLeft: toNullable <<< map Left <<< convertError
, right: Right
}
type ConnectResult =
{ connection :: Connection
, done :: Effect Unit
}
foreign import ffiConnect
:: forall a
. { nullableLeft :: Error -> Nullable (Either PGError ConnectResult)
, right :: a -> Either PGError ConnectResult
}
-> Pool
-> EffectFnAff (Either PGError ConnectResult)
-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in the Aff context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
:: forall a
. Connection
-> Aff a
-> Aff (Either PGError a)
withTransaction conn action =
begin >>= case _ of
Nothing → do
a ← action `catchError` \jsErr → do
void $ rollback
throwError jsErr
commit >>= case _ of
Just pgError → pure (Left pgError)
Nothing → pure (Right a)
Just pgError → pure (Left pgError)
where
begin = execute conn (Query "BEGIN TRANSACTION") Row0
commit = execute conn (Query "COMMIT TRANSACTION") Row0
rollback = execute conn (Query "ROLLBACK TRANSACTION") Row0
-- | Execute a PostgreSQL query and discard its results.
execute
:: forall i o
. (ToSQLRow i)
=> Connection
-> Query i o
-> i
-> Aff (Maybe PGError)
execute conn (Query sql) values =
hush <<< either Right Left <$> unsafeQuery conn sql (toSQLRow values)
-- | Execute a PostgreSQL query and return its results.
query
:: forall i o
. ToSQLRow i
=> FromSQLRow o
=> Connection
-> Query i o
-> i
-> Aff (Either PGError (Array o))
query conn (Query sql) values = do
r <- unsafeQuery conn sql (toSQLRow values)
pure $ r >>= _.rows >>> traverse (fromSQLRow >>> lmap ConversionError)
-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
:: forall i o
. ToSQLRow i
=> FromSQLValue o
=> Connection
-> Query i (Row1 o)
-> i
-> Aff (Either PGError (Maybe o))
scalar conn sql values =
query conn sql values <#> map (head >>> map (case _ of Row1 a -> a))
-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
:: forall i
. ToSQLRow i
=> Connection
-> Query i Int
-> i
-> Aff (Either PGError Int)
command conn (Query sql) values =
map _.rowCount <$> unsafeQuery conn sql (toSQLRow values)
type QueryResult =
{ rows :: Array (Array Foreign)
, rowCount :: Int
}
unsafeQuery
:: Connection
-> String
-> Array Foreign
-> Aff (Either PGError QueryResult)
unsafeQuery c s =
fromEffectFnAff <<< ffiUnsafeQuery p c s
where
p =
{ nullableLeft: toNullable <<< map Left <<< convertError
, right: Right
}
foreign import ffiUnsafeQuery
:: { nullableLeft :: Error -> Nullable (Either PGError QueryResult)
, right :: QueryResult -> Either PGError QueryResult
}
-> Connection
-> String
-> Array Foreign
-> EffectFnAff (Either PGError QueryResult)
data PGError
= ConnectionError String
| ConversionError String
| InternalError PGErrorDetail
| OperationalError PGErrorDetail
| ProgrammingError PGErrorDetail
| IntegrityError PGErrorDetail
| DataError PGErrorDetail
| NotSupportedError PGErrorDetail
| QueryCanceledError PGErrorDetail
| TransactionRollbackError PGErrorDetail
derive instance eqPGError :: Eq PGError
derive instance genericPGError :: Generic PGError _
instance showPGError :: Show PGError where
show = genericShow
type PGErrorDetail =
{ severity :: String
, code :: String
, message :: String
, detail :: String
, hint :: String
, position :: String
, internalPosition :: String
, internalQuery :: String
, where_ :: String
, schema :: String
, table :: String
, column :: String
, dataType :: String
, constraint :: String
, file :: String
, line :: String
, routine :: String
}
foreign import ffiSQLState :: Error -> Nullable String
foreign import ffiErrorDetail :: Error -> PGErrorDetail
convertError :: Error -> Maybe PGError
convertError err =
case toMaybe $ ffiSQLState err of
Nothing -> Nothing
Just sqlState -> Just $ convert sqlState $ ffiErrorDetail err
where
convert :: String -> PGErrorDetail -> PGError
convert s =
if prefix "0A" s then NotSupportedError
else if prefix "20" s || prefix "21" s then ProgrammingError
else if prefix "22" s then DataError
else if prefix "23" s then IntegrityError
else if prefix "24" s || prefix "25" s then InternalError
else if prefix "26" s || prefix "27" s || prefix "28" s then OperationalError
else if prefix "2B" s || prefix "2D" s || prefix "2F" s then InternalError
else if prefix "34" s then OperationalError
else if prefix "38" s || prefix "39" s || prefix "3B" s then InternalError
else if prefix "3D" s || prefix "3F" s then ProgrammingError
else if prefix "40" s then TransactionRollbackError
else if prefix "42" s || prefix "44" s then ProgrammingError
else if s == "57014" then QueryCanceledError
else if prefix "5" s then OperationalError
else if prefix "F" s then InternalError
else if prefix "H" s then OperationalError
else if prefix "P" s then InternalError
else if prefix "X" s then InternalError
else const $ ConnectionError s
prefix :: String -> String -> Boolean
prefix p =
maybe false (_ == 0) <<< String.indexOf (Pattern p)
-- onIntegrityError :: forall a. PG a -> PG a -> PG a
-- onIntegrityError errorResult db =
-- catchError db handleError
-- where
-- handleError e =
-- case e of
-- IntegrityError _ -> errorResult
-- _ -> throwError e