refactor: remove auth and logging middleware

postgrest.cabal

@@ -70,6 +70,7 @@ library
                       PostgREST.Listener
                       PostgREST.Logger
                       PostgREST.MainTx
+                      PostgREST.Logger.Apache
                       PostgREST.MediaType
                       PostgREST.Metrics
                       PostgREST.Network
@@ -116,6 +117,7 @@ library
                     , directory                 >= 1.2.6 && < 1.4
                     , either                    >= 4.4.1 && < 5.1
                     , extra                     >= 1.7.0 && < 2.0
+                    , fast-logger               >= 3.2.0 && < 3.3
                     , fuzzyset                  >= 0.2.4 && < 0.3
                     , hasql                     >= 1.9 && <= 1.9.3.1
                     , hasql-dynamic-statements  >= 0.3.1 && <= 0.3.1.8
@@ -147,7 +149,6 @@ library
                     , time                      >= 1.6 && < 1.15
                     , unordered-containers      >= 0.2.8 && < 0.3
                     , unix-compat               >= 0.5.4 && < 0.8
-                    , vault                     >= 0.3.1.5 && < 0.4
                     , vector                    >= 0.11 && < 0.14
                     , wai                       >= 3.2.1 && < 3.3
                     , wai-cors                  >= 0.2.5 && < 0.3

src/PostgREST/ApiRequest.hs

@@ -8,6 +8,7 @@ module PostgREST.ApiRequest
   ( ApiRequest(..)
   , userApiRequest
   , userPreferences
+  , userBearerAuth
   ) where
 
 import qualified Data.CaseInsensitive as CI
@@ -16,13 +17,15 @@ import qualified Data.List.NonEmpty   as NonEmptyList
 import qualified Data.Set             as S
 import qualified Data.Text.Encoding   as T
 
-import Data.List                 (lookup)
-import Data.Ranged.Ranges        (emptyRange, rangeIntersection,
-                                  rangeIsEmpty)
-import Network.HTTP.Types.Header (RequestHeaders, hCookie)
-import Network.Wai               (Request (..))
-import Network.Wai.Parse         (parseHttpAccept)
-import Web.Cookie                (parseCookies)
+import Data.List                       (lookup)
+import Data.Ranged.Ranges              (emptyRange, rangeIntersection,
+                                        rangeIsEmpty)
+import Network.HTTP.Types.Header       (RequestHeaders,
+                                        hAuthorization, hCookie)
+import Network.Wai                     (Request (..))
+import Network.Wai.Middleware.HttpAuth (extractBearerAuth)
+import Network.Wai.Parse               (parseHttpAccept)
+import Web.Cookie                      (parseCookies)
 
 import PostgREST.ApiRequest.Payload      (getPayload)
 import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
@@ -114,6 +117,10 @@ userApiRequest conf prefs req reqBody = do
 userPreferences :: AppConfig -> Request -> TimezoneNames -> Preferences.Preferences
 userPreferences conf req timezones = Preferences.fromHeaders (configDbTxAllowOverride conf) timezones $ requestHeaders req
 
+-- | Obtains the Bearer Auth
+userBearerAuth :: Request -> Maybe ByteString
+userBearerAuth req = extractBearerAuth =<< lookup hAuthorization (requestHeaders req)
+
 getResource :: AppConfig -> [Text] -> Either ApiRequestError Resource
 getResource AppConfig{configOpenApiMode, configDbRootSpec} = \case
   []             ->

src/PostgREST/App.hs

@@ -9,6 +9,7 @@ Some of its functionality includes:
 - Producing HTTP Headers according to RFCs.
 - Content Negotiation
 -}
