Logging.hs

{-# LANGUAGE OverloadedStrings #-}

module Hledger.Flow.Logging where

import Control.Concurrent.Async (wait, withAsync)
import Control.Concurrent.STM
import Control.Monad (when)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.LocalTime (getZonedTime)
import qualified GHC.IO.Handle.FD as H
import Hledger.Flow.Types

dummyLogger :: TChan LogMessage -> T.Text -> IO ()
dummyLogger _ _ = return ()

channelOut :: TChan LogMessage -> T.Text -> IO ()
channelOut ch txt = atomically $ writeTChan ch $ StdOut txt

channelOutLn :: TChan LogMessage -> T.Text -> IO ()
channelOutLn ch txt = channelOut ch (txt <> "\n")

channelErr :: TChan LogMessage -> T.Text -> IO ()
channelErr ch txt = atomically $ writeTChan ch $ StdErr txt

channelErrLn :: TChan LogMessage -> T.Text -> IO ()
channelErrLn ch txt = channelErr ch (txt <> "\n")

logToChannel :: TChan LogMessage -> T.Text -> IO ()
logToChannel ch msg = do
  ts <- timestampPrefix msg
  channelErrLn ch ts

timestampPrefix :: T.Text -> IO T.Text
timestampPrefix txt = do
  t <- getZonedTime
  return $ T.pack (show t) <> "\thledger-flow " <> txt

withConsoleLogging :: (TChan LogMessage -> IO a) -> IO a
withConsoleLogging action = do
  ch <- newTChanIO
  withAsync (consoleChannelLoop ch) $ \logger -> do
    result <- action ch
    terminateChannelLoop ch
    wait logger
    return result

consoleChannelLoop :: TChan LogMessage -> IO ()
consoleChannelLoop ch = do
  logMsg <- atomically $ readTChan ch
  case logMsg of
    StdOut msg -> do
      T.hPutStr H.stdout msg
      consoleChannelLoop ch
    StdErr msg -> do
      T.hPutStr H.stderr msg
      consoleChannelLoop ch
    Terminate -> return ()

terminateChannelLoop :: TChan LogMessage -> IO ()
terminateChannelLoop ch = atomically $ writeTChan ch Terminate

logVerbose :: (HasVerbosity o) => o -> TChan LogMessage -> T.Text -> IO ()
logVerbose opts ch msg = when (verbose opts) $ logToChannel ch msg