{-#LANGUAGE NoImplicitPrelude #-}
{-#LANGUAGE DeriveGeneric #-}
{-#LANGUAGE OverloadedStrings #-}
module Web.Sprinkles.Logger
( stderrLogger
, newBufferedLogger
, syslogLogger
, nullLogger
, tChanLogger
, Logger (..)
, LogLevel (..)
, LogMessage (..)
, writeLog
)
where
import Web.Sprinkles.Prelude
import Control.Concurrent (forkIO)
import Data.Aeson (FromJSON (..), Value (..), (.:), withObject)
import qualified System.Posix.Syslog as Syslog
import Data.Default (Default (..))
import Foreign.C.String (withCStringLen)
data LogLevel = Debug
| Notice
| Warning
| Error
| Critical
deriving (Show, Eq, Ord, Enum, Bounded, Generic)
logLevelToSyslogPrio :: LogLevel -> Syslog.Priority
logLevelToSyslogPrio Debug = Syslog.Debug
logLevelToSyslogPrio Notice = Syslog.Notice
logLevelToSyslogPrio Warning = Syslog.Warning
logLevelToSyslogPrio Error = Syslog.Error
logLevelToSyslogPrio Critical = Syslog.Critical
instance FromJSON LogLevel where
parseJSON (String "debug") = return Debug
parseJSON (String "notice") = return Notice
parseJSON (String "warning") = return Warning
parseJSON (String "error") = return Error
parseJSON (String "critical") = return Critical
parseJSON x = fail $ "Invalid log level: " <> show x
data LogMessage =
LogMessage
{ lmTimestamp :: !UTCTime
, lmLevel :: !LogLevel
, lmMessage :: !Text
}
deriving (Show, Eq)
instance FromJSON LogMessage where
parseJSON = withObject "LogMessage" $ \o -> do
LogMessage <$> o .: "timestamp"
<*> o .: "level"
<*> o .: "message"
writeLog :: Logger -> LogLevel -> Text -> IO ()
writeLog logger level message = do
now <- getCurrentTime
writeLogMessage logger $
LogMessage now level message
formatMessage :: LogMessage -> Text
formatMessage msg =
tshow (lmTimestamp msg) <>
" [" <>
tshow (lmLevel msg) <>
"] " <>
lmMessage msg
data Logger =
Logger
{ writeLogMessage :: LogMessage -> IO ()
}
instance Default Logger where
def = nullLogger
nullLogger :: Logger
nullLogger = Logger
{ writeLogMessage = const . return $ ()
}
stderrLogger :: LogLevel -> Logger
stderrLogger level =
def { writeLogMessage = go }
where
go msg =
when
(lmLevel msg >= level)
(hPutStrLn stderr $ formatMessage msg)
syslogLogger :: LogLevel -> Logger
syslogLogger level =
def { writeLogMessage = go }
where
go msg =
Syslog.withSyslog
"sprinkles"
[]
Syslog.User $ do
let minPrio = logLevelToSyslogPrio level
Syslog.setlogmask [minPrio..maxBound]
withCStringLen (unpack . lmMessage $ msg) $
Syslog.syslog
Nothing
(logLevelToSyslogPrio . lmLevel $ msg)
newBufferedLogger :: Logger -> IO Logger
newBufferedLogger inner = do
channel <- newChan
let writeFn = writeChan channel
forkIO . forever $
readChan channel >>= writeLogMessage inner
return $ Logger writeFn
tChanLogger :: TChan LogMessage -> Logger
tChanLogger chan =
Logger (atomically . writeTChan chan)