+{-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns        #-}
@@ -24,7 +25,6 @@ import System.IO.Error  (ioeGetErrorType)
 import Control.Monad.Except     (liftEither)
 import Control.Monad.Extra      (whenJust)
 import Data.Either.Combinators  (mapLeft, whenLeft)
-import Data.Maybe               (fromJust)
 import Data.String              (IsString (..))
 import Network.Wai.Handler.Warp (defaultSettings, setHost,
                                  setOnException, setPort,
@@ -33,6 +33,7 @@ import Network.Wai.Handler.Warp (defaultSettings, setHost,
 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
@@ -41,7 +42,6 @@ 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.Logger     as Logger
 import qualified PostgREST.MainTx     as MainTx
 import qualified PostgREST.Plan       as Plan
 import qualified PostgREST.Query      as Query
@@ -51,7 +51,7 @@ import qualified PostgREST.Unix       as Unix (installSignalHandlers)
 import PostgREST.ApiRequest           (ApiRequest (..))
 import PostgREST.AppState             (AppState)
 import PostgREST.Auth.Types           (AuthResult (..))
-import PostgREST.Config               (AppConfig (..), LogLevel (..))
+import PostgREST.Config               (AppConfig (..))
 import PostgREST.Error                (Error)
 import PostgREST.Network              (resolveSocketToAddress)
 import PostgREST.Observation          (Observation (..))
@@ -72,11 +72,9 @@ import qualified Network.Socket            as NS
 import           PostgREST.Unix            (createAndBindDomainSocket)
 import           Protolude                 hiding (Handler)
 
-type Handler = ExceptT Error
-
 run :: AppState -> IO ()
 run appState = do
-  conf@AppConfig{..} <- AppState.getConfig appState
+  conf <- AppState.getConfig appState
 
   AppState.schemaCacheLoader appState -- Loads the initial SchemaCache
   (mainSocket, adminSocket) <- initSockets conf
@@ -89,7 +87,7 @@ run appState = do
 
   Admin.runAdmin appState adminSocket mainSocket (serverSettings conf)
 
-  let app = postgrest configLogLevel appState (AppState.schemaCacheLoader appState)
+  let app = postgrest appState (AppState.schemaCacheLoader appState)
 
   do
     address <- resolveSocketToAddress mainSocket
@@ -122,48 +120,59 @@ serverSettings AppConfig{..} =
     & setServerName ("postgrest/" <> prettyVersion)
 
 -- | PostgREST application
-postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application
-postgrest logLevel appState connWorker =
+postgrest :: AppState.AppState -> IO () -> Wai.Application
+postgrest appState connWorker =
   traceHeaderMiddleware appState .
-  Cors.middleware appState .
-  Auth.middleware appState .
-  Logger.middleware logLevel Auth.getRole $
-    -- fromJust can be used, because the auth middleware will **always** add
-    -- some AuthResult to the vault.
+  Cors.middleware appState $
     \req respond -> do
       appConf@AppConfig{..} <- AppState.getConfig appState -- the config must be read again because it can reload
-      case fromJust $ Auth.getResult req of
-        Left err -> respond $ Error.errorResponseFor configClientErrorVerbosity err
-        Right authResult -> do
-          maybeSchemaCache <- AppState.getSchemaCache appState
-
-          let
-            eitherResponse :: IO (Either Error Wai.Response)
-            eitherResponse =
-              runExceptT $ postgrestResponse appState appConf maybeSchemaCache authResult req
-
-          response <- either (Error.errorResponseFor configClientErrorVerbosity) 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. 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
-          resp <- do
-            delay <- AppState.getNextDelay appState
-            return $ addRetryHint delay response
-          respond resp
+      maybeSchemaCache <- AppState.getSchemaCache appState
+
+      let observer = AppState.getObserver appState
+          bearerAuth = ApiRequest.userBearerAuth req
+
+      response <- do
+        authResultE <- runExceptT $ withTiming appConf $
+            liftIO (Auth.getAuthResult appState bearerAuth) >>= liftEither
+
+        case authResultE of
+          Left err -> do
+            let resp = Error.errorResponseFor configClientErrorVerbosity err
+            observer $ genResponseObs Nothing req resp
+            pure resp
+
+          Right (jwtTime, authResult@AuthResult{..}) -> do
+            resp <- either (Error.errorResponseFor configClientErrorVerbosity) identity <$>
+              runExceptT (postgrestResponse appState appConf maybeSchemaCache jwtTime authResult req)
+            observer $ genResponseObs (Just authRole) req resp
+            pure resp
+
+      -- 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
   :: AppState.AppState
   -> AppConfig
   -> Maybe SchemaCache
+  -> Maybe Double
   -> AuthResult
   -> Wai.Request
-  -> Handler IO Wai.Response
-postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthResult{..} req = do
+  -> ExceptT Error IO Wai.Response
+postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResult@AuthResult{..} req = do
   let observer = AppState.getObserver appState
 
   sCache <-
@@ -174,20 +183,18 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthRe
         lift $ observer SchemaCacheEmptyObs
         throwError Error.NoSchemaCacheError
 
-  body <- lift $ Wai.strictRequestBody req
+  let prefs = ApiRequest.userPreferences conf req (dbTimezones sCache)
 
-  let jwtTime = if configServerTimingEnabled then Auth.getJwtDur req else Nothing
-      timezones = dbTimezones sCache
-      prefs = ApiRequest.userPreferences conf req timezones
+  body <- lift $ Wai.strictRequestBody req
 
-  (parseTime, apiReq@ApiRequest{..}) <- withTiming $ liftEither . mapLeft Error.ApiRequestErr $ ApiRequest.userApiRequest conf prefs req body
-  (planTime, plan)                   <- withTiming $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
+  (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 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 $ do
+  (txTime, txResult) <- withTiming conf $ do
     case tx of
       MainTx.NoDbTx r -> pure r
       MainTx.DbTx{..} -> do
@@ -200,7 +207,7 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthRe
         lift $ whenLeft eitherResp $ obsQuery . Error.status
         liftEither eitherResp
 
-  (respTime, resp) <- withTiming $ do
+  (respTime, resp) <- withTiming conf $ do
     let response = Response.actionResponse txResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache
         status' = either Error.status Response.pgrstStatus response
 
@@ -224,14 +231,14 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthRe
     varyHeaderPresent :: [HTTP.Header] -> Bool
     varyHeaderPresent = any (\(h, _v) -> h == HTTP.hVary)
 
-    withTiming :: Handler IO a -> Handler IO (Maybe Double, a)
-    withTiming f = if configServerTimingEnabled
-        then do
-          (t, r) <- timeItT f
-          pure (Just t, r)
-        else do
-          r <- f
-          pure (Nothing, r)
+withTiming :: AppConfig -> ExceptT e IO a -> ExceptT e IO (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

src/PostgREST/Auth.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE RecordWildCards #-}
 {-|
 Module      : PostgREST.Auth
 Description : PostgREST authentication functions.
@@ -12,66 +11,28 @@ In the test suite there is an example of simple login function that can be used
 very simple authentication system inside the PostgreSQL database.
 -}
 module PostgREST.Auth
-  ( getResult
-  , getJwtDur
-  , getRole
-  , middleware
-  ) where
-
-import qualified Data.ByteString                 as BS
-import qualified Data.Vault.Lazy                 as Vault
-import qualified Network.HTTP.Types.Header       as HTTP
-import qualified Network.Wai                     as Wai
-import qualified Network.Wai.Middleware.HttpAuth as Wai
-
-import Data.List        (lookup)
-import PostgREST.TimeIt (timeItT)
-import System.IO.Unsafe (unsafePerformIO)
+  ( getAuthResult )
+  where
 
 import PostgREST.AppState      (AppState, getConfig, getJwtCacheState,
                                 getTime)
 import PostgREST.Auth.Jwt      (parseClaims)
 import PostgREST.Auth.JwtCache (lookupJwtCache)
-import PostgREST.Auth.Types    (AuthResult (..))
-import PostgREST.Config        (AppConfig (..))
-import PostgREST.Error         (Error (..))
+import PostgREST.Auth.Types    (AuthResult)
+import PostgREST.Error         (Error)
 
 import Protolude
 
--- | Validate authorization header
---   Parse and store JWT claims for future use in the request.
-middleware :: AppState -> Wai.Middleware
-middleware appState app req respond = do
-  conf@AppConfig{..} <- getConfig appState
+-- | Perform authentication and authorization
+--   Parse JWT and return AuthResult
+getAuthResult :: AppState -> Maybe ByteString -> IO (Either Error AuthResult)
+getAuthResult appState token = do
+  conf <- getConfig appState
   time <- getTime appState
 
-  let token  = Wai.extractBearerAuth =<< lookup HTTP.hAuthorization (Wai.requestHeaders req)
-      parseJwt = runExceptT $ lookupJwtCache jwtCacheState token >>= parseClaims conf time
-      jwtCacheState = getJwtCacheState appState
-
-  -- If ServerTimingEnabled -> calculate JWT validation time
-  req' <- if configServerTimingEnabled then do
-      (dur, authResult) <- timeItT parseJwt
-      pure $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult & Vault.insert jwtDurKey dur }
-    else do
-      authResult <- parseJwt
-      pure $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult }
-
-  app req' respond
-
-authResultKey :: Vault.Key (Either Error AuthResult)
-authResultKey = unsafePerformIO Vault.newKey
-{-# NOINLINE authResultKey #-}
-
-getResult :: Wai.Request -> Maybe (Either Error AuthResult)
-getResult = Vault.lookup authResultKey . Wai.vault
-
-jwtDurKey :: Vault.Key Double
-jwtDurKey = unsafePerformIO Vault.newKey
-{-# NOINLINE jwtDurKey #-}
-
-getJwtDur :: Wai.Request -> Maybe Double
-getJwtDur =  Vault.lookup jwtDurKey . Wai.vault
+  let jwtCacheState = getJwtCacheState appState
+      parseJwt = runExceptT $ do
+        claims <- lookupJwtCache jwtCacheState token
+        parseClaims conf time claims
 
-getRole :: Wai.Request -> Maybe BS.ByteString
-getRole req = authRole <$> (rightToMaybe =<< getResult req)
+  parseJwt