-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Monad.Error
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, BangPatterns #-}
{- | Functions for logging.

    Log msgs are used to report everything from errors and debug msgs to status
    reports.  They are collected in a central place that writes them to a file
    in a machine-readable serialized format.
-}
module Util.Log (
    -- * setup
    configure
    , rotate, rotate_config
    , with_stdio_lock
    -- * msgs
    , Msg(..), msg_string
    -- ** data
    , with_int, with_text, with_dyn
    , lookup_int, lookup_text, lookup_dyn
    -- ** other types
    , Priority(..), State(..)
    , write_json, write_formatted
    , msg, msg_call_stack
    , log
    , timer, debug, notice, warn, error
    , debug_stack, notice_stack, warn_stack, error_stack
    , add_prefix
    -- * LogT monad
    , LogMonad(..)
    , LogT, run, LogId, run_id
    , format_msg
    , serialize, deserialize
) where
import           Prelude hiding (error, log)
import qualified Control.Concurrent.MVar as MVar
import qualified Control.DeepSeq as DeepSeq
import qualified Control.Monad.Error as Error
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.Reader as Reader
import qualified Control.Monad.State as State
import qualified Control.Monad.State.Lazy as State.Lazy
import qualified Control.Monad.State.Strict as State.Strict
import qualified Control.Monad.Trans as Trans
import qualified Control.Monad.Writer.Lazy as Writer

import qualified Data.Aeson as Aeson
import           Data.Aeson (parseJSON, toJSON)
import qualified Data.Aeson.Types as Aeson.Types
import qualified Data.ByteString.Lazy as ByteString.Lazy
import qualified Data.Char as Char
import qualified Data.Dynamic as Dynamic
import qualified Data.Map.Strict as Map
import qualified Data.Monoid as Monoid
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Time as Time
import qualified Data.Vector as Vector

import qualified GHC.Generics as Generics
import qualified GHC.Stack
import qualified Numeric
import qualified System.Directory as Directory
import qualified System.Environment as Environment
import qualified System.FilePath as FilePath
import qualified System.IO as IO
import qualified System.IO.Unsafe as Unsafe
import qualified System.Posix as Posix
import qualified System.Process as Process

import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.Read as Read

import qualified Util.CallStack as CallStack
import qualified Util.Exceptions as Exceptions
import qualified Util.Logger as Logger
import qualified Util.Serialize as Serialize
import           Util.Serialize (get, get_tag, put, put_tag)

import qualified Derive.Stack as Stack

import           Global


data Msg = Msg {
    Msg -> UTCTime
msg_date :: !Time.UTCTime
    , Msg -> Caller
msg_caller :: !CallStack.Caller
    , Msg -> Priority
msg_priority :: !Priority
    -- | Msgs which are logged from the deriver may record the position in the
    -- score the msg was emitted.
    , Msg -> Maybe Stack
msg_stack :: !(Maybe Stack.Stack)
    -- | Free form text for humans.
    , Msg -> Text
msg_text :: !Text
    , Msg -> Map Text Data
msg_data :: !(Map.Map Text Data)
    } deriving (Msg -> Msg -> Bool
(Msg -> Msg -> Bool) -> (Msg -> Msg -> Bool) -> Eq Msg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Msg -> Msg -> Bool
$c/= :: Msg -> Msg -> Bool
== :: Msg -> Msg -> Bool
$c== :: Msg -> Msg -> Bool
Eq, Int -> Msg -> ShowS
[Msg] -> ShowS
Msg -> String
(Int -> Msg -> ShowS)
-> (Msg -> String) -> ([Msg] -> ShowS) -> Show Msg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Msg] -> ShowS
$cshowList :: [Msg] -> ShowS
show :: Msg -> String
$cshow :: Msg -> String
showsPrec :: Int -> Msg -> ShowS
$cshowsPrec :: Int -> Msg -> ShowS
Show, ReadPrec [Msg]
ReadPrec Msg
Int -> ReadS Msg
ReadS [Msg]
(Int -> ReadS Msg)
-> ReadS [Msg] -> ReadPrec Msg -> ReadPrec [Msg] -> Read Msg
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Msg]
$creadListPrec :: ReadPrec [Msg]
readPrec :: ReadPrec Msg
$creadPrec :: ReadPrec Msg
readList :: ReadS [Msg]
$creadList :: ReadS [Msg]
readsPrec :: Int -> ReadS Msg
$creadsPrec :: Int -> ReadS Msg
Read)

instance DeepSeq.NFData Msg where
    rnf :: Msg -> ()
rnf Msg
msg = Map Text Data -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf (Msg -> Map Text Data
msg_data Msg
msg) () -> () -> ()
`seq` Msg
msg Msg -> () -> ()
`seq` ()

msg_string :: Msg -> String
msg_string :: Msg -> String
msg_string = Text -> String
Text.unpack (Text -> String) -> (Msg -> Text) -> Msg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Text
msg_text

instance Pretty Msg where pretty :: Msg -> Text
pretty = Msg -> Text
format_msg

-- ** data

-- | Attach some semi-structured data to a log msg.  Simple data can then be
-- analyzed without having to parse the text.
data Data = NoData | Int !Int | Text !Text
    -- | Sneak out any domain-specific type, probably for debugging.  Since it
    -- can't be serialized, it will turn into @Text (show dyn)@.
    | Dynamic !Dynamic.Dynamic

instance DeepSeq.NFData Data where
    rnf :: Data -> ()
rnf Data
_ = ()

instance Eq Data where
    Data
a == :: Data -> Data -> Bool
== Data
b = case (Data
a, Data
b) of
        (Data
NoData, Data
NoData) -> Bool
True
        (Int Int
x, Int Int
y) -> Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y
        (Text Text
x, Text Text
y) -> Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
y
        (Dynamic Dynamic
_, Dynamic Dynamic
_) -> Bool
False
        (Data, Data)
