1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | Log reporting interface
--
-- Some guidelines:
--
-- * don't allow `mark` in final code
--
-- * don't use `br` after `info`, unless verbose mode is requested (--loud flag in bild)
--
-- * always use `br` after `good`, `fail`, and `pass`
--
-- * often use `br` after `warn`, unless its really unimportant
--
-- * labels should be roughly hierarchical from general->specific
--
-- Future improvements to consider:
-- * Add timestamps (set via LOG_TIMESTAMPS=1 env var)
-- * Add log level filtering (set via LOG_LEVEL=warn to suppress info)
-- * Add structured JSON output (set via LOG_FORMAT=json for machine parsing)
-- * Add a `debug` level below `info` for verbose debugging
module Omni.Log
( Lvl (..),
good,
pass,
info,
warn,
fail,
debug,
wipe,
-- * Debugging
mark,
-- * Operators
(~&),
(~?),
-- * Wai Middleware
wai,
-- * Low-level
msg,
fmt,
br,
)
where
import Alpha hiding (pass)
import qualified Data.Text as Text
import qualified Network.Wai as Wai
import Rainbow (chunk, fore, green, magenta, red, white, yellow)
import qualified Rainbow
import qualified System.Environment as Env
import qualified System.IO as IO
import System.IO.Unsafe (unsafePerformIO)
data Lvl = Debug | Good | Pass | Info | Warn | Fail | Mark
deriving (Eq, Ord)
-- | Get the environment. This should probably return 'Omni.App.Area' instead of
-- 'String', but I don't want to depend on everything in 'Omni.App', so some kind
-- of refactor is needed.
area :: IO String
area =
Env.lookupEnv "AREA"
/> maybe "Test" identity
-- | Get the minimum log level from LOG_LEVEL env var (default: Info)
-- Set LOG_LEVEL=debug to see debug messages, LOG_LEVEL=warn to suppress info
minLogLevel :: Lvl
minLogLevel =
unsafePerformIO <| do
Env.lookupEnv "LOG_LEVEL" /> \case
Just "debug" -> Debug
Just "info" -> Info
Just "warn" -> Warn
Just "fail" -> Fail
_ -> Info
{-# NOINLINE minLogLevel #-}
msg :: Lvl -> [Text] -> IO ()
msg lvl labels
| lvl < minLogLevel = pure () -- Skip messages below minimum level
| otherwise =
area +> \case
"Live" -> putDumb
_ ->
Env.lookupEnv "TERM" +> \case
Just "dumb" -> putDumb
Nothing -> putDumb
_ -> Rainbow.hPutChunks IO.stderr [fore color <| clear <> chunk txt <> "\r"]
where
-- For systemd-journal, emacs *compilation* buffers, etc.
putDumb = putStr <| txt <> "\n"
txt = fmt (label : labels)
(color, label) = case lvl of
Debug -> (white, "debg")
Good -> (green, "good")
Pass -> (green, "pass")
Info -> (white, "info")
Warn -> (yellow, "warn")
Fail -> (red, "fail")
Mark -> (magenta, "mark")
clear = "\ESC[2K"
-- | Helper function for formatting outputs of labels.
fmt :: [Text] -> Text
fmt = Text.intercalate gap
gap :: Text
gap = ": "
br :: IO ()
br = Rainbow.hPutChunks stderr ["\n"] >> IO.hFlush stderr
wipe :: IO ()
wipe = hPutStr stderr ("\r" :: Text) >> IO.hFlush stderr
good, pass, info, warn, fail, debug :: [Text] -> IO ()
good = msg Good
pass = msg Pass
info = msg Info
warn = msg Warn
fail = msg Fail
debug = msg Debug
-- | Like 'Debug.trace' but follows the patterns in this module
mark :: (Show a) => Text -> a -> a
mark label val =
unsafePerformIO <| do
msg Mark [label, tshow val]
br
pure val
-- | Pipelined version of 'mark'.
--
-- @
-- mark label val = val ~& label
-- @
(~&) :: (Show a) => a -> Text -> a
val ~& label = mark label val
-- | Conditional mark.
(~?) :: (Show a) => a -> (a -> Bool) -> Text -> a
(~?) val test label = if test val then mark label val else val
wai :: Wai.Middleware
wai app req sendResponse =
app req <| \res ->
info
[ str <| Wai.requestMethod req,
show <| Wai.remoteHost req,
str <| Wai.rawPathInfo req
]
>> br
>> sendResponse res
|
