diff --git a/CHANGELOG.md b/CHANGELOG.md index 9a463da..7d69716 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] +## [0.1.3.3] - 2020-12-12 +### Changed +- Log user id for requests where it's set. + ## [0.1.3.2] - 2020-11-19 ### Fixed - Flush `stdout` after writing logs. diff --git a/src/Web/Template/Log.hs b/src/Web/Template/Log.hs index f085f62..4381409 100644 --- a/src/Web/Template/Log.hs +++ b/src/Web/Template/Log.hs @@ -4,10 +4,13 @@ module Web.Template.Log ( bcdlog , bcdlog400 + + , userIdVaultKey ) where import Data.Aeson (fromEncoding, pairs, (.=)) import Data.ByteString.Builder (hPutBuilder, toLazyByteString) +import Data.IORef (IORef, newIORef, readIORef) import Data.Text as T (Text, pack, unwords) import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding.Error as TE @@ -15,11 +18,18 @@ import qualified Data.Text.Lazy.Encoding as TLE (decodeUtf8With) import Data.Time (ZonedTime, defaultTimeLocale, formatTime, nominalDiffTimeToSeconds, utcToLocalZonedTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) +import Data.Vault.Lazy (Key, insert, newKey) import Network.HTTP.Types.Status (Status (..)) -import Network.Wai (Middleware, rawPathInfo, requestMethod, responseStatus) +import Network.Wai (Middleware, rawPathInfo, requestMethod, responseStatus, + vault) import Network.Wai.Internal (Response (..)) import System.BCD.Log (Level (..)) import System.IO (hFlush, stdout) +import System.IO.Unsafe (unsafePerformIO) + +userIdVaultKey :: Key (IORef (Maybe Text)) +userIdVaultKey = unsafePerformIO newKey +{-# NOINLINE userIdVaultKey #-} bcdlog :: Middleware bcdlog = logMiddleware False @@ -35,10 +45,19 @@ logMiddleware log400 app request respond = do start <- getPOSIXTime startZoned <- utcToLocalZonedTime $ posixSecondsToUTCTime start - app request $ \response -> do + -- Insert an empty IORef to the vault associated with request. + -- This IORef will later be filled by authorization handler in the application. + userIdRef <- newIORef Nothing + let vaultWithUserId = insert userIdVaultKey userIdRef $ vault request + + app request { vault = vaultWithUserId } $ \response -> do finishApp <- getPOSIXTime !rcv <- respond response finishNetwork <- getPOSIXTime + + -- Read userId written by the application. + userId <- readIORef userIdRef + let statusC = statusCode $ responseStatus response msg' = T.unwords [method, url, pack (show statusC)] @@ -58,6 +77,7 @@ logMiddleware log400 app request respond = do <> "msg" .= msg' <> "status" .= statusC <> "url" .= url + <> maybe mempty ("userId" .=) userId <> if log400 && statusC >= 400 then maybe mempty (\b -> "response" .= TLE.decodeUtf8With TE.lenientDecode (toLazyByteString b)) responseBody else mempty diff --git a/src/Web/Template/Servant/Auth.hs b/src/Web/Template/Servant/Auth.hs index 58227f0..ee13e3e 100644 --- a/src/Web/Template/Servant/Auth.hs +++ b/src/Web/Template/Servant/Auth.hs @@ -3,19 +3,23 @@ module Web.Template.Servant.Auth -- after https://www.stackage.org/haddock/lts-15.15/servant-server-0.16.2/src/Servant.Server.Experimental.Auth.html -import Control.Lens (at, (.~), (?~)) -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import GHC.Generics (Generic) +import Control.Lens (at, (.~), (?~)) +import Control.Monad.IO.Class (liftIO) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.IORef (writeIORef) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Vault.Lazy as V +import GHC.Generics (Generic) +import Web.Template.Log (userIdVaultKey) import Data.OpenApi.Internal (ApiKeyLocation (..), ApiKeyParams (..), SecurityRequirement (..), SecurityScheme (..), SecuritySchemeType (..)) import Data.OpenApi.Lens (components, description, security, securitySchemes) import Data.OpenApi.Operation (allOperations, setResponse) import Network.HTTP.Types.Header (hContentType) -import Network.Wai (requestHeaders) +import Network.Wai (requestHeaders, vault) import Servant.API ((:>)) import Servant.OpenApi (HasOpenApi (..)) import Servant.Server (HasServer (..), ServerError (..), err401) @@ -43,12 +47,21 @@ instance HasServer api context => HasServer (CbdAuth :> api) context where route _ context sub = route @api Proxy context $ addAuthCheck sub - $ withRequest $ \req -> - maybe (delayedFailFatal err) return $ - lookup "cookie" (requestHeaders req) - <&> parseCookiesText - >>= lookup "id" - <&> UserId + $ withRequest $ \req -> do + let + mUserId = + lookup "cookie" (requestHeaders req) + <&> parseCookiesText + >>= lookup "id" + case mUserId of + Nothing -> delayedFailFatal err + Just uid -> do + -- Try to store user id in the vault, to be used by logging middleware later. + let mUserIdRef = V.lookup userIdVaultKey $ vault req + case mUserIdRef of + Nothing -> return () + Just ref -> liftIO $ writeIORef ref $ Just uid + return $ UserId uid where err = err401 { errBody = "{\"error\": \"Authorization failed\"}" diff --git a/src/Web/Template/Server.hs b/src/Web/Template/Server.hs index c210092..ba3e0fe 100644 --- a/src/Web/Template/Server.hs +++ b/src/Web/Template/Server.hs @@ -15,22 +15,28 @@ module Web.Template.Server , toApplication ) where -import Control.Concurrent (threadDelay) -import Control.Exception (AsyncException (..), SomeException (..), catch, fromException) -import Control.Monad (unless) -import Control.Monad.RWS (RWST, evalRWST) -import Data.String (fromString) -import Data.Text.Encoding (encodeUtf8) -import Data.Text.Lazy as TL (Text, toStrict) -import Network.HTTP.Types.Status (status401) -import Network.Wai (Application) -import Network.Wai.Handler.Warp (Settings) -import Web.Cookie (parseCookiesText) -import Web.Scotty.Trans (Options (..), ScottyT, defaultHandler, header, json, middleware, - next, param, scottyAppT, scottyOptsT, status) -import Web.Template.Except (Except, JsonWebError (..), handleEx) -import Web.Template.Types -import Web.Template.Wai +import Control.Concurrent (threadDelay) +import Control.Exception (AsyncException (..), SomeException (..), catch, + fromException) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.RWS (RWST, evalRWST) +import Data.IORef (writeIORef) +import Data.String (fromString) +import Data.Text.Encoding (encodeUtf8) +import Data.Text.Lazy as TL (Text, toStrict) +import qualified Data.Vault.Lazy as V +import Network.HTTP.Types.Status (status401) +import Network.Wai (Application, vault) +import Network.Wai.Handler.Warp (Settings) +import Web.Cookie (parseCookiesText) +import Web.Scotty.Trans (Options (..), ScottyT, defaultHandler, header, json, + middleware, next, param, request, scottyAppT, + scottyOptsT, status) +import Web.Template.Except (Except, JsonWebError (..), handleEx) +import Web.Template.Log (userIdVaultKey) +import Web.Template.Types +import Web.Template.Wai -- | Restart `f` on `error` after `1s`. restartOnError1 :: IO () -> IO () @@ -94,7 +100,13 @@ auth (AuthProcess p) = do cookiesM <- header "Cookie" let idMaybe = cookiesM >>= getIdFromCookies case idMaybe of - Just id' -> p id' + Just id' -> do + -- Try to store user id in the vault, to be used by logging middleware later. + mUserIdRef <- V.lookup userIdVaultKey . vault <$> request + case mUserIdRef of + Nothing -> return () + Just ref -> liftIO $ writeIORef ref $ Just id' + p id' Nothing -> do status status401 json . JsonWebError $ "Authorization failed" diff --git a/web-template.cabal b/web-template.cabal index a907c1b..dfbedb8 100644 --- a/web-template.cabal +++ b/web-template.cabal @@ -1,5 +1,5 @@ name: web-template -version: 0.1.3.2 +version: 0.1.3.3 synopsis: Web template description: Web template includes: @@ -54,6 +54,7 @@ library , servant-server >= 0.18 , text , time + , vault , wai , wai-extra , wai-logger