_ -> Bool
False

with_int :: Text -> Int -> Msg -> Msg
with_int :: Text -> Int -> Msg -> Msg
with_int Text
tag = Text -> Data -> Msg -> Msg
with_data Text
tag (Data -> Msg -> Msg) -> (Int -> Data) -> Int -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Data
Int

with_text :: Text -> Text -> Msg -> Msg
with_text :: Text -> Text -> Msg -> Msg
with_text Text
tag = Text -> Data -> Msg -> Msg
with_data Text
tag (Data -> Msg -> Msg) -> (Text -> Data) -> Text -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Data
Text

with_dyn :: Dynamic.Typeable a => Text -> a -> Msg -> Msg
with_dyn :: forall a. Typeable a => Text -> a -> Msg -> Msg
with_dyn Text
tag = Text -> Data -> Msg -> Msg
with_data Text
tag (Data -> Msg -> Msg) -> (a -> Data) -> a -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Data
Dynamic (Dynamic -> Data) -> (a -> Dynamic) -> a -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Dynamic
forall a. Typeable a => a -> Dynamic
Dynamic.toDyn

with_data :: Text -> Data -> Msg -> Msg
with_data :: Text -> Data -> Msg -> Msg
with_data Text
tag Data
val Msg
msg = Msg
msg { msg_data :: Map Text Data
msg_data = Text -> Data -> Map Text Data -> Map Text Data
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
tag Data
val (Msg -> Map Text Data
msg_data Msg
msg) }

lookup_int :: Text -> Msg -> Maybe Int
lookup_int :: Text -> Msg -> Maybe Int
lookup_int Text
tag Msg
msg = case Text -> Map Text Data -> Maybe Data
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tag (Msg -> Map Text Data
msg_data Msg
msg) of
    Just (Int Int
v) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
v
    Maybe Data
_ -> Maybe Int
forall a. Maybe a
Nothing

lookup_text :: Text -> Msg -> Maybe Text
lookup_text :: Text -> Msg -> Maybe Text
lookup_text Text
tag Msg
msg = case Text -> Map Text Data -> Maybe Data
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tag (Msg -> Map Text Data
msg_data Msg
msg) of
    Just (Text Text
v) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v
    Maybe Data
_ -> Maybe Text
forall a. Maybe a
Nothing

lookup_dyn :: Dynamic.Typeable a => Text -> Msg -> Maybe a
lookup_dyn :: forall a. Typeable a => Text -> Msg -> Maybe a
lookup_dyn Text
tag Msg
msg = case Text -> Map Text Data -> Maybe Data
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tag (Msg -> Map Text Data
msg_data Msg
msg) of
    Just (Dynamic Dynamic
dyn) -> Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
Dynamic.fromDynamic Dynamic
dyn
    Maybe Data
_ -> Maybe a
forall a. Maybe a
Nothing

instance Show Data where
    show :: Data -> String
show Data
NoData = String
"NoData"
    -- This omits parens for negative numbers but I don't care much.
    show (Int Int
int) = String
"Int " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
int
    show (Text Text
text) = String
"Text " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
text
    show (Dynamic Dynamic
dyn) =
        String
"Dynamic " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"') (SomeTypeRep -> String
forall a. Show a => a -> String
show (Dynamic -> SomeTypeRep
Dynamic.dynTypeRep Dynamic
dyn)))

instance Read.Read Data where readPrec :: ReadPrec Data
readPrec = ReadP Data -> ReadPrec Data
forall a. ReadP a -> ReadPrec a
Read.lift ReadP Data
read_data

read_data :: ReadP.ReadP Data
read_data :: ReadP Data
read_data = [ReadP Data] -> ReadP Data
forall a. [ReadP a] -> ReadP a
ReadP.choice
    [ String -> ReadP String
ReadP.string String
"NoData" ReadP String -> ReadP Data -> ReadP Data
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Data -> ReadP Data
forall (f :: * -> *) a. Applicative f => a -> f a
pure Data
NoData
    , Int -> Data
Int (Int -> Data) -> ReadP Int -> ReadP Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ReadP String
ReadP.string String
"Int " ReadP String -> ReadP Int -> ReadP Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP Int
p_int)
    , Text -> Data
Text (Text -> Data) -> (String -> Text) -> String -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Data) -> ReadP String -> ReadP Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ReadP String
ReadP.string String
"Text " ReadP String -> ReadP String -> ReadP String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP String
p_text)
    , Text -> Data
Text (Text -> Data) -> (String -> Text) -> String -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Data) -> ReadP String -> ReadP Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ReadP String
ReadP.string String
"Dynamic " ReadP String -> ReadP String -> ReadP String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP String
p_text)
    ]
    where
    -- This will break if there is \" in there.  Surely there's a function
    -- to parse a haskell string?
    p_text :: ReadP String
