{-# LANGUAGE OverloadedStrings #-}

module Hyperion.Log where

import           Control.Monad.Catch       (Exception, MonadThrow, throwM)
import           Control.Monad.IO.Class    (MonadIO, liftIO)
import           Data.IORef                (IORef, newIORef, readIORef, writeIORef)
import           Data.Text                 (Text)
import qualified Data.Text                 as T
import           Data.Time.Format          (defaultTimeLocale, formatTime)
import           Data.Time.LocalTime       (getZonedTime)
import           GHC.IO.Handle             (hDuplicateTo)
import           System.Console.Concurrent (errorConcurrent)
import           System.Directory          (createDirectoryIfMissing)
import           System.FilePath.Posix     (takeDirectory)
import           System.IO                 (IOMode (..), hFlush, openFile,
                                            stderr, stdout)
import           System.IO.Unsafe          (unsafePerformIO)
import           Text.PrettyPrint          ((<+>))
import qualified Text.PrettyPrint          as PP (render, text)
import           Text.Show.Pretty          (ppDoc)

-- * General comments
-- $
-- This module contains some simple functions for logging and throwing errors.
-- The logging is done to 'stderr'.
-- The functions use 'errorConcurrent' to write to stderr (through 'text').
--
-- The output can be redirected from 'stderr' to a file by using 'redirectToFile'.

showText :: Show a => a -> Text
showText :: a -> Text
showText = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

prettyShowText :: Show a => a -> Text
prettyShowText :: a -> Text
prettyShowText a
a = String -> Text
T.pack (Doc -> String
PP.render (a -> Doc
forall a. Show a => a -> Doc
ppDoc a
a))

rawText :: MonadIO m => Text -> m ()
rawText :: Text -> m ()
rawText Text
t = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall v. Outputable v => v -> IO ()
errorConcurrent Text
t

-- | Outputs the first argument to log. Prepends current time in the format
-- @[%a %D %X]@ where @%a@ is day of the week, @%D@ is date in @mm\/dd\/yy@ format, @%X@ is
-- current time of day in some default locale.
text :: MonadIO m => Text -> m ()
text :: Text -> m ()
text Text
msg = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Text
now <- String -> Text
T.pack (String -> Text) -> (ZonedTime -> String) -> ZonedTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"[%a %D %X] " (ZonedTime -> Text) -> IO ZonedTime -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime
  Text -> IO ()
forall v. Outputable v => v -> IO ()
errorConcurrent (Text
now Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")

-- | Outputs a string to log using 'text' where the string is a pretty version of the first
-- two arguments
info :: (Show a, MonadIO m) => Text -> a -> m ()
info :: Text -> a -> m ()
info Text
msg a
a = Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
text (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Doc -> String
PP.render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text (Text -> String
T.unpack Text
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":") Doc -> Doc -> Doc
<+> a -> Doc
forall a. Show a => a -> Doc
ppDoc a
a

-- | Same as 'info' but prepended by "WARN: ".
warn :: (Show a, MonadIO m) => Text -> a -> m ()
warn :: Text -> a -> m ()
warn Text
msg a
a = Text -> a -> m ()
forall a (m :: * -> *). (Show a, MonadIO m) => Text -> a -> m ()
info (Text
"WARN: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg) a
a

-- | Shorthand for @'info' \"ERROR\"@
err :: (Show a, MonadIO m) => a -> m ()
err :: a -> m ()
err a
e = Text -> a -> m ()
forall a (m :: * -> *). (Show a, MonadIO m) => Text -> a -> m ()
info Text
"ERROR" a
e

-- | Same as 'throwM' but first logs the error using 'err'
throw :: (MonadThrow m, MonadIO m, Exception e) => e -> m a
throw :: e -> m a
throw e
e = do
  e -> m ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
err e
e
  e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e

-- | Same as 'error' but first logs the error using 'text' by prepending "ERROR: " to the first argument.
throwError :: MonadIO m => String -> m a
throwError :: String -> m a
throwError String
e = do
  Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
text (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"ERROR: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e
  String -> m a
forall a. HasCallStack => String -> a
error String
e

flush :: IO ()
flush :: IO ()
flush = Handle -> IO ()
hFlush Handle
stderr

currentLogFile :: IORef (Maybe FilePath)
{-# NOINLINE currentLogFile #-}
currentLogFile :: IORef (Maybe String)
currentLogFile = IO (IORef (Maybe String)) -> IORef (Maybe String)
forall a. IO a -> a
unsafePerformIO (Maybe String -> IO (IORef (Maybe String))
forall a. a -> IO (IORef a)
newIORef Maybe String
forall a. Maybe a
Nothing)

getLogFile :: MonadIO m => m (Maybe FilePath)
getLogFile :: m (Maybe String)
getLogFile = IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe String) -> IO (Maybe String)
forall a. IORef a -> IO a
readIORef IORef (Maybe String)
currentLogFile)

-- | Redirects log output to file by rewrting 'stdout' and 'stderr' handles.
redirectToFile :: FilePath -> IO ()
redirectToFile :: String -> IO ()
redirectToFile String
logFile = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
logFile)
  Handle
h <- String -> IOMode -> IO Handle
openFile String
logFile IOMode
WriteMode
  IORef (Maybe String) -> Maybe String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe String)
currentLogFile (String -> Maybe String
forall a. a -> Maybe a
Just String
logFile)
  Handle -> Handle -> IO ()
hDuplicateTo Handle
h Handle
stdout
  Handle -> Handle -> IO ()
hDuplicateTo Handle
h Handle
stderr