-
Notifications
You must be signed in to change notification settings - Fork 55
/
IO.hs
157 lines (142 loc) · 5.39 KB
/
IO.hs
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
-- |
-- An API of low-level IO operations.
module Hasql.IO where
import Hasql.Commands qualified as Commands
import Hasql.Decoders.Result qualified as ResultDecoders
import Hasql.Decoders.Results qualified as ResultsDecoders
import Hasql.Encoders.Params qualified as ParamsEncoders
import Hasql.Errors
import Hasql.LibPq14 qualified as LibPQ
import Hasql.Prelude
import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry
{-# INLINE acquireConnection #-}
acquireConnection :: ByteString -> IO LibPQ.Connection
acquireConnection =
LibPQ.connectdb
{-# INLINE acquirePreparedStatementRegistry #-}
acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry
acquirePreparedStatementRegistry =
PreparedStatementRegistry.new
{-# INLINE releaseConnection #-}
releaseConnection :: LibPQ.Connection -> IO ()
releaseConnection connection =
LibPQ.finish connection
{-# INLINE checkConnectionStatus #-}
checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString))
checkConnectionStatus c =
do
s <- LibPQ.status c
case s of
LibPQ.ConnectionOk -> return Nothing
_ -> fmap Just (LibPQ.errorMessage c)
{-# INLINE checkServerVersion #-}
checkServerVersion :: LibPQ.Connection -> IO (Maybe Int)
checkServerVersion c =
fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c)
{-# INLINE getIntegerDatetimes #-}
getIntegerDatetimes :: LibPQ.Connection -> IO Bool
getIntegerDatetimes c =
fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes"
where
decodeValue =
\case
Just "on" -> True
_ -> False
{-# INLINE initConnection #-}
initConnection :: LibPQ.Connection -> IO ()
initConnection c =
void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning))
{-# INLINE getResults #-}
getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a)
getResults connection integerDatetimes decoder =
{-# SCC "getResults" #-}
(<*) <$> get <*> dropRemainders
where
get =
ResultsDecoders.run decoder connection integerDatetimes
dropRemainders =
ResultsDecoders.run ResultsDecoders.dropRemainders connection integerDatetimes
{-# INLINE getPreparedStatementKey #-}
getPreparedStatementKey ::
LibPQ.Connection ->
PreparedStatementRegistry.PreparedStatementRegistry ->
ByteString ->
[LibPQ.Oid] ->
IO (Either CommandError ByteString)
getPreparedStatementKey connection registry template oidList =
{-# SCC "getPreparedStatementKey" #-}
PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry
where
localKey =
PreparedStatementRegistry.LocalKey template oidList
onNewRemoteKey key =
do
sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))
fmap resultsMapping $ getResults connection undefined (resultsDecoder sent)
where
resultsDecoder sent =
if sent
then ResultsDecoders.single ResultDecoders.noResult
else ResultsDecoders.clientError
resultsMapping =
\case
Left x -> (False, Left x)
Right _ -> (True, Right key)
onOldRemoteKey key =
pure (pure key)
{-# INLINE checkedSend #-}
checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ())
checkedSend connection send =
send >>= \case
False -> fmap (Left . ClientError) $ LibPQ.errorMessage connection
True -> pure (Right ())
{-# INLINE sendPreparedParametricStatement #-}
sendPreparedParametricStatement ::
LibPQ.Connection ->
PreparedStatementRegistry.PreparedStatementRegistry ->
Bool ->
ByteString ->
ParamsEncoders.Params a ->
a ->
IO (Either CommandError ())
sendPreparedParametricStatement connection registry integerDatetimes template encoder input =
runExceptT $ do
key <- ExceptT $ getPreparedStatementKey connection registry template oidList
ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary
where
(oidList, valueAndFormatList) =
ParamsEncoders.compilePreparedStatementData encoder integerDatetimes input
{-# INLINE sendUnpreparedParametricStatement #-}
sendUnpreparedParametricStatement ::
LibPQ.Connection ->
Bool ->
ByteString ->
ParamsEncoders.Params a ->
a ->
IO (Either CommandError ())
sendUnpreparedParametricStatement connection integerDatetimes template encoder input =
checkedSend connection
$ LibPQ.sendQueryParams
connection
template
(ParamsEncoders.compileUnpreparedStatementData encoder integerDatetimes input)
LibPQ.Binary
{-# INLINE sendParametricStatement #-}
sendParametricStatement ::
LibPQ.Connection ->
Bool ->
PreparedStatementRegistry.PreparedStatementRegistry ->
ByteString ->
ParamsEncoders.Params a ->
Bool ->
a ->
IO (Either CommandError ())
sendParametricStatement connection integerDatetimes registry template encoder prepared params =
{-# SCC "sendParametricStatement" #-}
if prepared
then sendPreparedParametricStatement connection registry integerDatetimes template encoder params
else sendUnpreparedParametricStatement connection integerDatetimes template encoder params
{-# INLINE sendNonparametricStatement #-}
sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either CommandError ())
sendNonparametricStatement connection sql =
checkedSend connection $ LibPQ.sendQuery connection sql