version 0.1.3.3: log user id (#20)

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.

src/Web/Template/Log.hs

@@ -4,22 +4,32 @@
 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
 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

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\"}"

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"

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