{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Request correlation and structured logging, independent of any logger
-- library. Enable through 'Web.Spock.Core.sc_logging' or use the middleware
-- directly in a WAI application.
module Web.Spock.Logging
  ( LoggingConfig (..), defaultLoggingConfig,
    RequestContext (..), LogLevel (..), LogEvent (..), LogEventType (..),
    RequestLogger, newRequestLogger, requestLoggingMiddleware, lookupRequestLogger,
    emitRequestLog,
  ) where

import Control.Exception
import qualified System.Entropy as Entropy
import Data.Aeson (ToJSON (..), Value, object, (.=))
import qualified Data.Aeson.Key as Key
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.IO as T
import Data.Time (UTCTime, getCurrentTime)
import qualified Data.Vault.Lazy as Vault
import Data.Word (Word64)
import GHC.Clock (getMonotonicTimeNSec)
import Network.HTTP.Types (HeaderName, statusCode)
import qualified Network.Wai as Wai
import System.IO (stderr)

data RequestContext = RequestContext
  { RequestContext -> Text
rc_requestId :: Text,
    RequestContext -> Text
rc_method :: Text,
    -- | Raw path only; excludes query strings, headers, and request bodies.
    RequestContext -> Text
rc_path :: Text
  } deriving (RequestContext -> RequestContext -> Bool
(RequestContext -> RequestContext -> Bool)
-> (RequestContext -> RequestContext -> Bool) -> Eq RequestContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequestContext -> RequestContext -> Bool
== :: RequestContext -> RequestContext -> Bool
$c/= :: RequestContext -> RequestContext -> Bool
/= :: RequestContext -> RequestContext -> Bool
Eq, Int -> RequestContext -> ShowS
[RequestContext] -> ShowS
RequestContext -> String
(Int -> RequestContext -> ShowS)
-> (RequestContext -> String)
-> ([RequestContext] -> ShowS)
-> Show RequestContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequestContext -> ShowS
showsPrec :: Int -> RequestContext -> ShowS
$cshow :: RequestContext -> String
show :: RequestContext -> String
$cshowList :: [RequestContext] -> ShowS
showList :: [RequestContext] -> ShowS
Show)

data LogLevel = LogDebug | LogInfo | LogWarning | LogError deriving (LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
/= :: LogLevel -> LogLevel -> Bool
Eq, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> String
show :: LogLevel -> String
$cshowList :: [LogLevel] -> ShowS
showList :: [LogLevel] -> ShowS
Show)

data LogEventType
  = -- | Status and elapsed microseconds until the response is available.
    -- Streaming body transmission is not included in the duration.
    AccessLog Int Word64
  | MessageLog LogLevel Text [(Text, Value)]
  | ErrorLog Text
  deriving (LogEventType -> LogEventType -> Bool
(LogEventType -> LogEventType -> Bool)
-> (LogEventType -> LogEventType -> Bool) -> Eq LogEventType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogEventType -> LogEventType -> Bool
== :: LogEventType -> LogEventType -> Bool
$c/= :: LogEventType -> LogEventType -> Bool
/= :: LogEventType -> LogEventType -> Bool
Eq, Int -> LogEventType -> ShowS
[LogEventType] -> ShowS
LogEventType -> String
(Int -> LogEventType -> ShowS)
-> (LogEventType -> String)
-> ([LogEventType] -> ShowS)
-> Show LogEventType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogEventType -> ShowS
showsPrec :: Int -> LogEventType -> ShowS
$cshow :: LogEventType -> String
show :: LogEventType -> String
$cshowList :: [LogEventType] -> ShowS
showList :: [LogEventType] -> ShowS
Show)

data LogEvent = LogEvent
  { LogEvent -> UTCTime
le_time :: UTCTime,
    LogEvent -> RequestContext
le_request :: RequestContext,
    LogEvent -> LogEventType
le_event :: LogEventType
  } deriving (LogEvent -> LogEvent -> Bool
(LogEvent -> LogEvent -> Bool)
-> (LogEvent -> LogEvent -> Bool) -> Eq LogEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogEvent -> LogEvent -> Bool
== :: LogEvent -> LogEvent -> Bool
$c/= :: LogEvent -> LogEvent -> Bool
/= :: LogEvent -> LogEvent -> Bool
Eq, Int -> LogEvent -> ShowS
[LogEvent] -> ShowS
LogEvent -> String
(Int -> LogEvent -> ShowS)
-> (LogEvent -> String) -> ([LogEvent] -> ShowS) -> Show LogEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogEvent -> ShowS
showsPrec :: Int -> LogEvent -> ShowS
$cshow :: LogEvent -> String
show :: LogEvent -> String
$cshowList :: [LogEvent] -> ShowS
showList :: [LogEvent] -> ShowS
Show)

instance ToJSON LogEvent where
  toJSON :: LogEvent -> Value
toJSON LogEvent
event = [(Key, Value)] -> Value
object ([(Key, Value)] -> Value) -> [(Key, Value)] -> Value
forall a b. (a -> b) -> a -> b
$
    [ Key
"time" Key -> UTCTime -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LogEvent -> UTCTime
le_time LogEvent
event,
      Key
"requestId" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequestContext -> Text
rc_requestId RequestContext
context,
      Key
"method" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequestContext -> Text
rc_method RequestContext
context,
      Key
"path" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequestContext -> Text
rc_path RequestContext
context ] [(Key, Value)] -> [(Key, Value)] -> [(Key, Value)]
forall a. [a] -> [a] -> [a]
++ [(Key, Value)]
details
    where
      context :: RequestContext
context = LogEvent -> RequestContext
le_request LogEvent
event
      details :: [(Key, Value)]
details = case LogEvent -> LogEventType
le_event LogEvent
event of
        AccessLog Int
status Word64
duration -> [Key
"type" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"access" :: Text), Key
"status" Key -> Int -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
status, Key
"durationMicros" Key -> Word64 -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64
duration]
        MessageLog LogLevel
