webdriver-precore-0.2.0.0: test/Logger.hs

module Logger
  ( Printer (..),
    withLogger,
    withLogFileLogger,
    withChannelFileLogger,
    printToFileAndLog,
  )
where

import Control.Monad (unless)
import Data.Text (Text)
import Data.Text.IO qualified as TIO
import IOUtils (Logger (..), findWebDriverRoot, loopForever)
import System.FilePath ((</>))
import UnliftIO
  ( IOMode (..),
    atomically,
    bracket,
    cancel,
    isEmptyTChan,
    newTChanIO,
    readTChan,
    withFile,
    writeTChan,
    atomically
  )
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Directory (getCurrentDirectory)
import UnliftIO.IO (hSetBuffering)
import UnliftIO.IO (BufferMode(..))


-- | Printer abstraction for logging output
newtype Printer = MkPrinter
  { print :: Text -> IO ()
  }

-- | Creates a logger with a channel and async loop that processes messages using the provided Printer
withLogger :: Printer -> (Logger -> IO ()) -> IO ()
withLogger p loggingAction = do
  logChan <- newTChanIO
  let waitEmpty :: Int -> IO ()
      waitEmpty attempt = do
        empty <- atomically $ isEmptyTChan logChan
        unless (empty || attempt > 500) $ do
          threadDelay 10_000
          waitEmpty $ succ attempt

      writeToChan = atomically . writeTChan @Text logChan
      readAndPrint = atomically (readTChan logChan) >>= p.print

  bracket
    -- initialise printloop
    (loopForever writeToChan "Logger" readAndPrint)
    -- empty and cancel print loop
    ( \printLoop -> do
        waitEmpty 0
        cancel printLoop
    )
    -- run the loggingAction with a logger that writes messages to the print channel
    (const . loggingAction $ MkLogger  writeToChan)

-- | Opens a log file and provides a function to write to it
withLogFileLogger :: ((Text -> IO ()) -> IO ()) -> IO ()
withLogFileLogger action = do
  lgPath <- getLogPath <$> getCurrentDirectory
  withFile lgPath WriteMode $ \h -> do
     hSetBuffering h LineBuffering
     action $ TIO.hPutStrLn h
  where
    lgName = "eval.log"
    getLogPath = maybe lgName (</> lgName) . findWebDriverRoot

-- | Combines withLogger and withLogFileLogger to provide channel-based file logging
withChannelFileLogger :: (Logger -> IO ()) -> IO ()
withChannelFileLogger loggingAction =
  withLogFileLogger $ \printToFile ->
    withLogger (printToFileAndLog printToFile) loggingAction

-- | Creates a Printer that writes to both a file and stdout
printToFileAndLog :: (Text -> IO ()) -> Printer
printToFileAndLog printToFile =
  MkPrinter
    { print = \msg -> do
        let logMsg = "[LOG] " <> msg
        TIO.putStrLn logMsg
        printToFile logMsg
    }