p_text = ReadP String -> ReadP String -> ReadP String -> ReadP String
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
ReadP.between (String -> ReadP String
ReadP.string String
"\"") (String -> ReadP String
ReadP.string String
"\"")
        ((Char -> Bool) -> ReadP String
ReadP.munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"'))
    p_int :: ReadP Int
p_int = ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
ReadP.readS_to_P (ReadS Int -> ReadS Int
forall a. Real a => ReadS a -> ReadS a
Numeric.readSigned ReadS Int
forall a. (Eq a, Num a) => ReadS a
Numeric.readDec)

-- ** other types

-- | Pure code can't give a date, but making msg_date Maybe makes it awkward
-- for everyone who processes Msgs, so cheat with this.
no_date_yet :: Time.UTCTime
no_date_yet :: UTCTime
no_date_yet = Day -> DiffTime -> UTCTime
Time.UTCTime (Integer -> Day
Time.ModifiedJulianDay Integer
0) DiffTime
0

-- | Logging state.  Don't log if a handle is Nothing.
data State = State {
    State -> Msg -> IO ()
state_write_msg :: Msg -> IO ()
    , State -> Priority
state_priority :: Priority
    }

-- | Write logs as JSON to the given handle.
write_json :: IO.Handle -> Msg -> IO ()
write_json :: Handle -> Msg -> IO ()
write_json Handle
hdl Msg
log_msg = do
    Handle -> ByteString -> IO ()
ByteString.Lazy.hPut Handle
hdl (Msg -> ByteString
serialize Msg
log_msg)
    Handle -> ByteString -> IO ()
ByteString.Lazy.hPut Handle
hdl ByteString
"\n"

-- | Write logs as human-readable text.
write_formatted :: IO.Handle -> Msg -> IO ()
write_formatted :: Handle -> Msg -> IO ()
write_formatted Handle
hdl = Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
hdl (Text -> IO ()) -> (Msg -> Text) -> Msg -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Text
format_msg

initial_state :: State
initial_state :: State
initial_state = State
    { state_write_msg :: Msg -> IO ()
state_write_msg = Handle -> Msg -> IO ()
write_formatted Handle
IO.stderr
    , state_priority :: Priority
state_priority = Priority
Notice
    }

{-# NOINLINE global_state #-}
global_state :: MVar.MVar State
global_state :: MVar State
global_state = IO (MVar State) -> MVar State
forall a. IO a -> a
Unsafe.unsafePerformIO (State -> IO (MVar State)
forall a. a -> IO (MVar a)
MVar.newMVar State
initial_state)

-- * setup

rotate :: FilePath -> IO IO.Handle
rotate :: String -> IO Handle
rotate = Int -> Int -> String -> IO Handle
rotate_config Int
4 (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mb)
    where mb :: Int
mb = Int
1024Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2

-- | Get a file handle for writing log msgs, first rotating logs if necessary.
rotate_config :: Int -> Int -> FilePath -> IO IO.Handle
rotate_config :: Int -> Int -> String -> IO Handle
rotate_config Int
keep Int
max_size String
log_fn = do
    let rotated_fn :: a -> String
rotated_fn a
n = String
log_fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".gz"
    FileOffset
size <- FileOffset
-> (FileStatus -> FileOffset) -> Maybe FileStatus -> FileOffset
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FileOffset
0 FileStatus -> FileOffset
Posix.fileSize (Maybe FileStatus -> FileOffset)
-> IO (Maybe FileStatus) -> IO FileOffset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FileStatus -> IO (Maybe FileStatus)
forall {a}. IO a -> IO (Maybe a)
ignore (String -> IO FileStatus
Posix.getFileStatus String
log_fn)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileOffset
size FileOffset -> FileOffset -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
max_size) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [(Int, Int)] -> ((Int, Int) -> IO (Maybe ())) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a]
reverse ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..Int
keep] (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int
1..Int
keep]))) (((Int, Int) -> IO (Maybe ())) -> IO ())
-> ((Int, Int) -> IO (Maybe ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
from, Int
to) ->
            IO () -> IO (Maybe ())
forall {a}. IO a -> IO (Maybe a)
ignore (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
Directory.renameFile (Int -> String
forall a. Show a => a -> String
rotated_fn Int
from) (Int -> String
forall a. Show a => a -> String
rotated_fn Int
to)
        let fn :: String
fn = ShowS
FilePath.dropExtension (Integer -> String
forall a. Show a => a -> String
rotated_fn Integer
1)
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"rotate logs " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
log_fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fn
        IO () -> IO (Maybe ())
forall {a}. IO a -> IO (Maybe a)
ignore (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
Directory.renameFile String
log_fn String
fn
        ProcessHandle -> IO ExitCode
Process.waitForProcess (ProcessHandle -> IO ExitCode) -> IO ProcessHandle -> IO ExitCode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
Process.runProcess String
"gzip" [String
fn]
            Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Handle
hdl <- String -> IOMode -> IO Handle
IO.openFile String
log_fn IOMode
IO.AppendMode
    -- Logs are per-line, so ensure they go out promptly.
    Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
hdl BufferMode
IO.LineBuffering
    Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
hdl
    where ignore :: IO a -> IO (Maybe a)
ignore = IO a -> IO (Maybe a)
forall {a}. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent

-- | Configure the logging system by modifying its internal state.
configure :: (State -> State) -> IO ()
configure :: (State -> State) -> IO ()
configure State -> State
f = MVar State -> (State -> IO State) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ MVar State
global_state (State -> IO State
with_log_config (State -> IO State) -> (State -> State) -> State -> IO State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
f)

with_log_config :: State -> IO State
with_log_config :: State -> IO State
with_log_config State
state = do
    String
config_str <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
Environment.lookupEnv String
"LOG_CONFIG"
    (Text -> IO State)
-> (State -> IO State) -> Either Text State -> IO State
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> IO State
forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO State -> IO State
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text State -> IO State) -> Either Text State -> IO State
forall a b. (a -> b) -> a -> b
$ String -> State -> Either Text State
parse_log_config String
config_str State
state

parse_log_config :: String -> State -> Either Text State
parse_log_config :: String -> State -> Either Text State
parse_log_config String
str State
state
    | String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = State -> Either Text State
forall a b. b -> Either a b
Right State
state
    | Just Priority
prio <- String -> Map String Priority -> Maybe Priority
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ShowS
lower String
str) Map String Priority
priorities =
        State -> Either Text State
forall a b. b -> Either a b
Right (State -> Either Text State) -> State -> Either Text State
forall a b. (a -> b) -> a -> b
$ State
state { state_priority :: Priority
state_priority = Priority
prio }
    | Bool
otherwise = Text -> Either Text State
forall a b. a -> Either a b
Left (Text -> Either Text State) -> Text -> Either Text State
forall a b. (a -> b) -> a -> b
$ Text
"can't parse LOG_CONFIG: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (ShowS
forall a. Show a => a -> String
show String
str)
    where
    priorities :: Map String Priority
