{-# Language OverloadedStrings, BangPatterns #-}
{-|
Module      : Client.Log
Description : Support for logging IRC traffic
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module provides provides logging functionality for IRC traffic.

-}
module Client.Log where

import Client.Image.Message (cleanText)
import Client.Message
import Control.Exception (try)
import Control.Lens (view)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as L
import Data.Text.Lazy.IO qualified as L
import Data.Time
import Irc.Identifier (Identifier, idText, idTextNorm )
import Irc.Message (IrcMsg(Ctcp, Privmsg, Notice), Source(srcUser))
import Irc.UserInfo (UserInfo(userNick))
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((<.>), (</>))


-- | Log entry queued in client to be written by the event loop
data LogLine = LogLine
  { LogLine -> FilePath
logBaseDir :: FilePath -- ^ log directory from server settings
  , LogLine -> Day
logDay     :: Day      -- ^ localtime day
  , LogLine -> Text
logTarget  :: Text     -- ^ channel or nickname
  , LogLine -> Text
logLine    :: L.Text   -- ^ formatted log message text
  }


-- | Write the given log entry to the filesystem.
writeLogLine ::
  LogLine  {- ^ log line -} ->
  IO ()
writeLogLine :: LogLine -> IO ()
writeLogLine LogLine
ll = IO () -> IO ()
ignoreProblems (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  do let dir :: FilePath
dir = LogLine -> FilePath
logBaseDir LogLine
ll FilePath -> FilePath -> FilePath
</> Text -> FilePath
Text.unpack (LogLine -> Text
logTarget LogLine
ll)
     let file :: FilePath
file = FilePath
dir FilePath -> FilePath -> FilePath
</> TimeLocale -> FilePath -> Day -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%F" (LogLine -> Day
logDay LogLine
ll) FilePath -> FilePath -> FilePath
<.> FilePath
"log"

     let recursiveFlag :: Bool
recursiveFlag = Bool
True
     Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
recursiveFlag FilePath
dir
     FilePath -> Text -> IO ()
L.appendFile FilePath
file (LogLine -> Text
logLine LogLine
ll)


-- | Ignore all 'IOErrors'
ignoreProblems :: IO () -> IO ()
ignoreProblems :: IO () -> IO ()
ignoreProblems IO ()
m = () () -> IO (Either IOError ()) -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (IO () -> IO (Either IOError ())
forall e a. Exception e => IO a -> IO (Either e a)
try IO ()
m :: IO (Either IOError ()))


-- | Construct a 'LogLine' for the given 'ClientMessage' when appropriate.
-- Only chat messages result in a log line.
renderLogLine ::
  ClientMessage {- ^ message       -} ->
  FilePath      {- ^ log directory -} ->
  [Char]        {- ^ status modes  -} ->
  Identifier    {- ^ target        -} ->
  Maybe LogLine
renderLogLine :: ClientMessage
-> FilePath -> FilePath -> Identifier -> Maybe LogLine
renderLogLine !ClientMessage
msg FilePath
dir FilePath
statusModes Identifier
target =
  case Getting MessageBody ClientMessage MessageBody
-> ClientMessage -> MessageBody
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting MessageBody ClientMessage MessageBody
Lens' ClientMessage MessageBody
msgBody ClientMessage
msg of
    NormalBody{} -> Maybe LogLine
forall a. Maybe a
Nothing
    ErrorBody {} -> Maybe LogLine
forall a. Maybe a
Nothing
    IrcBody IrcMsg
irc ->
      case IrcMsg
irc of
        Privmsg Source
who Identifier
_ Text
txt ->
           Text -> Maybe LogLine
success ([Text] -> Text
L.fromChunks ([Text] -> [Text]
statuspart [Text
"<", Identifier -> Text
idText (UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
who)), Text
"> ", Text -> Text
cleanText Text
txt]))
        Notice Source
who Identifier
_ Text
txt ->
           Text -> Maybe LogLine
success ([Text] -> Text
L.fromChunks ([Text] -> [Text]
statuspart [Text
"-", Identifier -> Text
idText (UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
who)), Text
"- ", Text -> Text
cleanText Text
txt]))
        Ctcp Source
who Identifier
_ Text
"ACTION" Text
txt ->
           Text -> Maybe LogLine
success ([Text] -> Text
L.fromChunks ([Text] -> [Text]
statuspart [Text
"* ", Identifier -> Text
idText (UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
who)), Text
" ", Text -> Text
cleanText Text
txt]))
        IrcMsg
_          -> Maybe LogLine
forall a. Maybe a
Nothing

  where
    localtime :: LocalTime
localtime = ZonedTime -> LocalTime
zonedTimeToLocalTime (Getting ZonedTime ClientMessage ZonedTime
-> ClientMessage -> ZonedTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ZonedTime ClientMessage ZonedTime
Lens' ClientMessage ZonedTime
msgTime ClientMessage
msg)
    day :: Day
day       = LocalTime -> Day
localDay LocalTime
localtime
    tod :: TimeOfDay
tod       = LocalTime -> TimeOfDay
localTimeOfDay LocalTime
localtime
    todStr :: FilePath
todStr    = TimeLocale -> FilePath -> TimeOfDay -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%T" TimeOfDay
tod

    success :: Text -> Maybe LogLine
success Text
txt = LogLine -> Maybe LogLine
forall a. a -> Maybe a
Just LogLine
      { logBaseDir :: FilePath
logBaseDir = FilePath
dir
      , logDay :: Day
logDay     = Day
day
      , logTarget :: Text
logTarget  = Text -> Text
Text.toLower (Identifier -> Text
idTextNorm Identifier
target)
      , logLine :: Text
logLine    = [Text] -> Text
L.fromChunks [Text
"[", FilePath -> Text
Text.pack FilePath
todStr, Text
"] "] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
      }
    statuspart :: [Text] -> [Text]
statuspart [Text]
rest
      | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
statusModes = [Text]
rest
      | Bool
otherwise = Text
"statusmsg(" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: FilePath -> Text
Text.pack FilePath
statusModes Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
") " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest