chore: move executable code to src/

src/ now contains all source code - in subdirectories, according to the .cabal component they belong to. This will allow us to put vendored libraries in the same place - and later split our own code into multiple components/libraries as well.
2026-07-14 06:58:15 +00:00
parent 44e15e4e9b
commit aa7d442d32
63 changed files with 21 additions and 21 deletions
@@ -0,0 +1,337 @@
+{-|
+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 FlexibleContexts    #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns        #-}
+module PostgREST.App
+  ( postgrest
+  , run
+  ) where
+
+import GHC.Conc         (ThreadStatus (..), threadStatus)
+import GHC.IO.Exception (IOErrorType (..))
+import GHC.Weak
+import System.IO.Error  (ioeGetErrorType)
+
+import Control.Monad.Except     (liftEither)
+import Data.Either.Combinators  (mapLeft, whenLeft)
+import Data.IORef               (atomicWriteIORef, newIORef,
+                                 readIORef)
+import Data.String              (IsString (..), String)
+import Network.Wai.Handler.Warp (defaultSettings, setBeforeMainLoop,
+                                 setHost, setOnException, setPort,
+                                 setServerName)
+
+import qualified Data.Text.Encoding       as T
+import qualified Network.Wai              as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Network.Wai.Header       as WaiHeader
+
+import qualified PostgREST.Admin      as Admin
+import qualified PostgREST.ApiRequest as ApiRequest
+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.Listener   as Listener
+import qualified PostgREST.MainTx     as MainTx
+import qualified PostgREST.Plan       as Plan
+import qualified PostgREST.Query      as Query
+import qualified PostgREST.Response   as Response
+import qualified PostgREST.Unix       as Unix (installSignalHandlers)
+
+import PostgREST.ApiRequest           (ApiRequest (..))
+import PostgREST.AppState             (AppState)
+import PostgREST.Auth.Types           (AuthResult (..))
+import PostgREST.Config               (AppConfig (..))
+import PostgREST.Error                (Error)
+import PostgREST.Network              (resolveSocketToAddress)
+import PostgREST.Observation          (Observation (..))
+import PostgREST.Response.Performance (ServerTiming (..),
+                                       serverTimingHeader)
+import PostgREST.SchemaCache          (SchemaCache (..))
+import PostgREST.TimeIt               (timeItT)
+import PostgREST.Version              (docsVersion, prettyVersion)
+
+import           Control.Monad.Writer
+import qualified Data.ByteString.Char8     as BS
+import qualified Data.List                 as L
+import           Data.Streaming.Network    (bindPortTCP)
+import qualified Data.Text                 as T
+import qualified Network.HTTP.Types        as HTTP
+import           Network.HTTP.Types.Header (hVary, hWarning)
+import qualified Network.Socket            as NS
+import           PostgREST.Unix            (createAndBindDomainSocket)
+import           System.Posix.Types        (FileMode)
+
+import Protolude        hiding (Handler)
+import System.Directory (doesPathExist)
+
+run :: AppState -> Weak ThreadId -> IO ()
+run appState mainThreadIdRef = do
+  conf <- AppState.getConfig appState
+
+  mainSocketRef <- newIORef Nothing
+  let setMainSocketRef = atomicWriteIORef mainSocketRef . Just
+      clearMainSocketRef = atomicWriteIORef mainSocketRef Nothing
+
+  bracket (initAdminServerSocket conf) ensureSocketClosed $ \adminSocket -> do
+
+    let closeSockets = do
+          ensureSocketClosed adminSocket
+          ensureSocketClosed =<< readIORef mainSocketRef
+    Unix.installSignalHandlers observer closeSockets (AppState.schemaCacheLoader appState) (AppState.readInDbConfig False appState)
+
+    Admin.runAdmin appState adminSocket (checkMainAppLive (readIORef mainSocketRef) mainThreadIdRef) (serverSettings conf)
+
+    Listener.runListener appState
+
+    -- Kick off and wait for the initial SchemaCache load before creating the
+    -- main API socket.
+    AppState.schemaCacheLoader appState
+    AppState.waitForSchemaCacheInit appState
+
+    bracket (initServerSocket conf) NS.close $ \mainSocket -> do
+
+      let app = postgrest appState (AppState.schemaCacheLoader appState)
+
+      address <- resolveSocketToAddress mainSocket
+
+      let
+        appServerSettings = serverSettings conf
+          & setPort (configServerPort conf)
+          & setOnException onWarpException
+          & setBeforeMainLoop (setMainSocketRef mainSocket *> observer (AppServerAddressObs address))
+
+      Warp.runSettingsSocket appServerSettings mainSocket app
+        `finally` clearMainSocketRef
+  where
+    observer = AppState.getObserver appState
+
+    ensureSocketClosed = foldMap NS.close
+
+    onWarpException :: Maybe Wai.Request -> SomeException -> IO ()
+    onWarpException _ ex =
+      when (shouldDisplayException ex) $
+        observer $ WarpServerObs $ show ex
+
+    -- Similar to wai defaultShouldDisplayException in
+    -- https://github.com/yesodweb/wai//blob/8c3882c60f6abe043889fc20c7efd3fa9747fa4a/warp/Network/Wai/Handler/Warp/Settings.hs#L251-L258
+    -- but without omitting AsyncException since it's important to log for ThreadKilled, StackOverflow and other cases.
+    -- We want to reuse this to avoid flooding the logs for some transient failure cases.
+    shouldDisplayException :: SomeException -> Bool
+    shouldDisplayException se
+        | Just (_ :: Warp.InvalidRequest) <- fromException se = False
+        | Just (ioeGetErrorType -> et) <- fromException se, et == ResourceVanished || et == InvalidArgument = False
+        | otherwise = True
+
+serverSettings :: AppConfig -> Warp.Settings
+serverSettings AppConfig{..} =
+  defaultSettings
+    & setHost (fromString $ toS configServerHost)
+    & setServerName ("postgrest/" <> prettyVersion)
+
+-- | PostgREST application
+postgrest :: AppState.AppState -> IO () -> Wai.Application
+postgrest appState connWorker =
+  traceHeaderMiddleware appState .
+  Cors.middleware appState $
+    \req respond -> do
+      appConf@AppConfig{..} <- AppState.getConfig appState -- the config must be read again because it can reload
+      maybeSchemaCache <- AppState.getSchemaCache appState
+
+      let handleError = fmap (either (Error.errorResponseFor configClientErrorVerbosity) identity)
+
+      -- writer to save authRole (uses `tell` for this and `getLast` to obtain it)
+      -- has to be before runExceptT to make sure role is not lost on error
+      (response, authRole) <- runWriterT . handleError . runExceptT $ do
+        (jwtTime, authResult@AuthResult{..}) <- withTiming appConf $
+          Auth.getAuthResult appState $ ApiRequest.userBearerAuth req
+
+        tell $ pure authRole
+
+        postgrestResponse appState appConf maybeSchemaCache jwtTime authResult req
+
+      AppState.getObserver appState $ genResponseObs (getLast authRole) req response
+
+      -- Launch the connWorker when the connection is down. The postgrest
+      -- function can respond successfully (with a stale schema cache) before
+      -- the connWorker is done. However, when there's an empty schema cache
+      -- postgrest responds with the error `PGRST002`; this means that the schema
+      -- cache is still loading, so we don't launch the connWorker here because
+      -- it would duplicate the loading process, e.g. https://github.com/PostgREST/postgrest/issues/3704
+      -- TODO: this process may be unnecessary when the Listener is enabled. Revisit once https://github.com/PostgREST/postgrest/issues/1766 is done
+      when (isServiceUnavailable response && isJust maybeSchemaCache) connWorker
+      delay <- AppState.getNextDelay appState
+      respond $ addRetryHint delay response
+  where
+    -- TODO WaiHeader.contentLength does a lookup everytime, see: https://hackage.haskell.org/package/wai-extra-3.1.17/docs/src/Network.Wai.Header.html#contentLength
+    -- It might be possible to gain some perf by returning the response length from `postgrestResponse`. We calculate the length manually on Response.hs.
+    genResponseObs :: Maybe ByteString -> Wai.Request -> Wai.Response -> Observation
+    genResponseObs user req resp =
+      ResponseObs user req (Wai.responseStatus resp) (WaiHeader.contentLength $ Wai.responseHeaders resp)
+
+postgrestResponse
+  :: (MonadError Error m, MonadIO m)
+  => AppState.AppState
+  -> AppConfig
+  -> Maybe SchemaCache
+  -> Maybe Double
+  -> AuthResult
+  -> Wai.Request
+  -> m Wai.Response
+postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResult@AuthResult{..} req = do
+  let observer = AppState.getObserver appState
+
+  sCache <-
+    case maybeSchemaCache of
+      Just sCache ->
+        return sCache
+      Nothing -> do
+        liftIO $ observer SchemaCacheEmptyObs
+        throwError Error.NoSchemaCacheError
+
+  let prefs = ApiRequest.userPreferences conf req (dbTimezones sCache)
+
+  body <- liftIO $ Wai.strictRequestBody req
+
+  (parseTime, apiReq@ApiRequest{..}) <- withTiming conf $ liftEither . mapLeft Error.ApiRequestErr $ ApiRequest.userApiRequest conf prefs req body
+  (planTime, plan)                   <- withTiming conf $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
+
+  let warnings = Plan.legacyWarnings plan
+      legacyWarnMsg = "Embedded resource was referenced by relation name even though it has an alias. This is deprecated and will stop working in a future release."
+      legacyWarnHint = let replacement (relName, alias) = "`" <> relName <> "` to `" <> alias <> "`" in T.intercalate ", " (replacement <$> warnings)
+      shouldShowWarnings = configUrlUseLegacyTargetNames && not (null warnings)
+
+  liftIO $ when shouldShowWarnings $
+    observer $ LegacyTargetNameWarningObs (legacyWarnMsg, legacyWarnHint) iMethod (iPath <> Wai.rawQueryString req) -- TODO maybe store rawQueryString in ApiRequest for consistency
+
+  let mainQ = Query.mainQuery plan conf apiReq authResult configDbPreRequest
+      tx = MainTx.mainTx mainQ conf authResult apiReq plan sCache
+      obsQuery s = when configLogQuery $ observer $ QueryObs mainQ s
+
+  (txTime, txResult) <- withTiming conf $ do
+    case tx of
+      MainTx.NoDbTx r -> pure r
+      MainTx.DbTx dbSession -> do
+        dbRes <- liftIO $ AppState.usePool appState dbSession
+        let eitherResp = join $ mapLeft (Error.PgErr . Error.PgError (Just authRole /= configDbAnonRole)) dbRes
+
+        -- TODO: we use obsQuery twice, one here and one below because in case of an error with the usePool above, the request will finish here and return an error message.
+        -- This is because of a combination of ExceptT + our Error module which has Wai.responseLBS.
+        -- This needs refactoring so only the below obsQuery is used.
+        liftIO $ whenLeft eitherResp $ obsQuery . Error.status
+        liftEither eitherResp
+
+  (respTime, resp) <- withTiming conf $ do
+    let response = Response.actionResponse txResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache
+        status' = either Error.status Response.pgrstStatus response
+
+    -- TODO: see above obsQuery, only this obsQuery should remain after refactoring (because the QueryObs depends on the status)
+    liftIO $ obsQuery status'
+    liftEither response
+
+  let warnHdrMsgs = if shouldShowWarnings then Just (legacyWarnMsg, legacyWarnHint) else Nothing
+
+  return $ toWaiResponse (ServerTiming jwtTime parseTime planTime txTime respTime) warnHdrMsgs resp
+
+  where
+    toWaiResponse :: ServerTiming -> Maybe (Text, Text) -> Response.PgrstResponse -> Wai.Response
+    toWaiResponse timing warnMsgs (Response.PgrstResponse st hdrs bod) =
+      Wai.responseLBS st (hdrs ++ serverTimingHeaders timing ++ warningHeaders warnMsgs ++ [varyHeader | not $ varyHeaderPresent hdrs]) bod
+
+    serverTimingHeaders :: ServerTiming -> [HTTP.Header]
+    serverTimingHeaders timing = [serverTimingHeader timing | configServerTimingEnabled]
+
+    varyHeader :: HTTP.Header
+    varyHeader = (hVary, "Accept, Prefer, Range")
+
+    varyHeaderPresent :: [HTTP.Header] -> Bool
+    varyHeaderPresent = any (\(h, _v) -> h == hVary)
+
+    warningHeaders :: Maybe (Text, Text) -> [HTTP.Header]
+    warningHeaders Nothing = []
+    warningHeaders (Just (msg, hint)) =
+      let warnMsg = msg <> " Update " <> hint <> " in query string filters, orders or limits."
+          pgrstVer = "PostgRESTv" <> BS.filter (/= ' ') prettyVersion
+      in
+      [(hWarning, "299 " <> pgrstVer <> " \"" <> encodeUtf8 warnMsg <> "\"")]
+
+withTiming :: (MonadError e m, MonadIO m) => AppConfig -> m a -> m (Maybe Double, a)
+withTiming AppConfig{configServerTimingEnabled} f = if configServerTimingEnabled
+    then do
+      (t, r) <- timeItT f
+      pure (Just t, r)
+    else do
+      r <- f
+      pure (Nothing, r)
+
+traceHeaderMiddleware :: AppState -> Wai.Middleware
+traceHeaderMiddleware appState app req respond = do
+  conf <- AppState.getConfig appState
+
+  case configServerTraceHeader conf of
+    Nothing -> app req respond
+    Just hdr ->
+      let hdrVal = L.lookup hdr $ Wai.requestHeaders req in
+      app req (respond . Wai.mapResponseHeaders ([(hdr, fromMaybe mempty hdrVal)] ++))
+
+addRetryHint :: Int -> Wai.Response -> Wai.Response
+addRetryHint delay response = do
+  let h = ("Retry-After", BS.pack $ show delay)
+  Wai.mapResponseHeaders (\hs -> if isServiceUnavailable response then h:hs else hs) response
+
+isServiceUnavailable :: Wai.Response -> Bool
+isServiceUnavailable response = Wai.responseStatus response == HTTP.status503
+
+initSocket :: (Applicative f, Traversable f) => Maybe String -> FileMode -> Text -> f Int -> IO (f NS.Socket)
+initSocket unixSocket unixSocketMode tcpHost tcpPort =
+  maybe initTCPSocket initDomainSocket unixSocket
+  where
+    initTCPSocket = traverse (`bindPortTCP` (fromString $ T.unpack tcpHost)) tcpPort
+    -- I'm not using `streaming-commons`' bindPath function here because it's not defined for Windows,
+    -- but we need to have runtime error if we try to use it in Windows, not compile time error
+    initDomainSocket = fmap pure . (`createAndBindDomainSocket` unixSocketMode)
+
+initServerSocket :: AppConfig -> IO NS.Socket
+initServerSocket AppConfig{..} =
+  runIdentity <$> initSocket
+    configServerUnixSocket configServerUnixSocketMode
+    configServerHost (pure configServerPort)
+
+initAdminServerSocket :: AppConfig -> IO (Maybe NS.Socket)
+initAdminServerSocket AppConfig{..} =
+  initSocket
+    configAdminServerUnixSocket configAdminServerUnixSocketMode
+    configAdminServerHost configAdminServerPort
+
+checkMainAppLive :: IO (Maybe NS.Socket) -> Weak ThreadId -> IO Bool
+checkMainAppLive getMainSocket mainThreadIdRef =
+  handle (\(_ :: IOException) -> pure False) $
+    checkMainThread <&&> checkSocket
+  where
+    checkSocket = getMainSocket >>=
+      maybe (pure False)
+      (NS.getSocketName >=> \case
+        -- in case of unix socket, check if it still exists
+        NS.SockAddrUnix fp -> doesPathExist fp
+        _ -> pure True)
+    checkMainThread = deRefWeak mainThreadIdRef >>=
+      maybe (pure False)
+      (fmap isRunning . threadStatus)
+    isRunning = \case
+      ThreadRunning -> True
+      ThreadBlocked _ -> True
+      _ -> False