{-# LANGUAGE CPP #-}

module Katip.Scribes.Handle where

-------------------------------------------------------------------------------
import Control.Concurrent
import Control.Exception (bracket_, finally)
import Data.Aeson
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Bifunctor (Bifunctor (..))
#else
import qualified Data.HashMap.Strict as HM
#endif
import Data.Monoid as M
import Data.Scientific as S
import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy.IO as T
-------------------------------------------------------------------------------
import Katip.Core
import Katip.Format.Time (formatAsLogTime)
import System.IO

-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
brackets :: Builder -> Builder
brackets :: Builder -> Builder
brackets Builder
m = Text -> Builder
fromText Text
"[" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
M.<> Builder
m Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
"]"

-------------------------------------------------------------------------------
getKeys :: LogItem s => Verbosity -> s -> [Builder]
getKeys :: Verbosity -> s -> [Builder]
getKeys Verbosity
verb s
a = [[Builder]] -> [Builder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (HashMap Text Value -> [[Builder]]
toBuilders (Verbosity -> s -> HashMap Text Value
forall a. LogItem a => Verbosity -> a -> HashMap Text Value
payloadObject Verbosity
verb s
a))

#if MIN_VERSION_aeson(2, 0, 0)
toBuilders :: KM.KeyMap Value -> [[Builder]]
toBuilders = fmap (renderPair . first K.toText) . KM.toList

toTxtKeyList :: KM.KeyMap v -> [(Text, v)]
toTxtKeyList mp = first K.toText <$> KM.toList mp
#else
toBuilders :: HM.HashMap Text Value -> [[Builder]]
toBuilders :: HashMap Text Value -> [[Builder]]
toBuilders = ((Text, Value) -> [Builder]) -> [(Text, Value)] -> [[Builder]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Value) -> [Builder]
renderPair ([(Text, Value)] -> [[Builder]])
-> (HashMap Text Value -> [(Text, Value)])
-> HashMap Text Value
-> [[Builder]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList

toTxtKeyList :: HM.HashMap Text v -> [(Text, v)]
toTxtKeyList :: HashMap Text v -> [(Text, v)]
toTxtKeyList = HashMap Text v -> [(Text, v)]
forall k v. HashMap k v -> [(k, v)]
HM.toList
#endif

renderPair :: (Text, Value) -> [Builder]
renderPair :: (Text, Value) -> [Builder]
renderPair (Text
k, Value
v) =
  case Value
v of
    Object HashMap Text Value
o -> [[Builder]] -> [Builder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(Text, Value) -> [Builder]
renderPair (Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k', Value
v') | (Text
k', Value
v') <- HashMap Text Value -> [(Text, Value)]
forall v. HashMap Text v -> [(Text, v)]
toTxtKeyList HashMap Text Value
o]
    String Text
t -> [Text -> Builder
fromText (Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t)]
    Number Scientific
n -> [Text -> Builder
fromText (Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString (Scientific -> String
formatNumber Scientific
n)]
    Bool Bool
b -> [Text -> Builder
fromText (Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString (Bool -> String
forall a. Show a => a -> String
show Bool
b)]
    Value
Null -> [Text -> Builder
fromText (Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":null")]
    Value
_ -> [Builder]
forall a. Monoid a => a
mempty -- Can't think of a sensible way to handle arrays
  where
    formatNumber :: Scientific -> String
    formatNumber :: Scientific -> String
formatNumber Scientific
n =
      FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Generic (if Scientific -> Bool
isFloating Scientific
n then Maybe Int
forall a. Maybe a
Nothing else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) Scientific
n

-------------------------------------------------------------------------------
data ColorStrategy
  = -- | Whether to use color control chars in log output
    ColorLog Bool
  | -- | Color if output is a terminal
    ColorIfTerminal
  deriving (Int -> ColorStrategy -> ShowS
[ColorStrategy] -> ShowS
ColorStrategy -> String
(Int -> ColorStrategy -> ShowS)
-> (ColorStrategy -> String)
-> ([ColorStrategy] -> ShowS)
-> Show ColorStrategy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColorStrategy] -> ShowS
$cshowList :: [ColorStrategy] -> ShowS
show :: ColorStrategy -> String
$cshow :: ColorStrategy -> String
showsPrec :: Int -> ColorStrategy -> ShowS
$cshowsPrec :: Int -> ColorStrategy -> ShowS
Show, ColorStrategy -> ColorStrategy -> Bool
(ColorStrategy -> ColorStrategy -> Bool)
-> (ColorStrategy -> ColorStrategy -> Bool) -> Eq ColorStrategy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorStrategy -> ColorStrategy -> Bool
$c/= :: ColorStrategy -> ColorStrategy -> Bool
== :: ColorStrategy -> ColorStrategy -> Bool
$c== :: ColorStrategy -> ColorStrategy -> Bool
Eq)

-------------------------------------------------------------------------------

-- | Logs to a file handle such as stdout, stderr, or a file. Contexts
-- and other information will be flattened out into bracketed
-- fields. For example:
--
-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
--
-- Returns the newly-created `Scribe`. The finalizer flushes the
-- handle. Handle mode is set to 'LineBuffering' automatically.
mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribe = (forall a. LogItem a => ItemFormatter a)
-> ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribeWithFormatter forall a. LogItem a => ItemFormatter a
bracketFormat

-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
-- `ItemFormatter` that can be used to format `Item` as needed.
--
-- Returns the newly-created `Scribe`. The finalizer flushes the
-- handle. Handle mode is set to 'LineBuffering' automatically.
mkHandleScribeWithFormatter ::
  (forall a. LogItem a => ItemFormatter a) ->
  ColorStrategy ->
  Handle ->
  PermitFunc ->
  Verbosity ->
  IO Scribe
mkHandleScribeWithFormatter :: (forall a. LogItem a => ItemFormatter a)
-> ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribeWithFormatter forall a. LogItem a => ItemFormatter a
itemFormatter ColorStrategy
cs Handle
h PermitFunc
permitF Verbosity
verb = do
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
  Bool
colorize <- case ColorStrategy
cs of
    ColorStrategy
ColorIfTerminal -> Handle -> IO Bool
hIsTerminalDevice Handle
h
    ColorLog Bool
b -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
  MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  let logger :: Item a -> IO ()
logger i :: Item a
i@Item {} = do
        IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock) (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Handle -> Text -> IO ()
T.hPutStrLn Handle
h (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ ItemFormatter a
forall a. LogItem a => ItemFormatter a
itemFormatter Bool
colorize Verbosity
verb Item a
i
  Scribe -> IO Scribe
forall (m :: * -> *) a. Monad m => a -> m a
return (Scribe -> IO Scribe) -> Scribe -> IO Scribe
forall a b. (a -> b) -> a -> b
$ (forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
Scribe forall a. LogItem a => Item a -> IO ()
logger (Handle -> IO ()
hFlush Handle
h) PermitFunc
permitF

-------------------------------------------------------------------------------

-- | A specialization of 'mkHandleScribe' that takes a 'FilePath'
-- instead of a 'Handle'. It is responsible for opening the file in
-- 'AppendMode' and will close the file handle on
-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
-- to 'LineBuffering' mode.
mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
mkFileScribe :: String -> PermitFunc -> Verbosity -> IO Scribe
mkFileScribe String
f PermitFunc
permitF Verbosity
verb = do
  Handle
h <- String -> IOMode -> IO Handle
openFile String
f IOMode
AppendMode
  Scribe forall a. LogItem a => Item a -> IO ()
logger IO ()
finalizer PermitFunc
permit <- ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribe (Bool -> ColorStrategy
ColorLog Bool
False) Handle
h PermitFunc
permitF Verbosity
verb
  Scribe -> IO Scribe
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
Scribe forall a. LogItem a => Item a -> IO ()
logger (IO ()
finalizer IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
h) PermitFunc
permit)

-------------------------------------------------------------------------------

-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
-- whether to colorize the output, `Verbosity` of output, and an `Item` to
-- format.
--
-- See `bracketFormat` and `jsonFormat` for examples.
type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder

formatItem :: LogItem a => ItemFormatter a
formatItem :: ItemFormatter a
formatItem = ItemFormatter a
forall a. LogItem a => ItemFormatter a
bracketFormat
{-# DEPRECATED formatItem "Use bracketFormat instead" #-}

-- | A traditional 'bracketed' log format. Contexts and other information will
-- be flattened out into bracketed fields. For example:
--
-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
bracketFormat :: LogItem a => ItemFormatter a
bracketFormat :: ItemFormatter a
bracketFormat Bool
withColor Verbosity
verb Item {a
String
Maybe Loc
UTCTime
ProcessID
ThreadIdText
LogStr
Severity
Environment
Namespace
_itemLoc :: forall a. Item a -> Maybe Loc
_itemNamespace :: forall a. Item a -> Namespace
_itemTime :: forall a. Item a -> UTCTime
_itemMessage :: forall a. Item a -> LogStr
_itemPayload :: forall a. Item a -> a
_itemProcess :: forall a. Item a -> ProcessID
_itemHost :: forall a. Item a -> String
_itemThread :: forall a. Item a -> ThreadIdText
_itemSeverity :: forall a. Item a -> Severity
_itemEnv :: forall a. Item a -> Environment
_itemApp :: forall a. Item a -> Namespace
_itemLoc :: Maybe Loc
_itemNamespace :: Namespace
_itemTime :: UTCTime
_itemMessage :: LogStr
_itemPayload :: a
_itemProcess :: ProcessID
_itemHost :: String
_itemThread :: ThreadIdText
_itemSeverity :: Severity
_itemEnv :: Environment
_itemApp :: Namespace
..} =
  Builder -> Builder
brackets Builder
nowStr
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (Text -> Builder) -> [Text] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Builder
fromText ([Text] -> [Builder]) -> [Text] -> [Builder]
forall a b. (a -> b) -> a -> b
$ Namespace -> [Text]
intercalateNs Namespace
_itemNamespace)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (Text -> Builder
fromText (Severity -> Text
renderSeverity' Severity
_itemSeverity))
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (String -> Builder
fromString String
_itemHost)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (Builder
"PID " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString (ProcessID -> String
forall a. Show a => a -> String
show ProcessID
_itemProcess))
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (Builder
"ThreadId " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (ThreadIdText -> Text
getThreadIdText ThreadIdText
_itemThread))
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
ks
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> (Loc -> Builder) -> Maybe Loc -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (Builder -> Builder
brackets (Builder -> Builder) -> (Loc -> Builder) -> Loc -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
fromString (String -> Builder) -> (Loc -> String) -> Loc -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
locationToString) Maybe Loc
_itemLoc
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
" "
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (LogStr -> Builder
unLogStr LogStr
_itemMessage)
  where
    nowStr :: Builder
nowStr = Text -> Builder
fromText (UTCTime -> Text
formatAsLogTime UTCTime
_itemTime)
    ks :: [Builder]
ks = (Builder -> Builder) -> [Builder] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Builder -> Builder
brackets ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ Verbosity -> a -> [Builder]
forall s. LogItem s => Verbosity -> s -> [Builder]
getKeys Verbosity
verb a
_itemPayload
    renderSeverity' :: Severity -> Text
renderSeverity' Severity
severity =
      Bool -> Severity -> Text -> Text
colorBySeverity Bool
withColor Severity
severity (Severity -> Text
renderSeverity Severity
severity)

-- | Logs items as JSON. This can be useful in circumstances where you already
-- have infrastructure that is expecting JSON to be logged to a standard stream
-- or file. For example:
--
-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Started","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":44},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}
-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
jsonFormat :: LogItem a => ItemFormatter a
jsonFormat :: ItemFormatter a
jsonFormat Bool
withColor Verbosity
verb Item a
i =
  Text -> Builder
fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$
    Bool -> Severity -> Text -> Text
colorBySeverity Bool
withColor (Item a -> Severity
forall a. Item a -> Severity
_itemSeverity Item a
i) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
      Text -> Text
toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Verbosity -> Item a -> Value
forall a. LogItem a => Verbosity -> Item a -> Value
itemJson Verbosity
verb Item a
i

-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
-- are colored red, `WarningS` is colored yellow, and all other messages are
-- rendered in the default color.
colorBySeverity :: Bool -> Severity -> Text -> Text
colorBySeverity :: Bool -> Severity -> Text -> Text
colorBySeverity Bool
withColor Severity
severity Text
msg = case Severity
severity of
  Severity
EmergencyS -> Text -> Text
red Text
msg
  Severity
AlertS -> Text -> Text
red Text
msg
  Severity
CriticalS -> Text -> Text
red Text
msg
  Severity
ErrorS -> Text -> Text
red Text
msg
  Severity
WarningS -> Text -> Text
yellow Text
msg
  Severity
_ -> Text
msg
  where
    red :: Text -> Text
red = Text -> Text -> Text
forall p. (Semigroup p, IsString p) => p -> p -> p
colorize Text
"31"
    yellow :: Text -> Text
yellow = Text -> Text -> Text
forall p. (Semigroup p, IsString p) => p -> p -> p
colorize Text
"33"
    colorize :: p -> p -> p
colorize p
c p
s
      | Bool
withColor = p
"\ESC[" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
c p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
"m" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
s p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
"\ESC[0m"
      | Bool
otherwise = p
s

-- | Provides a simple log environment with 1 scribe going to
-- stdout. This is a decent example of how to build a LogEnv and is
-- best for scripts that just need a quick, reasonable set up to log
-- to stdout.
ioLogEnv :: PermitFunc -> Verbosity -> IO LogEnv
ioLogEnv :: PermitFunc -> Verbosity -> IO LogEnv
ioLogEnv PermitFunc
permit Verbosity
verb = do
  LogEnv
le <- Namespace -> Environment -> IO LogEnv
initLogEnv Namespace
"io" Environment
"io"
  Scribe
lh <- ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribe ColorStrategy
ColorIfTerminal Handle
stdout PermitFunc
permit Verbosity
verb
  Text -> Scribe -> ScribeSettings -> LogEnv -> IO LogEnv
registerScribe Text
"stdout" Scribe
lh ScribeSettings
defaultScribeSettings LogEnv
le