level Text
message [(Text, Value)]
fields ->
          [Key
"type" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"message" :: Text), Key
"level" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LogLevel -> Text
levelName LogLevel
level, Key
"message" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
message,
           Key
"fields" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [Text -> Key
Key.fromText Text
key Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
value | (Text
key, Value
value) <- [(Text, Value)]
fields]]
        ErrorLog Text
message -> [Key
"type" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"error" :: Text), Key
"level" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"error" :: Text), Key
"message" Key -> Text -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
message]

levelName :: LogLevel -> Text
levelName :: LogLevel -> Text
levelName LogLevel
LogDebug = Text
"debug"
levelName LogLevel
LogInfo = Text
"info"
levelName LogLevel
LogWarning = Text
"warning"
levelName LogLevel
LogError = Text
"error"

data LoggingConfig = LoggingConfig
  { LoggingConfig -> LogEvent -> IO ()
lc_logEvent :: LogEvent -> IO (),
    LoggingConfig -> CI ByteString
lc_requestIdHeader :: HeaderName,
    -- | Opt in only behind a trusted proxy. Accepted values contain 1-128 ASCII
    -- letters, digits, dots, underscores, or hyphens; duplicates are rejected.
    LoggingConfig -> Bool
lc_trustIncomingRequestId :: Bool,
    LoggingConfig -> IO Text
lc_generateRequestId :: IO Text,
    -- | Called when the sink fails. Synchronous failures in logging callbacks
    -- cannot change responses. Asynchronous cancellation is always propagated.
    LoggingConfig -> SomeException -> IO ()
lc_logFailure :: SomeException -> IO ()
  }

defaultLoggingConfig :: (LogEvent -> IO ()) -> LoggingConfig
defaultLoggingConfig :: (LogEvent -> IO ()) -> LoggingConfig
defaultLoggingConfig LogEvent -> IO ()
sink = (LogEvent -> IO ())
-> CI ByteString
-> Bool
-> IO Text
-> (SomeException -> IO ())
-> LoggingConfig
LoggingConfig LogEvent -> IO ()
sink CI ByteString
"X-Request-Id" Bool
False IO Text
generateId
  (\SomeException
_ -> Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Spock: structured log sink failed")

data RequestLogger = RequestLogger LoggingConfig (Vault.Key RequestContext)

newRequestLogger :: LoggingConfig -> IO RequestLogger
newRequestLogger :: LoggingConfig -> IO RequestLogger
newRequestLogger LoggingConfig
cfg = LoggingConfig -> Key RequestContext -> RequestLogger
RequestLogger LoggingConfig
cfg (Key RequestContext -> RequestLogger)
-> IO (Key RequestContext) -> IO RequestLogger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Key RequestContext)
forall a. IO (Key a)
Vault.newKey

lookupRequestLogger :: RequestLogger -> Wai.Request -> Maybe (RequestContext, LogEventType -> IO ())
lookupRequestLogger :: RequestLogger
-> Request -> Maybe (RequestContext, LogEventType -> IO ())
lookupRequestLogger logger :: RequestLogger
logger@(RequestLogger LoggingConfig
_ Key RequestContext
key) Request
request = do
  context <- Key RequestContext -> Vault -> Maybe RequestContext
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key RequestContext
key (Request -> Vault
Wai.vault Request
request)
  pure (context, emitRequestLog logger context)

emitRequestLog :: RequestLogger -> RequestContext -> LogEventType -> IO ()
emitRequestLog :: RequestLogger -> RequestContext -> LogEventType -> IO ()
emitRequestLog (RequestLogger LoggingConfig
cfg Key RequestContext
_) RequestContext
context LogEventType
event = do
  now <- IO UTCTime
