Add admin port

Author: steve-chavez

src/PostgREST/App.hs

@@ -93,7 +93,6 @@ data RequestContext = RequestContext
   , ctxDbStructure :: DbStructure
   , ctxApiRequest  :: ApiRequest
   , ctxPgVersion   :: PgVersion
-  , ctxListenerOn  :: Bool
   }
 
 type Handler = ExceptT Error
@@ -115,6 +114,10 @@ run installHandlers maybeRunWithSocket appState = do
 
   let app = postgrest configLogLevel appState (connectionWorker appState)
 
+  whenJust configAdminServerPort $ \adminPort -> do
+    AppState.logWithZTime appState $ "Admin server listening on port " <> show adminPort
+    void . forkIO $ Warp.runSettings (serverSettings conf & setPort adminPort) $ adminApp appState
+
   case configServerUnixSocket of
     Just socket ->
       -- run the postgrest application with user defined socket. Only for UNIX systems
@@ -128,6 +131,9 @@ run installHandlers maybeRunWithSocket appState = do
       do
         AppState.logWithZTime appState $ "Listening on port " <> show configServerPort
         Warp.runSettings (serverSettings conf) app
+  where
+    whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
+    whenJust mg f = maybe (pure ()) f mg
 
 serverSettings :: AppConfig -> Warp.Settings
 serverSettings AppConfig{..} =
@@ -136,6 +142,16 @@ serverSettings AppConfig{..} =
     & setPort configServerPort
     & setServerName ("postgrest/" <> prettyVersion)
 
+adminApp :: AppState.AppState -> Wai.Application
+adminApp appState req respond =
+  case Wai.pathInfo req of
+    [] -> do
+      listenerOn <- AppState.getIsListenerOn appState
+      if listenerOn
+        then respond $ Wai.responseLBS HTTP.status200 [] mempty
+        else respond $ Wai.responseLBS HTTP.status503 [] mempty
+    _ -> respond $ Wai.responseLBS HTTP.status404 [] mempty
+
 -- | PostgREST application
 postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application
 postgrest logLev appState connWorker =
@@ -146,12 +162,11 @@ postgrest logLev appState connWorker =
       maybeDbStructure <- AppState.getDbStructure appState
       pgVer <- AppState.getPgVersion appState
       jsonDbS <- AppState.getJsonDbS appState
-      listenerOn <- AppState.getIsListenerOn appState
 
       let
         eitherResponse :: IO (Either Error Wai.Response)
         eitherResponse =
-          runExceptT $ postgrestResponse conf maybeDbStructure jsonDbS pgVer (AppState.getPool appState) time listenerOn req
+          runExceptT $ postgrestResponse conf maybeDbStructure jsonDbS pgVer (AppState.getPool appState) time req
 
       response <- either Error.errorResponseFor identity <$> eitherResponse
       -- Launch the connWorker when the connection is down.  The postgrest
@@ -175,10 +190,9 @@ postgrestResponse
   -> PgVersion
   -> SQL.Pool
   -> UTCTime
-  -> Bool
   -> Wai.Request
   -> Handler IO Wai.Response
-postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time listenerOn req = do
+postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time req = do
   body <- lift $ Wai.strictRequestBody req
 
   dbStructure <-
@@ -197,7 +211,7 @@ postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time listenerOn req =
 
   let
     handleReq apiReq =
-      handleRequest $ RequestContext conf dbStructure apiReq pgVer listenerOn
+      handleRequest $ RequestContext conf dbStructure apiReq pgVer
 
   runDbHandler pool (txMode apiRequest) jwtClaims (configDbPreparedStatements conf) .
     Middleware.optionalRollback conf apiRequest $
@@ -216,7 +230,7 @@ runDbHandler pool mode jwtClaims prepared handler = do
   liftEither resp
 
 handleRequest :: RequestContext -> DbHandler Wai.Response
