refactor: remove auth and logging middleware

This commit removes auth middleware for it hides
side effects and obscures logic. The auth operations
are now done in its own stage in the request-response
cycle.

It also removes the logging middleware because now
we instead use observation module to log the response.

Author: taimoorzaeem

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

@@ -11,6 +11,7 @@ Some of its functionality includes:
 -}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE ViewPatterns        #-}
 module PostgREST.App
   ( postgrest
@@ -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,93 +120,102 @@ 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
+
+      (maybeUser, response) <-
+        either
+          (second $ Error.errorResponseFor configClientErrorVerbosity)
+          (first Just)
+          <$> runExceptT (postgrestResponse appState appConf maybeSchemaCache req)
+
+      observer $ genResponseObs maybeUser 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
   :: AppState.AppState
   -> AppConfig
   -> Maybe SchemaCache
-  -> AuthResult
   -> Wai.Request
-  -> Handler IO Wai.Response
-postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthResult{..} req = do
+  -> ExceptT (Maybe ByteString, Error) IO (ByteString, Wai.Response)
+postgrestResponse appState conf@AppConfig{..} maybeSchemaCache req = do
   let observer = AppState.getObserver appState
 
+  let bearerAuth = ApiRequest.userBearerAuth req
+
+  (jwtTime, authResult@AuthResult{..}) <- withExceptT (Nothing,) $ -- no role at this stage
+    withTiming $ liftIO (Auth.getAuthResult appState bearerAuth) >>= liftEither
+
+  let authRole' = Just authRole
+
   sCache <-
     case maybeSchemaCache of
       Just sCache ->
         return sCache
       Nothing -> do
         lift $ observer SchemaCacheEmptyObs
-        throwError Error.NoSchemaCacheError
+        throwError (authRole', Error.NoSchemaCacheError)
+
+  let prefs = ApiRequest.userPreferences conf req (dbTimezones sCache)
+      withRoleError = withExceptT (authRole',)
 
   body <- lift $ Wai.strictRequestBody req
 
-  let jwtTime = if configServerTimingEnabled then Auth.getJwtDur req else Nothing
-      timezones = dbTimezones sCache
-      prefs = ApiRequest.userPreferences conf req timezones
+  (parseTime, apiReq@ApiRequest{..}) <- withRoleError $
+    withTiming $ liftEither . mapLeft Error.ApiRequestErr $ ApiRequest.userApiRequest conf prefs req body
 
-  (parseTime, apiReq@ApiRequest{..}) <- withTiming $ liftEither . mapLeft Error.ApiRequestErr $ ApiRequest.userApiRequest conf prefs req body
-  (planTime, plan)                   <- withTiming $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
+  (planTime, plan) <- withRoleError $
+    withTiming $ 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) <- withRoleError . withTiming $ do
     case tx of
       MainTx.NoDbTx r -> pure r
       MainTx.DbTx{..} -> do
         dbRes <- lift $ AppState.usePool appState (dqTransaction dqIsoLevel dqTxMode $ runExceptT dqDbHandler)
-        let eitherResp = join $ mapLeft (Error.PgErr . Error.PgError (Just authRole /= configDbAnonRole)) dbRes
+        let eitherResp = join $ mapLeft (Error.PgErr . Error.PgError (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.
         lift $ whenLeft eitherResp $ obsQuery . Error.status
         liftEither eitherResp
 
-  (respTime, resp) <- withTiming $ do
+  (respTime, resp) <- withRoleError $ withTiming $ 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)
     lift $ obsQuery status'
     liftEither response
 
-  return $ toWaiResponse (ServerTiming jwtTime parseTime planTime txTime respTime) resp
+  pure (authRole, toWaiResponse (ServerTiming jwtTime parseTime planTime txTime respTime) resp)
 
   where
     toWaiResponse :: ServerTiming -> Response.PgrstResponse -> Wai.Response
@@ -224,7 +231,7 @@ 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 :: ExceptT e IO a -> ExceptT e IO (Maybe Double, a)
     withTiming f = if configServerTimingEnabled
         then do
           (t, r) <- timeItT f

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