{-# Language OverloadedStrings, BangPatterns #-}
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 ((<.>), (</>))
data LogLine = LogLine
{ LogLine -> FilePath
logBaseDir :: FilePath
, LogLine -> Day
logDay :: Day
, LogLine -> Text
logTarget :: Text
, LogLine -> Text
logLine :: L.Text
}
writeLogLine ::
LogLine ->
IO ()
writeLogLine :: LogLine -> IO ()
writeLogLine LogLine
ll = IO () -> IO ()
ignoreProblems 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
</> 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)
ignoreProblems :: IO () -> IO ()
ignoreProblems :: IO () -> IO ()
ignoreProblems IO ()
m = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall e a. Exception e => IO a -> IO (Either e a)
try IO ()
m :: IO (Either IOError ()))
renderLogLine ::
ClientMessage ->
FilePath ->
[Char] ->
Identifier ->
Maybe LogLine
renderLogLine :: ClientMessage
-> FilePath -> FilePath -> Identifier -> Maybe LogLine
renderLogLine !ClientMessage
msg FilePath
dir FilePath
statusModes Identifier
target =
case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientMessage MessageBody
msgBody ClientMessage
msg of
NormalBody{} -> forall a. Maybe a
Nothing
ErrorBody {} -> 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
_ -> forall a. Maybe a
Nothing
where
localtime :: LocalTime
localtime = ZonedTime -> LocalTime
zonedTimeToLocalTime (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view 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 = forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%T" TimeOfDay
tod
success :: Text -> Maybe LogLine
success Text
txt = 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
"] "] forall a. Semigroup a => a -> a -> a
<> Text
txt forall a. Semigroup a => a -> a -> a
<> Text
"\n"
}
statuspart :: [Text] -> [Text]
statuspart [Text]
rest
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
statusModes = [Text]
rest
| Bool
otherwise = Text
"statusmsg(" forall a. a -> [a] -> [a]
: FilePath -> Text
Text.pack FilePath
statusModes forall a. a -> [a] -> [a]
: Text
") " forall a. a -> [a] -> [a]
: [Text]
rest