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
|
module Sproxy.Logging (
LogLevel(..)
, debug
, error
, info
, level
, start
, warn
) where
import Prelude hiding (error)
import Control.Applicative (empty)
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Monad (forever, when)
import Data.Aeson (FromJSON, ToJSON)
import Data.Char (toLower)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import System.IO (hPrint, stderr)
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe)
import qualified Data.Aeson as JSON
import qualified Data.Text as T
start :: LogLevel -> IO ()
start None = return ()
start lvl = do
writeIORef logLevel lvl
ch <- readIORef chanRef
_ <- forkIO . forever $ readChan ch >>= hPrint stderr
return ()
info :: String -> IO ()
info = send . Message Info
warn:: String -> IO ()
warn = send . Message Warning
error:: String -> IO ()
error = send . Message Error
debug :: String -> IO ()
debug = send . Message Debug
send :: Message -> IO ()
send msg@(Message l _) = do
lvl <- level
when (l <= lvl) $ do
ch <- readIORef chanRef
writeChan ch msg
{-# NOINLINE chanRef #-}
chanRef :: IORef (Chan Message)
chanRef = unsafePerformIO (newChan >>= newIORef)
{-# NOINLINE logLevel #-}
logLevel :: IORef LogLevel
logLevel = unsafePerformIO (newIORef None)
level :: IO LogLevel
level = readIORef logLevel
data LogLevel = None | Error | Warning | Info | Debug
deriving (Enum, Ord, Eq)
instance Show LogLevel where
show None = "NONE"
show Error = "ERROR"
show Warning = "WARN"
show Info = "INFO"
show Debug = "DEBUG"
instance Read LogLevel where
readsPrec _ s
| l == "none" = [ (None, "") ]
| l == "error" = [ (Error, "") ]
| l == "warn" = [ (Warning, "") ]
| l == "info" = [ (Info, "") ]
| l == "debug" = [ (Debug, "") ]
| otherwise = [ ]
where l = map toLower s
instance ToJSON LogLevel where
toJSON = JSON.String . T.pack . show
instance FromJSON LogLevel where
parseJSON (JSON.String s) =
maybe (fail $ "unknown log level: " ++ show s) return (readMaybe . T.unpack $ s)
parseJSON _ = empty
data Message = Message LogLevel String
instance Show Message where
show (Message lvl str) = show lvl ++ ": " ++ str
|
