logging.hs

import Control.Exception.Safe (displayException, tryAny)
import Data.Foldable (fold)
import System.Directory (getPermissions, writable)
import System.Environment (getEnv)
import System.IO (hPutStr, stdout, stderr)

data Level = Info | Error

data Event = Event Level String

data Log = Log { record :: Event -> IO () }

consoleLog = Log $ \(Event level message) ->
    hPutStr (standardStream level) (message <> "\n")

standardStream Info = stdout
standardStream Error = stderr

fileLog path = Log $ \(Event level message) ->
    appendFile (path level) (message <> "\n")

formattedLog topic log = Log $ \event ->
    record log (formatEvent topic event)

formatEvent topic (Event level msg) = Event level msg'
  where
    msg' = paren (topic ! levelString level) ! msg

paren x = "(" <> x <> ")"

x ! y = x <> " " <> y

levelString Info = "info"
levelString Error = "error"

nullLog = Log (\_ -> return ())

multiLog log1 log2 = Log $ \event ->
  do
    record log1 event
    record log2 event

instance Semigroup Log where (<>) = multiLog
instance Monoid Log where mempty = nullLog

recoverFromException log action =
  do
    result <- tryAny action

    case result of
        Left e ->
          do
            record log (Event Error (displayException e))
            return Nothing
        Right x ->
            return (Just x)

main =
  do
    let bootLog = formattedLog "Boot" consoleLog
    record bootLog (Event Info "Starting")
    fileLog <- recoverFromException bootLog initFileLog

    let appLog = formattedLog "App" consoleLog <> fold fileLog
    record appLog (Event Info "Application started")

    -- ...

initFileLog =
  do
    infoPath <- envLogPath "INFO"
    errorPath <- envLogPath "ERROR"

    let
        path Info = infoPath
        path Error = errorPath

    return (fileLog path)

envLogPath varName =
  do
    path <- getEnv varName
    assertWritable path
    return path

assertWritable path =
  do
    permissions <- getPermissions path
    case writable permissions of
        True -> return ()
        False -> fail ("Log path" ! path ! "is not writable")