Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
146 lines (124 sloc) 4.81 KB
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"