{-# 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 qualified Data.Text as T
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy.IO as T
import qualified Data.Vector as V
-------------------------------------------------------------------------------
import Katip.Core
import Katip.Format.Time (formatAsLogTime)
import System.IO

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

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

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

#if MIN_VERSION_aeson(2, 0, 0)
toBuilders :: KM.KeyMap Value -> [[Builder]]
toBuilders :: KeyMap Value -> [[Builder]]
toBuilders = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text, Value) -> [Builder]
renderPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> Text
K.toText) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. KeyMap v -> [(Key, v)]
KM.toList

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

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

renderPair :: (Text, Value) -> [Builder]
renderPair :: (Text, Value) -> [Builder]
renderPair (Text
k, Value
v) =
  case Value
v of
    Object KeyMap Value
o -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(Text, Value) -> [Builder]
renderPair (Text
k forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
k', Value
v') | (Text
k', Value
v') <- forall v. KeyMap v -> [(Text, v)]
toTxtKeyList KeyMap Value
o]
    Array Array
a -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(Text, Value) -> [Builder]
renderPair (Text
k forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
k'), Value
v') | (Int
k', Value
v') <- forall a. Vector a -> [a]
V.toList (forall a. Vector a -> Vector (Int, a)
V.indexed Array
a)]
    String Text
t -> [Text -> Builder
fromText (Text
k forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
t)]
    Number Scientific
n -> [Text -> Builder
fromText (Text
k forall a. Semigroup a => a -> a -> a
<> Text
":") forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString (Scientific -> String
formatNumber Scientific
n)]
    Bool Bool
b -> [Text -> Builder
fromText (Text
k forall a. Semigroup a => a -> a -> a
<> Text
":") forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString (forall a. Show a => a -> String
show Bool
b)]
    Value
Null -> [Text -> Builder
fromText (Text
k forall a. Semigroup a => a -> a -> a
<> Text
":null")]
  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 forall a. Maybe a
Nothing else 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
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
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
  MVar ()
lock <- forall a. a -> IO (MVar a)
newMVar ()
  let logger :: Item a -> IO ()
logger i :: Item a
i@Item {} = do
        forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall a. MVar a -> IO a
takeMVar MVar ()
lock) (forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()) forall a b. (a -> b) -> a -> b
$
          Handle -> Text -> IO ()
T.hPutStrLn Handle
h forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ forall a. LogItem a => ItemFormatter a
itemFormatter Bool
colorize Verbosity
verb Item a
i
  forall (m :: * -> *) a. Monad m => a -> m a
return 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
  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 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 :: forall a. LogItem a => ItemFormatter a
formatItem = 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 :: forall a. LogItem a => 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
    forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Builder
fromText forall a b. (a -> b) -> a -> b
$ Namespace -> [Text]
intercalateNs Namespace
_itemNamespace)
    forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (Text -> Builder
fromText (Severity -> Text
renderSeverity' Severity
_itemSeverity))
    forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (String -> Builder
fromString String
_itemHost)
    forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (Builder
"PID " forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString (forall a. Show a => a -> String
show ProcessID
_itemProcess))
    forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
brackets (Builder
"ThreadId " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (ThreadIdText -> Text
getThreadIdText ThreadIdText
_itemThread))
    forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [Builder]
ks
    forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Builder -> Builder
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
locationToString) Maybe Loc
_itemLoc
    forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
" "
    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 = forall a b. (a -> b) -> [a] -> [b]
map Builder -> Builder
brackets forall a b. (a -> b) -> a -> b
$ 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 :: forall a. LogItem a => ItemFormatter a
jsonFormat Bool
withColor Verbosity
verb Item a
i =
  Text -> Builder
fromText forall a b. (a -> b) -> a -> b
$
    Bool -> Severity -> Text -> Text
colorBySeverity Bool
withColor (forall a. Item a -> Severity
_itemSeverity Item a
i) forall a b. (a -> b) -> a -> b
$
      Text -> Text
toStrict forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ 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 = forall {a}. (Semigroup a, IsString a) => a -> a -> a
colorize Text
"31"
    yellow :: Text -> Text
yellow = forall {a}. (Semigroup a, IsString a) => a -> a -> a
colorize Text
"33"
    colorize :: a -> a -> a
colorize a
c a
s
      | Bool
withColor = a
"\ESC[" forall a. Semigroup a => a -> a -> a
<> a
c forall a. Semigroup a => a -> a -> a
<> a
"m" forall a. Semigroup a => a -> a -> a
<> a
s forall a. Semigroup a => a -> a -> a
<> a
"\ESC[0m"
      | Bool
otherwise = a
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