-
Notifications
You must be signed in to change notification settings - Fork 5
/
Logging.hs
145 lines (124 loc) · 4.81 KB
/
Logging.hs
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
module Hyena.Logging
( -- * The Logger and LogRequest types
AccessLogger,
LogRequest(..),
ErrorLogger,
-- * Logging
startAccessLogger,
stopAccessLogger,
logAccess,
startErrorLogger,
stopErrorLogger,
logError,
) where
import qualified Data.ByteString.Char8 as C
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Network.Socket (HostAddress, inet_ntoa)
import Network.Wai (Method(..))
import Prelude hiding (log)
import System.IO (Handle, hFlush, hPutStr, hPutStrLn)
import Text.Printf (printf)
import Hyena.Http (Request(..), Response(..))
-- ---------------------------------------------------------------------
-- The Logger and LogRequest types
-- | A queue of messages waiting to be logged.
data Logger a = Logger
{ channel :: Chan (Maybe a)
, finished :: MVar ()
-- ^ The logger puts a value here once it has terminated.
}
-- | A description of a processed request.
data LogRequest = LogRequest
{ hostAddress :: HostAddress
, request :: Request
, response :: Response
}
-- | A logger for client requests.
newtype AccessLogger = AccessLogger (Logger LogRequest)
-- | A logger for error messages.
newtype ErrorLogger = ErrorLogger (Logger String)
-- ---------------------------------------------------------------------
-- Logging
-- | Start a new logger in a separate thread that runs until
-- 'stopLogger' is called. Returns a 'Logger' that can be used to log
-- messages.
startLogger :: (Handle -> a -> IO ()) -> Handle -> IO (Logger a)
startLogger writer logHandle = do
chan <- newChan
finished' <- newEmptyMVar
_ <- forkIO $ logMessages chan finished'
return Logger { channel = chan
, finished = finished'
}
where
logMessages chan finished' = do
msg <- readChan chan
case msg of
Just msg' -> writer logHandle msg' >>
logMessages chan finished'
Nothing -> putMVar finished' ()
-- | Stop the access after all currently enqueued log requests have
-- been processed. Waits until the logger has finished.
stopLogger :: Logger a -> IO ()
stopLogger logger = do
writeChan (channel logger) Nothing
takeMVar (finished logger)
-- | Start a new logger that logs client requests.
startAccessLogger :: Handle -> IO AccessLogger
startAccessLogger = fmap AccessLogger . startLogger writeAccess
-- | Stop a client request logger.
stopAccessLogger :: AccessLogger -> IO ()
stopAccessLogger (AccessLogger logger) = stopLogger logger
-- | Start a new logger that logs error messages.
startErrorLogger :: Handle -> IO ErrorLogger
startErrorLogger = fmap ErrorLogger . startLogger writeError
-- | Stop error message logger.
stopErrorLogger :: ErrorLogger -> IO ()
stopErrorLogger (ErrorLogger logger) = stopLogger logger
-- | Log an error.
logError :: ErrorLogger -> String -> IO ()
logError (ErrorLogger logger) = writeChan (channel logger) . Just
-- | Write error message to the given 'Handle'.
writeError :: Handle -> String -> IO ()
writeError handle msg = hPutStr handle msg >> hFlush handle
-- | Log a client request.
logAccess :: AccessLogger -> Request -> Response -> HostAddress -> IO ()
logAccess (AccessLogger logger) req resp haddr =
writeChan (channel logger) $ Just
LogRequest
{ hostAddress = haddr
, request = req
, response = resp
}
-- | Write client request log message to the given 'Handle'.
writeAccess :: Handle -> LogRequest -> IO ()
writeAccess h logReq = do
host <- inet_ntoa (hostAddress logReq)
let requestLine = printf "\"%s %s HTTP/%s\"" method' uri version
response' = show (statusCode $ response logReq) ++ " " ++ show length'
hPutStrLn h $ host ++ " " ++ requestLine ++ " " ++ response'
where
(major, minor) = httpVersion $ request logReq
version = show major ++ "." ++ show minor
method' = prettyPrint $ method $ request logReq
uri = C.unpack $ requestUri $ request logReq
respHeaders = responseHeaders $ response logReq
-- TODO: Calculate the size in case Content-Length is missing.
length' :: Int
length' = maybe 0 (read . C.unpack)
(lookup (C.pack "Content-Length") respHeaders)
class PrettyPrint a where
prettyPrint :: a -> String
-- | Converts from a 'Method' enumeration to the corresponding HTTP
-- string.
instance PrettyPrint Method where
prettyPrint Options = "OPTIONS"
prettyPrint Get = "GET"
prettyPrint Head = "HEAD"
prettyPrint Post = "POST"
prettyPrint Put = "PUT"
prettyPrint Delete = "DELETE"
prettyPrint Trace = "TRACE"
prettyPrint Connect = "CONNECT"