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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Biz.Log
( Lvl (..),
good,
pass,
info,
warn,
fail,
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 = Good | Pass | Info | Warn | Fail | Mark
-- | Get the environment. This should probably return 'Biz.Dragons.Area'
-- instead of 'String'.
area :: String
area =
Env.lookupEnv "AREA"
/> maybe "Test" identity
|> unsafePerformIO
msg :: Lvl -> [Text] -> IO ()
msg lvl labels =
case area of
"Live" -> putDumb
_ ->
Env.getEnv "TERM" +> \case
"dumb" -> 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
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 :: [Text] -> IO ()
good = msg Good
pass = msg Pass
info = msg Info
warn = msg Warn
fail = msg Fail
-- | 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
|