-handleRequest context@(RequestContext _ _ ApiRequest{..} _ _) =
+handleRequest context@(RequestContext _ _ ApiRequest{..} _) =
   case (iAction, iTarget) of
     (ActionRead headersOnly, TargetIdent identifier) ->
       handleRead headersOnly identifier context
@@ -334,7 +348,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
       response HTTP.status201 headers mempty
 
 handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _ _) = do
+handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do
   WriteQueryResult{..} <- writeQuery identifier False mempty context
 
   let
@@ -356,7 +370,7 @@ handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _ _) = do
       response status [contentRangeHeader] mempty
 
 handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response
-handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _ _) = do
+handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do
   when (iTopLevelRange /= RangeQuery.allRange) $
     throwError Error.PutRangeNotAllowedError
 
@@ -380,7 +394,7 @@ handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _ _) =
       response HTTP.status204 [] mempty
 
 handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _ _) = do
+handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do
   WriteQueryResult{..} <- writeQuery identifier False mempty context
 
   let
@@ -463,13 +477,7 @@ handleInvoke invMethod proc context@RequestContext{..} = do
       (if invMethod == InvHead then mempty else LBS.fromStrict body)
 
 handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response
-handleOpenApi _ _ (RequestContext _ _ ApiRequest{iPreferRepresentation = None} _ isListenerOn) =
-  return $
-    Wai.responseLBS
-    (if isListenerOn then HTTP.status200 else HTTP.status503)
-    mempty
-    mempty
-handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest ctxPgVersion _) = do
+handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest ctxPgVersion) = do
   body <-
     lift $ case configOpenApiMode of
       OAFollowPriv ->
@@ -576,7 +584,7 @@ returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc
 returnsScalar _                   = False
 
 readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
-readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest _ _) =
+readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest _) =
   liftEither $
     ReqBuilder.readRequest qiSchema qiName configDbMaxRows
       (dbRelationships dbStructure)

src/PostgREST/CLI.hs

@@ -199,6 +199,9 @@ exampleConfigFile =
       |## when none is provided, 660 is applied by default
       |# server-unix-socket-mode = "660"
       |
+      |## admin server for health checks, it's disabled by default unless a port is specified
+      |# admin-server-port = 3001
+      |
       |## determine if the OpenAPI output should follow or ignore role privileges or be disabled entirely
       |## admitted values: follow-privileges, ignore-privileges, disabled
       |openapi-mode = "follow-privileges"

src/PostgREST/Config.hs

@@ -93,6 +93,7 @@ data AppConfig = AppConfig
   , configServerPort            :: Int
   , configServerUnixSocket      :: Maybe FilePath
   , configServerUnixSocketMode  :: FileMode
+  , configAdminServerPort       :: Maybe Int
   }
 
 data LogLevel = LogCrit | LogError | LogWarn | LogInfo
@@ -147,6 +148,7 @@ toText conf =
       ,("server-port",                   show . configServerPort)
       ,("server-unix-socket",        q . maybe mempty T.pack . configServerUnixSocket)
       ,("server-unix-socket-mode",   q . T.pack . showSocketMode)
+      ,("admin-server-port",             show . configAdminServerPort)
       ]
 
     -- quote all app.settings
@@ -242,6 +244,7 @@ parser optPath env dbSettings =
     <*> (fromMaybe 3000 <$> optInt "server-port")
     <*> (fmap T.unpack <$> optString "server-unix-socket")
     <*> parseSocketFileMode "server-unix-socket-mode"
+    <*> optInt "admin-server-port"
   where
     parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
     parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value

src/PostgREST/Request/ApiRequest.hs

@@ -195,7 +195,7 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
       , iRange = ranges
       , iTopLevelRange = topLevelRange
       , iPayload = relevantPayload
-      , iPreferRepresentation = fromMaybe (if method `elem` ["GET", "HEAD"] then Full else None) preferRepresentation
+      , iPreferRepresentation = fromMaybe None preferRepresentation
       , iPreferParameters = preferParameters
       , iPreferCount = preferCount
       , iPreferResolution = preferResolution