priorities = [(String, Priority)] -> Map String Priority
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, Priority)] -> Map String Priority)
-> [(String, Priority)] -> Map String Priority
forall a b. (a -> b) -> a -> b
$ [String] -> [Priority] -> [(String, Priority)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Priority -> String) -> [Priority] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS
lower ShowS -> (Priority -> String) -> Priority -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> String
forall a. Show a => a -> String
show) [Priority]
ps) [Priority]
ps
        where ps :: [Priority]
ps = [Priority
forall a. Bounded a => a
minBound .. Priority
forall a. Bounded a => a
maxBound] :: [Priority]
    lower :: ShowS
lower = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower

-- | Reuse the log lock, presumably to write to stdout or stderr.  It doesn't
-- really belong here, but stdout and stderr are already global, so reusing
-- a lock for them doesn't seem like a big deal.
with_stdio_lock :: IO () -> IO ()
with_stdio_lock :: IO () -> IO ()
with_stdio_lock IO ()
action = do
    MVar State -> (State -> IO State) -> IO State
forall a b. MVar a -> (a -> IO b) -> IO b
MVar.withMVar MVar State
global_state ((State -> IO State) -> IO State)
-> (State -> IO State) -> IO State
forall a b. (a -> b) -> a -> b
$ \State
state -> IO ()
action IO () -> IO State -> IO State
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State -> IO State
forall (m :: * -> *) a. Monad m => a -> m a
return State
state
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

data Priority =
    -- | Logs to determine where things are hanging when debugging
    -- a performance problem.  Use "LogView.ShowTimers" to show the time
    -- elapsed between Timer logs.
    Timer
    -- | Users don't look at this during normal use, but can be useful for
    -- debugging.
    | Debug
    -- | Informational msgs that the user might want to see.  Progress messages
    -- in e.g. derivation and play status are included here.
    | Notice
    -- | Something went wrong in e.g. derivation.  The user definitely wants to
    -- see this.
    | Warn
    -- | Unexpected error in the app, which may quit.  This is probably due to
    -- a bug.
    | Error
    deriving (Priority
Priority -> Priority -> Bounded Priority
forall a. a -> a -> Bounded a
maxBound :: Priority
$cmaxBound :: Priority
minBound :: Priority
$cminBound :: Priority
Bounded, Int -> Priority
Priority -> Int
Priority -> [Priority]
Priority -> Priority
Priority -> Priority -> [Priority]
Priority -> Priority -> Priority -> [Priority]
(Priority -> Priority)
-> (Priority -> Priority)
-> (Int -> Priority)
-> (Priority -> Int)
-> (Priority -> [Priority])
-> (Priority -> Priority -> [Priority])
-> (Priority -> Priority -> [Priority])
-> (Priority -> Priority -> Priority -> [Priority])
-> Enum Priority
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Priority -> Priority -> Priority -> [Priority]
$cenumFromThenTo :: Priority -> Priority -> Priority -> [Priority]
enumFromTo :: Priority -> Priority -> [Priority]
$cenumFromTo :: Priority -> Priority -> [Priority]
enumFromThen :: Priority -> Priority -> [Priority]
$cenumFromThen :: Priority -> Priority -> [Priority]
enumFrom :: Priority -> [Priority]
$cenumFrom :: Priority -> [Priority]
fromEnum :: Priority -> Int
$cfromEnum :: Priority -> Int
toEnum :: Int -> Priority
$ctoEnum :: Int -> Priority
pred :: Priority -> Priority
$cpred :: Priority -> Priority
succ :: Priority -> Priority
$csucc :: Priority -> Priority
Enum, Int -> Priority -> ShowS
[Priority] -> ShowS
Priority -> String
(Int -> Priority -> ShowS)
-> (Priority -> String) -> ([Priority] -> ShowS) -> Show Priority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Priority] -> ShowS
$cshowList :: [Priority] -> ShowS
show :: Priority -> String
$cshow :: Priority -> String
showsPrec :: Int -> Priority -> ShowS
$cshowsPrec :: Int -> Priority -> ShowS
Show, ReadPrec [Priority]
ReadPrec Priority
Int -> ReadS Priority
ReadS [Priority]
(Int -> ReadS Priority)
-> ReadS [Priority]
-> ReadPrec Priority
-> ReadPrec [Priority]
-> Read Priority
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Priority]
$creadListPrec :: ReadPrec [Priority]
readPrec :: ReadPrec Priority
$creadPrec :: ReadPrec Priority
readList :: ReadS [Priority]
$creadList :: ReadS [Priority]
readsPrec :: Int -> ReadS Priority
$creadsPrec :: Int -> ReadS Priority
Read, Priority -> Priority -> Bool
(Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool) -> Eq Priority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Priority -> Priority -> Bool
$c/= :: Priority -> Priority -> Bool
== :: Priority -> Priority -> Bool
$c== :: Priority -> Priority -> Bool
Eq, Eq Priority
Eq Priority
-> (Priority -> Priority -> Ordering)
-> (Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool)
-> (Priority -> Priority -> Priority)
-> (Priority -> Priority -> Priority)
-> Ord Priority
Priority -> Priority -> Bool
Priority -> Priority -> Ordering
Priority -> Priority -> Priority
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Priority -> Priority -> Priority
$cmin :: Priority -> Priority -> Priority
max :: Priority -> Priority -> Priority
$cmax :: Priority -> Priority -> Priority
>= :: Priority -> Priority -> Bool
$c>= :: Priority -> Priority -> Bool
> :: Priority -> Priority -> Bool
$c> :: Priority -> Priority -> Bool
<= :: Priority -> Priority -> Bool
$c<= :: Priority -> Priority -> Bool
< :: Priority -> Priority -> Bool
$c< :: Priority -> Priority -> Bool
compare :: Priority -> Priority -> Ordering
$ccompare :: Priority -> Priority -> Ordering
Ord, (forall x. Priority -> Rep Priority x)
-> (forall x. Rep Priority x -> Priority) -> Generic Priority
forall x. Rep Priority x -> Priority
forall x. Priority -> Rep Priority x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Priority x -> Priority
$cfrom :: forall x. Priority -> Rep Priority x
Generics.Generic)

