aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy/Logging.hs
blob: 3a52bf4a8cfd629bb718f11aecbfded3e93c633a (plain)
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
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, void, when)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as JSON
import Data.Char (toLower)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Data.Text as T
import System.IO (hPrint, stderr)
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe)

start :: LogLevel -> IO ()
start None = return ()
start lvl = do
  writeIORef logLevel lvl
  ch <- readIORef chanRef
  void . forkIO . forever $ readChan ch >>= hPrint stderr

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