/
App.hs
237 lines (200 loc) · 10.4 KB
/
App.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
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
{-|
Module : PostgREST.App
Description : PostgREST main application
This module is in charge of mapping HTTP requests to PostgreSQL queries.
Some of its functionality includes:
- Mapping HTTP request methods to proper SQL statements. For example, a GET request is translated to executing a SELECT query in a read-only TRANSACTION.
- Producing HTTP Headers according to RFCs.
- Content Negotiation
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module PostgREST.App
( SignalHandlerInstaller
, SocketRunner
, postgrest
, run
) where
import Control.Monad.Except (liftEither)
import Data.Either.Combinators (mapLeft, whenLeft)
import Data.Maybe (fromJust)
import Data.String (IsString (..))
import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
setServerName)
import System.Posix.Types (FileMode)
import qualified Data.HashMap.Strict as HM
import qualified Hasql.Pool as SQL
import qualified Hasql.Transaction.Sessions as SQL
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified PostgREST.Admin as Admin
import qualified PostgREST.ApiRequest as ApiRequest
import qualified PostgREST.ApiRequest.Types as ApiRequestTypes
import qualified PostgREST.AppState as AppState
import qualified PostgREST.Auth as Auth
import qualified PostgREST.Cors as Cors
import qualified PostgREST.Error as Error
import qualified PostgREST.Logger as Logger
import qualified PostgREST.Plan as Plan
import qualified PostgREST.Query as Query
import qualified PostgREST.Response as Response
import PostgREST.ApiRequest (Action (..), ApiRequest (..),
Mutation (..), Target (..))
import PostgREST.AppState (AppState)
import PostgREST.Auth (AuthResult (..))
import PostgREST.Config (AppConfig (..))
import PostgREST.Config.PgVersion (PgVersion (..))
import PostgREST.Error (Error)
import PostgREST.Query (DbHandler)
import PostgREST.SchemaCache (SchemaCache (..))
import PostgREST.SchemaCache.Routine (Routine (..))
import PostgREST.Version (prettyVersion)
import Protolude hiding (Handler)
type Handler = ExceptT Error
type SignalHandlerInstaller = AppState -> IO()
type SocketRunner = Warp.Settings -> Wai.Application -> FileMode -> FilePath -> IO()
run :: SignalHandlerInstaller -> Maybe SocketRunner -> AppState -> IO ()
run installHandlers maybeRunWithSocket appState = do
conf@AppConfig{..} <- AppState.getConfig appState
AppState.connectionWorker appState -- Loads the initial SchemaCache
installHandlers appState
-- reload schema cache + config on NOTIFY
AppState.runListener conf appState
Admin.runAdmin conf appState $ serverSettings conf
let app = postgrest conf appState (AppState.connectionWorker appState)
case configServerUnixSocket of
Just socket ->
-- run the postgrest application with user defined socket. Only for UNIX systems
case maybeRunWithSocket of
Just runWithSocket -> do
AppState.logWithZTime appState $ "Listening on unix socket " <> show socket
runWithSocket (serverSettings conf) app configServerUnixSocketMode socket
Nothing ->
panic "Cannot run with unix socket on non-unix platforms."
Nothing ->
do
AppState.logWithZTime appState $ "Listening on port " <> show configServerPort
Warp.runSettings (serverSettings conf) app
serverSettings :: AppConfig -> Warp.Settings
serverSettings AppConfig{..} =
defaultSettings
& setHost (fromString $ toS configServerHost)
& setPort configServerPort
& setServerName ("postgrest/" <> prettyVersion)
-- | PostgREST application
postgrest :: AppConfig -> AppState.AppState -> IO () -> Wai.Application
postgrest conf appState connWorker =
Response.traceHeaderMiddleware conf .
Cors.middleware .
Auth.middleware appState .
Logger.middleware (configLogLevel conf) $
-- fromJust can be used, because the auth middleware will **always** add
-- some AuthResult to the vault.
\req respond -> case fromJust $ Auth.getResult req of
Left err -> respond $ Error.errorResponseFor err
Right authResult -> do
appConf <- AppState.getConfig appState -- the config must be read again because it can reload
maybeSchemaCache <- AppState.getSchemaCache appState
pgVer <- AppState.getPgVersion appState
let
eitherResponse :: IO (Either Error Wai.Response)
eitherResponse =
runExceptT $ postgrestResponse appState appConf maybeSchemaCache pgVer authResult req
response <- either Error.errorResponseFor identity <$> eitherResponse
-- Launch the connWorker when the connection is down. The postgrest
-- function can respond successfully (with a stale schema cache) before
-- the connWorker is done.
when (Response.isServiceUnavailable response) connWorker
resp <- do
delay <- AppState.getRetryNextIn appState
return $ Response.addRetryHint delay response
respond resp
postgrestResponse
:: AppState.AppState
-> AppConfig
-> Maybe SchemaCache
-> PgVersion
-> AuthResult
-> Wai.Request
-> Handler IO Wai.Response
postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@AuthResult{..} req = do
sCache <-
case maybeSchemaCache of
Just sCache ->
return sCache
Nothing ->
throwError Error.NoSchemaCacheError
body <- lift $ Wai.strictRequestBody req
apiRequest <-
liftEither . mapLeft Error.ApiRequestError $
ApiRequest.userApiRequest conf req body
Response.optionalRollback conf apiRequest $
handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache
runDbHandler :: AppState.AppState -> Maybe Text -> SQL.Mode -> Bool -> Bool -> DbHandler b -> Handler IO b
runDbHandler appState isoLvl mode authenticated prepared handler = do
dbResp <- lift $ do
let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction
res <- AppState.usePool appState . transaction (toIsolationLevel isoLvl) mode $ runExceptT handler
whenLeft res (\case
SQL.AcquisitionTimeoutUsageError -> AppState.debounceLogAcquisitionTimeout appState -- this can happen rapidly for many requests, so we debounce
_ -> pure ())
return res
resp <-
liftEither . mapLeft Error.PgErr $
mapLeft (Error.PgError authenticated) dbResp
liftEither resp
where
toIsolationLevel = \case
Nothing -> SQL.ReadCommitted
Just "repeatable read" -> SQL.RepeatableRead
Just "serializable" -> SQL.Serializable
_ -> SQL.ReadCommitted
handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> Handler IO Wai.Response
handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache =
case (iAction, iTarget) of
(ActionRead headersOnly, TargetIdent identifier) -> do
wrPlan <- liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq
resultSet <- runQuery roleIsoLvl (Plan.wrTxMode wrPlan) $ Query.readQuery wrPlan conf apiReq
return $ Response.readResponse headersOnly identifier apiReq resultSet
(ActionMutate MutationCreate, TargetIdent identifier) -> do
mrPlan <- liftEither $ Plan.mutateReadPlan MutationCreate apiReq identifier conf sCache
resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.createQuery mrPlan apiReq conf
return $ Response.createResponse identifier mrPlan apiReq resultSet
(ActionMutate MutationUpdate, TargetIdent identifier) -> do
mrPlan <- liftEither $ Plan.mutateReadPlan MutationUpdate apiReq identifier conf sCache
resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.updateQuery mrPlan apiReq conf
return $ Response.updateResponse apiReq resultSet
(ActionMutate MutationSingleUpsert, TargetIdent identifier) -> do
mrPlan <- liftEither $ Plan.mutateReadPlan MutationSingleUpsert apiReq identifier conf sCache
resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.singleUpsertQuery mrPlan apiReq conf
return $ Response.singleUpsertResponse apiReq resultSet
(ActionMutate MutationDelete, TargetIdent identifier) -> do
mrPlan <- liftEither $ Plan.mutateReadPlan MutationDelete apiReq identifier conf sCache
resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.deleteQuery mrPlan apiReq conf
return $ Response.deleteResponse apiReq resultSet
(ActionInvoke invMethod, TargetProc identifier _) -> do
cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod
resultSet <- runQuery (roleIsoLvl <|> pdIsoLvl (Plan.crProc cPlan))(Plan.crTxMode cPlan) $ Query.invokeQuery (Plan.crProc cPlan) cPlan apiReq conf pgVer
return $ Response.invokeResponse invMethod (Plan.crProc cPlan) apiReq resultSet
(ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
oaiResult <- runQuery roleIsoLvl Plan.inspectPlanTxMode $ Query.openApiQuery sCache pgVer conf tSchema
return $ Response.openApiResponse headersOnly oaiResult conf sCache iSchema iNegotiatedByProfile
(ActionInfo, TargetIdent identifier) ->
return $ Response.infoIdentResponse identifier sCache
(ActionInfo, TargetProc identifier _) -> do
cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq ApiRequest.InvHead
return $ Response.infoProcResponse (Plan.crProc cPlan)
(ActionInfo, TargetDefaultSpec _) ->
return Response.infoRootResponse
_ ->
-- This is unreachable as the ApiRequest.hs rejects it before
-- TODO Refactor the Action/Target types to remove this line
throwError $ Error.ApiRequestError ApiRequestTypes.NotFound
where
roleSettings = fromMaybe mempty (HM.lookup authRole $ configRoleSettings conf)
roleIsoLvl = decodeUtf8 <$> HM.lookup "default_transaction_isolation" roleSettings
runQuery isoLvl mode query =
runDbHandler appState isoLvl mode authenticated prepared $ do
Query.setPgLocals conf authClaims authRole (HM.toList roleSettings) apiReq pgVer
Query.runPreReq conf
query