-- | Create a msg without initializing it, so it doesn't have to be in
-- LogMonad.
msg :: CallStack.Stack => Priority -> Maybe Stack.Stack -> Text -> Msg
msg :: Stack => Priority -> Maybe Stack -> Text -> Msg
msg = CallStack -> Priority -> Maybe Stack -> Text -> Msg
msg_call_stack CallStack
Stack => CallStack
GHC.Stack.callStack

-- | Like 'msg' but when you already have a CallStack.
msg_call_stack :: GHC.Stack.CallStack -> Priority -> Maybe Stack.Stack -> Text
    -> Msg
msg_call_stack :: CallStack -> Priority -> Maybe Stack -> Text -> Msg
msg_call_stack CallStack
call_stack Priority
prio Maybe Stack
stack Text
text =
    UTCTime
-> Caller
-> Priority
-> Maybe Stack
-> Text
-> Map Text Data
-> Msg
Msg UTCTime
no_date_yet (CallStack -> Caller
CallStack.caller CallStack
call_stack) Priority
prio Maybe Stack
stack Text
text Map Text Data
forall a. Monoid a => a
mempty

log :: (CallStack.Stack, LogMonad m) => Priority -> Text -> m ()
log :: forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Text -> m ()
log Priority
prio Text
text = Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
write (Msg -> m ()) -> Msg -> m ()
forall a b. (a -> b) -> a -> b
$ Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
msg Priority
prio Maybe Stack
forall a. Maybe a
Nothing Text
text

log_stack :: (CallStack.Stack, LogMonad m) => Priority -> Stack.Stack -> Text
    -> m ()
log_stack :: forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Stack -> Text -> m ()
log_stack Priority
prio Stack
stack Text
text = Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
write (Msg -> m ()) -> Msg -> m ()
forall a b. (a -> b) -> a -> b
$ Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
msg Priority
prio (Stack -> Maybe Stack
forall a. a -> Maybe a
Just Stack
stack) Text
text

timer, debug, notice, warn, error
    :: (CallStack.Stack, LogMonad m) => Text -> m ()
timer :: forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
timer = Priority -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Text -> m ()
log Priority
Timer
debug :: forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
debug = Priority -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Text -> m ()
log Priority
Debug
notice :: forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
notice = Priority -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Text -> m ()
log Priority
Notice
warn :: forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
warn = Priority -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Text -> m ()
log Priority
Warn
error :: forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
error = Priority -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Text -> m ()
log Priority
Error

-- Yay permutation game.  I could probably do a typeclass trick to make 'stack'
-- an optional arg, but I think I'd wind up with all the same boilerplate here.
debug_stack, notice_stack, warn_stack, error_stack
    :: (CallStack.Stack, LogMonad m) => Stack.Stack -> Text -> m ()
debug_stack :: forall (m :: * -> *). (Stack, LogMonad m) => Stack -> Text -> m ()
debug_stack = Priority -> Stack -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Stack -> Text -> m ()
log_stack Priority
Debug
notice_stack :: forall (m :: * -> *). (Stack, LogMonad m) => Stack -> Text -> m ()
notice_stack = Priority -> Stack -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Stack -> Text -> m ()
log_stack Priority
Notice
warn_stack :: forall (m :: * -> *). (Stack, LogMonad m) => Stack -> Text -> m ()
warn_stack = Priority -> Stack -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Stack -> Text -> m ()
log_stack Priority
Warn
error_stack :: forall (m :: * -> *). (Stack, LogMonad m) => Stack -> Text -> m ()
error_stack = Priority -> Stack -> Text -> m ()
forall (m :: * -> *).
(Stack, LogMonad m) =>
Priority -> Stack -> Text -> m ()
log_stack Priority
Error

-- | Prefix a msg with the given string.
add_prefix :: Text -> Msg -> Msg
add_prefix :: Text -> Msg -> Msg
add_prefix Text
pref Msg
m = Msg
m { msg_text :: Text
msg_text = Text
pref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Msg -> Text
msg_text Msg
m }

-- * LogT

-- | Previously there was an initialize_msg method, which could use the
-- LogMonad to fill in fields, e.g. 'add_time'.  Those things can happen in
-- 'write' too, but the msg could be created in a different context from the
-- call to 'write'.  In practice, though, I don't do that very much, and when
-- I did it was usually because I wasn't in a LogMonad at all, so I used the
-- pure 'msg' function.
class Monad m => LogMonad m where
    write :: Msg -> m ()

instance LogMonad IO where
    write :: Msg -> IO ()
write Msg
log_msg = MVar State -> (State -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
MVar.withMVar MVar State
global_state ((State -> IO ()) -> IO ()) -> (State -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(State Msg -> IO ()
write_msg Priority
prio) ->
        -- global_state also acts as a lock.
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
prio Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
<= Msg -> Priority
msg_priority Msg
log_msg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Msg
log_msg <- Msg -> IO Msg
add_time Msg
log_msg
            Msg -> IO ()
write_msg Msg
log_msg

-- | Format a msg in a nice user readable way.
format_msg :: Msg -> Text
format_msg :: Msg -> Text
format_msg (Msg UTCTime
_date Caller
caller Priority
prio Maybe Stack
stack Text
text Map Text Data
_data) =
    Text
log_msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Stack -> Text) -> Maybe Stack -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
" "<>) (Text -> Text) -> (Stack -> Text) -> Stack -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Text
forall a. Pretty a => a -> Text
pretty) Maybe Stack
stack
    where
    prio_symbol :: Priority -> Text