getCurrentTime
  lc_logEvent cfg (LogEvent now context event) `catch` \(SomeException
err :: SomeException) -> do
    SomeException -> IO ()
rethrowAsync SomeException
err
    LoggingConfig -> SomeException -> IO ()
lc_logFailure LoggingConfig
cfg SomeException
err IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
failure :: SomeException) -> SomeException -> IO ()
rethrowAsync SomeException
failure

requestLoggingMiddleware :: RequestLogger -> Wai.Middleware
requestLoggingMiddleware :: RequestLogger -> Middleware
requestLoggingMiddleware logger :: RequestLogger
logger@(RequestLogger LoggingConfig
cfg Key RequestContext
key) Application
app Request
request Response -> IO ResponseReceived
respond
  -- Error handlers can enter Spock again with the same request.
  | Just RequestContext
_ <- Key RequestContext -> Vault -> Maybe RequestContext
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key RequestContext
key (Request -> Vault
Wai.vault Request
request) = Application
app Request
request Response -> IO ResponseReceived
respond
  | Bool
otherwise = do
      sid <- case [ByteString
value | (CI ByteString
name, ByteString
value) <- Request -> RequestHeaders
Wai.requestHeaders Request
request, CI ByteString
name CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== LoggingConfig -> CI ByteString
lc_requestIdHeader LoggingConfig
cfg] of
        [ByteString
value] | LoggingConfig -> Bool
lc_trustIncomingRequestId LoggingConfig
cfg, ByteString -> Bool
validId ByteString
value -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
value
        [ByteString]
_ -> do
          generated <- LoggingConfig -> IO Text
lc_generateRequestId LoggingConfig
cfg
          if validId (T.encodeUtf8 generated) then pure generated else generateId
      let context = Text -> Text -> Text -> RequestContext
RequestContext Text
sid (ByteString -> Text
decode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Wai.requestMethod Request
request) (ByteString -> Text
decode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Wai.rawPathInfo Request
request)
          request' = Request
request { Wai.vault = Vault.insert key context (Wai.vault request) }
      start <- getMonotonicTimeNSec
      app request' (\Response
response -> do
        end <- IO Word64
getMonotonicTimeNSec
        emitRequestLog logger context $ AccessLog (statusCode $ Wai.responseStatus response) ((end - start) `div` 1000)
        respond $ Wai.mapResponseHeaders
          (\RequestHeaders
headers -> (LoggingConfig -> CI ByteString
lc_requestIdHeader LoggingConfig
cfg, Text -> ByteString
T.encodeUtf8 Text
sid) (CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: ((CI ByteString, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter ((CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= LoggingConfig -> CI ByteString
lc_requestIdHeader LoggingConfig
cfg) (CI ByteString -> Bool)
-> ((CI ByteString, ByteString) -> CI ByteString)
-> (CI ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI ByteString, ByteString) -> CI ByteString
forall a b. (a, b) -> a
fst) RequestHeaders
headers) response)
        `catch` \(SomeException
err :: SomeException) -> do
          SomeException -> IO ()
rethrowAsync SomeException
err
          RequestLogger -> RequestContext -> LogEventType -> IO ()
emitRequestLog RequestLogger
logger RequestContext
context (LogEventType -> IO ()) -> LogEventType -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogEventType
ErrorLog (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err)
          SomeException -> IO ResponseReceived
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
err
  where
    decode :: ByteString -> Text
decode = OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
lenientDecode

validId :: BS.ByteString -> Bool
validId :: ByteString -> Bool
validId ByteString
value = Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
value) Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
value Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
128 Bool -> Bool -> Bool
&& (Word8 -> Bool) -> ByteString -> Bool
BS.all Word8 -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
allowed ByteString
value
  where
    allowed :: a -> Bool
allowed a
c = (a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
65 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
90) Bool -> Bool -> Bool
|| (a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
97 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
122) Bool -> Bool -> Bool
|| (a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
57) Bool -> Bool -> Bool
|| a
c a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a
45, a
46, a
95]

generateId :: IO Text
generateId :: IO Text
generateId = do
  bytes <- Int -> IO ByteString
Entropy.getEntropy Int
16
  pure $ T.decodeUtf8 $ LBS.toStrict $ Builder.toLazyByteString $
    foldMap Builder.word8HexFixed (BS.unpack bytes)

rethrowAsync :: SomeException -> IO ()
rethrowAsync :: SomeException -> IO ()
rethrowAsync SomeException
err = case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err :: Maybe SomeAsyncException of
  Just SomeAsyncException
_ -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
err
  Maybe SomeAsyncException
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()