{-# LANGUAGE LambdaCase #-}

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 () }

standardStream = \case Info -> stdout; Error -> stderr

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

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

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

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

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

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

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

levelString = \case Info -> "info"; Error -> "error"

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

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

logFunc log functionName f x =
  do
    record log (Event Info msg)
    return (f x)
  where
    msg = functionName ! show x ! "=" ! show (f x)

exceptionEvent ex = Event Error (displayException ex)

logAction log taskDescription action =
  do
    record log (event Info "Starting")

    result <- tryAny action >>=
        \case
            Left e ->
              do
                record log (exceptionEvent e)
                return Nothing
            Right x ->
                return (Just x)

    record log (event Info "Done")
    return result

  where
    event level message = Event level (taskDescription ! "-" ! message)

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")

initFileLog :: IO Log
initFileLog =
  do
    infoPath <- envLogPath "INFO_LOG"
    errorPath <- envLogPath "ERROR_LOG"
    return (fileLog (\case Info -> infoPath; Error -> errorPath))

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

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

    let double = logFunc appLog "double" (* 2)
    x <- double (5 :: Int)
    y <- double (6 :: Int)
    z <- double (7 :: Int)
    record appLog (Event Info ("Results: " <> show [x, y, z]))