prio_symbol Priority
Timer = Text
"/"
    prio_symbol Priority
prio = Int -> Text -> Text
Text.replicate (Priority -> Int
forall a. Enum a => a -> Int
fromEnum Priority
prio) Text
"-"
    log_msg :: Text
log_msg = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Int -> Char -> Text -> Text
Text.justifyLeft Int
5 Char
' ' (Priority -> Text
prio_symbol Priority
prio)
        , Caller -> Text
CallStack.showCaller Caller
caller
        , Text
" - "
        , Text
text
        ]

-- | Add a time to the msg if it doesn't already have one.
add_time :: Msg -> IO Msg
add_time :: Msg -> IO Msg
add_time Msg
log_msg
    | Msg -> UTCTime
msg_date Msg
log_msg UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
no_date_yet = do
        UTCTime
utc <- IO UTCTime
Time.getCurrentTime
        Msg -> IO Msg
forall (m :: * -> *) a. Monad m => a -> m a
return (Msg -> IO Msg) -> Msg -> IO Msg
forall a b. (a -> b) -> a -> b
$! Msg
log_msg { msg_date :: UTCTime
msg_date = UTCTime
utc }
    | Bool
otherwise = Msg -> IO Msg
forall (m :: * -> *) a. Monad m => a -> m a
return (Msg -> IO Msg) -> Msg -> IO Msg
forall a b. (a -> b) -> a -> b
$! Msg
log_msg

instance Monad m => LogMonad (LogT m) where
    write :: Msg -> LogT m ()
write = Msg -> LogT m ()
forall (m :: * -> *). Monad m => Msg -> LogT m ()
write_msg

write_msg :: Monad m => Msg -> LogT m ()
write_msg :: forall (m :: * -> *). Monad m => Msg -> LogT m ()
write_msg = LogM m () -> LogT m ()
forall (m :: * -> *) a. LogM m a -> LogT m a
LogT (LogM m () -> LogT m ()) -> (Msg -> LogM m ()) -> Msg -> LogT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> LogM m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log

type LogM m = Logger.LoggerT Msg m
newtype LogT m a = LogT { forall (m :: * -> *) a. LogT m a -> LogM m a
run_log_t :: LogM m a }
    deriving (Functor (LogT m)
Functor (LogT m)
-> (forall a. a -> LogT m a)
-> (forall a b. LogT m (a -> b) -> LogT m a -> LogT m b)
-> (forall a b c.
    (a -> b -> c) -> LogT m a -> LogT m b -> LogT m c)
-> (forall a b. LogT m a -> LogT m b -> LogT m b)
-> (forall a b. LogT m a -> LogT m b -> LogT m a)
-> Applicative (LogT m)
forall a. a -> LogT m a
forall a b. LogT m a -> LogT m b -> LogT m a
forall a b. LogT m a -> LogT m b -> LogT m b
forall a b. LogT m (a -> b) -> LogT m a -> LogT m b
forall a b c. (a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
forall {m :: * -> *}. Monad m => Functor (LogT m)
forall (m :: * -> *) a. Monad m => a -> LogT m a
forall (m :: * -> *) a b.
Monad m =>
LogT m a -> LogT m b -> LogT m a
forall (m :: * -> *) a b.
Monad m =>
LogT m a -> LogT m b -> LogT m b
forall (m :: * -> *) a b.
Monad m =>
LogT m (a -> b) -> LogT m a -> LogT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. LogT m a -> LogT m b -> LogT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
LogT m a -> LogT m b -> LogT m a
*> :: forall a b. LogT m a -> LogT m b -> LogT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
LogT m a -> LogT m b -> LogT m b
liftA2 :: forall a b c. (a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
<*> :: forall a b. LogT m (a -> b) -> LogT m a -> LogT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
LogT m (a -> b) -> LogT m a -> LogT m b
pure :: forall a. a -> LogT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> LogT m a
Applicative, (forall a b. (a -> b) -> LogT m a -> LogT m b)
-> (forall a b. a -> LogT m b -> LogT m a) -> Functor (LogT m)
forall a b. a -> LogT m b -> LogT m a
forall a b. (a -> b) -> LogT m a -> LogT m b
forall (m :: * -> *) a b. Functor m => a -> LogT m b -> LogT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogT m a -> LogT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> LogT m b -> LogT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> LogT m b -> LogT m a
fmap :: forall a b. (a -> b) -> LogT m a -> LogT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogT m a -> LogT m b
Functor, Applicative (LogT m)
Applicative (LogT m)
-> (forall a b. LogT m a -> (a -> LogT m b) -> LogT m b)
-> (forall a b. LogT m a -> LogT m b -> LogT m b)
-> (forall a. a -> LogT m a)
-> Monad (LogT m)
forall a. a -> LogT m a
forall a b. LogT m a -> LogT m b -> LogT m b
forall a b. LogT m a -> (a -> LogT m b) -> LogT m b
forall (m :: * -> *). Monad m => Applicative (LogT m)
forall (m :: * -> *) a. Monad m => a -> LogT m a
forall (m :: * -> *) a b.
Monad m =>
LogT m a -> LogT m b -> LogT m b
forall (m :: * -> *) a b.
Monad m =>
LogT m a -> (a -> LogT m b) -> LogT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> LogT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> LogT m a
>> :: forall a b. LogT m a -> LogT m b -> LogT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
LogT m a -> LogT m b -> LogT m b
>>= :: forall a b. LogT m a -> (a -> LogT m b) -> LogT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
LogT m a -> (a -> LogT m b) -> LogT m b
Monad, Monad (LogT m)
Monad (LogT m) -> (forall a. IO a -> LogT m a) -> MonadIO (LogT m)
forall a. IO a -> LogT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (LogT m)
forall (m :: * -> *) a. MonadIO m => IO a -> LogT m a
liftIO :: forall a. IO a -> LogT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> LogT m a
Trans.MonadIO,
        (forall (m :: * -> *) a. Monad m => m a -> LogT m a)
-> MonadTrans LogT
forall (m :: * -> *) a. Monad m => m a -> LogT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> LogT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> LogT m a
Trans.MonadTrans, Except.MonadError e, State.MonadState st,
        Reader.MonadReader r)

run :: Monad m => LogT m a -> m (a, [Msg])
run :: forall (m :: * -> *) a. Monad m => LogT m a -> m (a, [Msg])
run = LoggerT Msg m a -> m (a, [Msg])
forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m (a, [w])
Logger.run (LoggerT Msg m a -> m (a, [Msg]))
-> (LogT m a -> LoggerT Msg m a) -> LogT m a -> m (a, [Msg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m a -> LoggerT Msg m a
forall (m :: * -> *) a. LogT m a -> LogM m a
run_log_t

type LogId a = LogT Identity.Identity a

run_id :: LogId a -> (a, [Msg])
run_id :: forall a. LogId a -> (a, [Msg])
run_id = Identity (a, [Msg]) -> (a, [Msg])
forall a. Identity a -> a
Identity.runIdentity (Identity (a, [Msg]) -> (a, [Msg]))
-> (LogId a -> Identity (a, [Msg])) -> LogId a -> (a, [Msg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogId a -> Identity (a, [Msg])
forall (m :: * -> *) a. Monad m => LogT m a -> m (a, [Msg])
run

-- ** mtl instances

instance LogMonad m => LogMonad (State.Strict.StateT s m) where
    write :: Msg -> StateT s m ()
write = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> StateT s m ()) -> (Msg -> m ()) -> Msg -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
write
instance LogMonad m => LogMonad (State.Lazy.StateT s m) where
    write :: Msg -> StateT s m ()
write = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> StateT s m ()) -> (Msg -> m ()) -> Msg -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
write
instance (Error.Error e, LogMonad m) => LogMonad (Error.ErrorT e m) where
    write :: Msg -> ErrorT e m ()
write = m () -> ErrorT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> ErrorT e m ()) -> (Msg -> m ()) -> Msg -> ErrorT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
write
instance LogMonad m => LogMonad (Except.ExceptT e m) where
    write :: Msg -> ExceptT e m ()
write = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> ExceptT e m ()) -> (Msg -> m ()) -> Msg -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
write
instance LogMonad m => LogMonad (Reader.ReaderT r m) where
    write :: Msg -> ReaderT r m ()
write = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> ReaderT r m ()) -> (Msg -> m ()) -> Msg -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
write
instance (Monoid.Monoid w, LogMonad m) => LogMonad (Writer.WriterT w m) where
    write :: Msg -> WriterT w m ()
write = m () -> WriterT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> WriterT w m ()) -> (Msg -> m ()) -> Msg -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
write

-- * serialize

-- | Serialize a log msg.  Newline separated text is nice because it's human
-- readable and can use newlines for records.  Previously I used Show, which is
-- bulky and slow.  JSON is hopefully faster, and retains the benefits of Show.
serialize :: Msg -> ByteString.Lazy.ByteString
serialize :: Msg -> ByteString
serialize (Msg UTCTime
date Caller
caller Priority
prio Maybe Stack
stack Text
text Map Text Data
data_) =
    Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Array -> Value
Aeson.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList
        [ UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON UTCTime
date, Caller -> Value
forall a. ToJSON a => a -> Value
toJSON Caller
caller, Priority -> Value
forall a. ToJSON a => a -> Value
toJSON Priority
prio, Maybe Stack -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe Stack
stack, Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
text
        , Map Text Data -> Value
forall a. ToJSON a => a -> Value
toJSON Map Text Data
data_
        ]

deserialize :: ByteString.Lazy.ByteString -> Either String Msg
deserialize :: ByteString -> Either String Msg
deserialize ByteString
bytes = case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
bytes of
    Just (Aeson.Array Array
a) -> case Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
a of
        [Value
date, Value
caller, Value
prio, Value
stack, Value
text, Value
data_] ->
            ((() -> Parser Msg) -> () -> Either String Msg)
-> () -> (() -> Parser Msg) -> Either String Msg
forall a b c. (a -> b -> c) -> b -> a -> c
flip (() -> Parser Msg) -> () -> Either String Msg
forall a b. (a -> Parser b) -> a -> Either String b
Aeson.Types.parseEither () ((() -> Parser Msg) -> Either String Msg)
-> (() -> Parser Msg) -> Either String Msg
forall a b. (a -> b) -> a -> b
$ \() ->
                UTCTime
-> Caller
-> Priority
-> Maybe Stack
-> Text
-> Map Text Data
-> Msg
Msg (UTCTime
 -> Caller
 -> Priority
 -> Maybe Stack
 -> Text
 -> Map Text Data
 -> Msg)
-> Parser UTCTime
-> Parser
     (Caller -> Priority -> Maybe Stack -> Text -> Map Text Data -> Msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser UTCTime
forall a. FromJSON a => Value -> Parser a
parseJSON Value
date Parser
  (Caller -> Priority -> Maybe Stack -> Text -> Map Text Data -> Msg)
-> Parser Caller
-> Parser (Priority -> Maybe Stack -> Text -> Map Text Data -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Caller
forall a. FromJSON a => Value -> Parser a
parseJSON Value
caller
                    Parser (Priority -> Maybe Stack -> Text -> Map Text Data -> Msg)
-> Parser Priority
-> Parser (Maybe Stack -> Text -> Map Text Data -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Priority
forall a. FromJSON a => Value -> Parser a
parseJSON Value
prio Parser (Maybe Stack -> Text -> Map Text Data -> Msg)
-> Parser (Maybe Stack) -> Parser (Text -> Map Text Data -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser (Maybe Stack)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
stack Parser (Text -> Map Text Data -> Msg)
-> Parser Text -> Parser (Map Text Data -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
text
                    Parser (Map Text Data -> Msg)
-> Parser (Map Text Data) -> Parser Msg
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser (Map Text Data)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
data_
        [Value]
_ -> String -> Either String Msg
forall a b. a -> Either a b
Left String
"expected a 6 element array"
    Maybe Value
_ -> String -> Either String Msg
forall a b. a -> Either a b
Left String
"can't decode json"

instance Aeson.ToJSON Priority
instance Aeson.FromJSON Priority

instance Aeson.ToJSON Data where
    toJSON :: Data -> Value
toJSON Data
d = case Data
d of
        Data
NoData -> Value
Aeson.Null
        Int Int
v -> Scientific -> Value
Aeson.Number (Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
        Text Text
v -> Text -> Value
Aeson.String Text
v
        Dynamic Dynamic
v -> Text -> Value
Aeson.String (String -> Text
Text.pack (Dynamic -> String
forall a. Show a => a -> String
show Dynamic
v))

instance Aeson.FromJSON Data where
    parseJSON :: Value -> Parser Data
parseJSON Value
json = case Value
json of
        Value
Aeson.Null -> Data -> Parser Data
forall (f :: * -> *) a. Applicative f => a -> f a
pure Data
NoData
        Aeson.Number Scientific
v -> Data -> Parser Data
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Data -> Parser Data) -> Data -> Parser Data
forall a b. (a -> b) -> a -> b
$ Int -> Data
Int (Scientific -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Scientific
v)
        Aeson.String Text
v -> Data -> Parser Data
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Data -> Parser Data) -> Data -> Parser Data
forall a b. (a -> b) -> a -> b
$ Text -> Data
Text Text
v
        Value
_ -> String -> Parser Data
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting null, number, or string"

-- TODO: this is only used by ReplProtocol, maybe it could use JSON?
-- Or just send preformatted log msgs.
instance Serialize.Serialize Msg where
    put :: Putter Msg
put (Msg UTCTime
a Caller
b Priority
c Maybe Stack
d Text
e Map Text Data
f) = Putter UTCTime
forall a. Serialize a => Putter a
put UTCTime
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Caller
forall a. Serialize a => Putter a
put Caller
b PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Priority
forall a. Serialize a => Putter a
put Priority
c PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter (Maybe Stack)
forall a. Serialize a => Putter a
put Maybe Stack
d PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Text
forall a. Serialize a => Putter a
put Text
e PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter (Map Text Data)
forall a. Serialize a => Putter a
put Map Text Data
f
    get :: Get Msg
get = UTCTime
-> Caller
-> Priority
-> Maybe Stack
-> Text
-> Map Text Data
-> Msg
Msg (UTCTime
 -> Caller
 -> Priority
 -> Maybe Stack
 -> Text
 -> Map Text Data
 -> Msg)
-> Get UTCTime
-> Get
     (Caller -> Priority -> Maybe Stack -> Text -> Map Text Data -> Msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get UTCTime
forall a. Serialize a => Get a
get Get
  (Caller -> Priority -> Maybe Stack -> Text -> Map Text Data -> Msg)
-> Get Caller
-> Get (Priority -> Maybe Stack -> Text -> Map Text Data -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Caller
forall a. Serialize a => Get a
get Get (Priority -> Maybe Stack -> Text -> Map Text Data -> Msg)
-> Get Priority
-> Get (Maybe Stack -> Text -> Map Text Data -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Priority
forall a. Serialize a => Get a
get Get (Maybe Stack -> Text -> Map Text Data -> Msg)
-> Get (Maybe Stack) -> Get (Text -> Map Text Data -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Maybe Stack)
forall a. Serialize a => Get a
get Get (Text -> Map Text Data -> Msg)
-> Get Text -> Get (Map Text Data -> Msg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Text
forall a. Serialize a => Get a
get Get (Map Text Data -> Msg) -> Get (Map Text Data) -> Get Msg
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Map Text Data)
forall a. Serialize a => Get a
get

instance Serialize.Serialize Priority where
    put :: Putter Priority
put = Putter Priority
forall a. Enum a => a -> PutM ()
Serialize.put_enum_unsafe
    get :: Get Priority
get = Get Priority
forall a. (Bounded a, Enum a) => Get a
Serialize.get_enum_unsafe

instance Serialize.Serialize Data where
    put :: Putter Data
put Data
NoData = Word8 -> PutM ()
put_tag Word8
0
    put (Int Int
a) = Word8 -> PutM ()
put_tag Word8
1 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Int
forall a. Serialize a => Putter a
put Int
a
    put (Text Text
a) = Word8 -> PutM ()
put_tag Word8
2 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Text
forall a. Serialize a => Putter a
put Text
a
    put (Dynamic Dynamic
a) = Putter Data
forall a. Serialize a => Putter a
put (Text -> Data
Text (Dynamic -> Text
forall a. Show a => a -> Text
showt Dynamic
a))
    get :: Get Data
get = Get Word8
get_tag Get Word8 -> (Word8 -> Get Data) -> Get Data
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word8
tag -> case Word8
tag of
        Word8
0 -> Data -> Get Data
forall (m :: * -> *) a. Monad m => a -> m a
return Data
NoData
        Word8
1 -> Int -> Data
Int (Int -> Data) -> Get Int -> Get Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. Serialize a => Get a
get
        Word8
2 -> Text -> Data
Text (Text -> Data) -> Get Text -> Get Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
forall a. Serialize a => Get a
get
        Word8
_ -> String -> Word8 -> Get Data
forall a. String -> Word8 -> Get a
Serialize.bad_tag String
"Data" Word8
tag