  Copyright ( c ) 2004  
  Copyright ( c ) 2005  
  Copyright ( c ) 2005  
  Copyright ( c ) 2005   <  >
--
  | Logging an IRC channel ..
--
module Lambdabot.Plugin.IRC.Log (logPlugin) where

import Lambdabot.Compat.FreenodeNick
import Lambdabot.IRC
import Lambdabot.Monad
import qualified Lambdabot.Message as Msg
import Lambdabot.Nick
import Lambdabot.Plugin
import Lambdabot.Util

import Control.Monad
import qualified Data.Map as M
import Data.Time
import System.Directory (createDirectoryIfMissing)
import System.FilePath
import System.IO

-- ------------------------------------------------------------------------

type Channel = Nick

type DateStamp = (Int, Int, Integer)
data ChanState = CS { chanHandle  :: Handle,
                      chanDate    :: DateStamp }
               deriving (Show, Eq)
type LogState = M.Map Channel ChanState
type Log = ModuleT LogState LB

data Event =
    Said Nick UTCTime String
    | Joined Nick String UTCTime
    | Parted Nick String UTCTime -- covers quitting as well
    | Kicked Nick Nick String UTCTime String
    | Renick Nick String UTCTime Nick
    | Mode Nick String UTCTime String
    deriving (Eq)

instance Show Event where
    show (Said nick ct what)      = timeStamp ct ++ " <" ++ nName nick ++ "> " ++ what
    show (Joined nick usr ct)     = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                    ++ " (" ++ usr ++ ") joined."
    show (Parted nick usr ct)     = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                    ++ " (" ++ usr ++ ") left."
    show (Kicked nick op usrop ct reason) = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                            ++ " was kicked by " ++ show (FreenodeNick op)
                                            ++ " (" ++ usrop ++ "): " ++ reason ++ "."
    show (Renick nick usr ct new) = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                    ++ " (" ++ usr ++ ") is now " ++ show (FreenodeNick new) ++ "."
    show (Mode nick usr ct mode)  = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                    ++ " (" ++ usr ++ ") changed mode to " ++ mode ++ "."

-- * Dispatchers and Module instance declaration
--
logPlugin :: Module (M.Map Channel ChanState)
logPlugin = newModule
    { moduleDefState  = return M.empty
    , moduleExit      = cleanLogState
    , moduleInit      = do
        let doLog f m hdl = logString hdl . show . f m
            connect signal cb = registerCallback signal $ \msg -> do
                now <- io getCurrentTime
                -- map over the channels this message was directed to, adding to each
                -- of their log files.
                mapM_ (withValidLog (doLog cb msg) now) (Msg.channels msg)

        connect "PRIVMSG" msgCB
        connect "JOIN"    joinCB
        connect "PART"    partCB
        connect "KICK"    kickCB
        connect "NICK"    nickCB
        connect "MODE"    modeCB
    }

-- * Logging helpers
--

-- | Show a number, padded to the left with zeroes up to the specified width
  ^  to fill to
          -> Int    -- ^ Number to show
          -> String -- ^ Padded string
showWidth width n = zeroes ++ num
    where num    = show n
          zeroes = replicate (width - length num) '0'

timeStamp :: UTCTime -> String
timeStamp (UTCTime _ ct) =
    (showWidth 2 (hours `mod` 24)) ++ ":" ++
    (showWidth 2 (mins  `mod` 60)) ++ ":" ++
    (showWidth 2 (secs  `mod` 60))
    where
        secs  = round ct :: Int
        mins  = secs `div` 60
        hours = mins `div` 60

  | Show a DateStamp .
dateToString :: DateStamp -> String
dateToString (d, m, y) = (showWidth 2 $ fromInteger y) ++ "-" ++
                         (showWidth 2 $ fromEnum m + 1) ++ "-" ++
                         (showWidth 2 d)

  | UTCTime - > DateStamp conversion
dateStamp :: UTCTime -> DateStamp
dateStamp (UTCTime day _) = (d, m, y)
    where (y,m,d) = toGregorian day

-- * State manipulation functions
--

-- | Cleans up after the module (closes files)
cleanLogState :: Log ()
cleanLogState =
    withMS $ \state writer -> do
      io $ M.foldr (\cs iom -> iom >> hClose (chanHandle cs)) (return ()) state
      writer M.empty

  | Fetch a channel from the internal map . Uses  's fail if not found .
getChannel :: Channel -> Log ChanState
getChannel c = (readMS >>=) . mLookup $ c
    where mLookup k = maybe (fail "getChannel: not found") return . M.lookup k

getDate :: Channel -> Log DateStamp
getDate c = fmap chanDate . getChannel $ c

getHandle :: Channel -> Log Handle
getHandle c = fmap chanHandle . getChannel $ c
    -- add points. otherwise:
  Unbound implicit parameters ( ? ref::GHC.IOBase . MVar LogState , ? name::String )
    --  arising from instantiating a type signature at
    -- Plugin/Log.hs:187:30-39
    -- Probable cause: `getChannel' is applied to too few arguments

  | Put a DateStamp and a Handle . Used by ' openChannelFile ' and
--  'reopenChannelMaybe'.
putHdlAndDS :: Channel -> Handle -> DateStamp -> Log ()
putHdlAndDS c hdl ds =
        modifyMS (M.adjust (\cs -> cs {chanHandle = hdl, chanDate = ds}) c)


-- * Logging IO
--

-- | Open a file to write the log to.
openChannelFile :: Channel -> UTCTime -> Log Handle
openChannelFile chan ct = do
    logDir <- lb $ findLBFileForWriting "Log"
    let dir  = logDir </> nTag chan </> nName chan
        file = dir </> (dateToString date) <.> "txt"
    io $ createDirectoryIfMissing True dir >> openFile file AppendMode
    where date = dateStamp ct

-- | Close and re-open a log file, and update the state.
reopenChannelMaybe :: Channel -> UTCTime -> Log ()
reopenChannelMaybe chan ct = do
  date <- getDate chan
  when (date /= dateStamp ct) $ do
    hdl <- getHandle chan
    io $ hClose hdl
    hdl' <- openChannelFile chan ct
    putHdlAndDS chan hdl' (dateStamp ct)

-- | Initialise the channel state (if it not already inited)
initChannelMaybe :: Nick -> UTCTime -> Log ()
initChannelMaybe chan ct = do
  chanp <- liftM (M.member chan) readMS
  unless chanp $ do
    hdl <- openChannelFile chan ct
    modifyMS (M.insert chan $ CS hdl (dateStamp ct))

-- | Ensure that the log is correctly initialised etc.
withValidLog :: (Handle -> UTCTime -> Log a) -> UTCTime -> Channel -> Log a
withValidLog f ct chan = do
  initChannelMaybe chan ct
  reopenChannelMaybe chan ct
  hdl <- getHandle chan
  rv <- f hdl ct
  return rv

-- | Log a string. Main logging workhorse.
logString :: Handle -> String -> Log ()
logString hdl str = io $ hPutStrLn hdl str >> hFlush hdl
  -- We flush on each operation to ensure logs are up to date.

-- * The event loggers themselves
--

-- | When somebody joins.
joinCB :: IrcMessage -> UTCTime -> Event
joinCB msg ct = Joined (Msg.nick msg) (Msg.fullName msg) ct

-- | When somebody quits.
partCB :: IrcMessage -> UTCTime -> Event
partCB msg ct = Parted (Msg.nick msg) (Msg.fullName msg) ct

-- | When somebody is kicked.
kickCB :: IrcMessage -> UTCTime -> Event
kickCB msg ct = Kicked (Msg.nick msg) { nName = head $ tail $ ircMsgParams msg }
                       (Msg.nick msg)
                       (Msg.fullName msg)
                       ct
                       (tail . concat . tail . tail $ ircMsgParams msg)

-- | When somebody changes his\/her name.
-- TODO:  We should only do this for channels that the user is currently on.
nickCB :: IrcMessage -> UTCTime -> Event
nickCB msg ct = Renick (Msg.nick msg) (Msg.fullName msg) ct
                       (parseNick (Msg.server msg) $ drop 1 $ head $ ircMsgParams msg)

-- | When somebody changes channel mode.
modeCB :: IrcMessage -> UTCTime -> Event
modeCB msg ct = Mode (Msg.nick msg) (Msg.fullName msg) ct
                     (unwords $ tail $ ircMsgParams msg)

-- | When somebody speaks.
msgCB :: IrcMessage -> UTCTime -> Event
msgCB msg ct = Said (Msg.nick msg) ct
                    (tail . concat . tail $ ircMsgParams msg)
                      -- each lines is :foo



 ------------------------------------------------------------------------
 covers quitting as well
 * Dispatchers and Module instance declaration

 map over the channels this message was directed to, adding to each
 of their log files.
 * Logging helpers

 | Show a number, padded to the left with zeroes up to the specified width
 ^ Number to show
 ^ Padded string
 * State manipulation functions

 | Cleans up after the module (closes files)
 add points. otherwise:
  arising from instantiating a type signature at
 Plugin/Log.hs:187:30-39
 Probable cause: `getChannel' is applied to too few arguments
  'reopenChannelMaybe'.
 * Logging IO

 | Open a file to write the log to.
 | Close and re-open a log file, and update the state.
 | Initialise the channel state (if it not already inited)
 | Ensure that the log is correctly initialised etc.
 | Log a string. Main logging workhorse.
 We flush on each operation to ensure logs are up to date.
 * The event loggers themselves

 | When somebody joins.
 | When somebody quits.
 | When somebody is kicked.
 | When somebody changes his\/her name.
 TODO:  We should only do this for channels that the user is currently on.
 | When somebody changes channel mode.
 | When somebody speaks.
 each lines is :foo
  Copyright ( c ) 2004  
  Copyright ( c ) 2005  
  Copyright ( c ) 2005  
  Copyright ( c ) 2005   <  >
  | Logging an IRC channel ..
module Lambdabot.Plugin.IRC.Log (logPlugin) where

import Lambdabot.Compat.FreenodeNick
import Lambdabot.IRC
import Lambdabot.Monad
import qualified Lambdabot.Message as Msg
import Lambdabot.Nick
import Lambdabot.Plugin
import Lambdabot.Util

import Control.Monad
import qualified Data.Map as M
import Data.Time
import System.Directory (createDirectoryIfMissing)
import System.FilePath
import System.IO


type Channel = Nick

type DateStamp = (Int, Int, Integer)
data ChanState = CS { chanHandle  :: Handle,
                      chanDate    :: DateStamp }
               deriving (Show, Eq)
type LogState = M.Map Channel ChanState
type Log = ModuleT LogState LB

data Event =
    Said Nick UTCTime String
    | Joined Nick String UTCTime
    | Kicked Nick Nick String UTCTime String
    | Renick Nick String UTCTime Nick
    | Mode Nick String UTCTime String
    deriving (Eq)

instance Show Event where
    show (Said nick ct what)      = timeStamp ct ++ " <" ++ nName nick ++ "> " ++ what
    show (Joined nick usr ct)     = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                    ++ " (" ++ usr ++ ") joined."
    show (Parted nick usr ct)     = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                    ++ " (" ++ usr ++ ") left."
    show (Kicked nick op usrop ct reason) = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                            ++ " was kicked by " ++ show (FreenodeNick op)
                                            ++ " (" ++ usrop ++ "): " ++ reason ++ "."
    show (Renick nick usr ct new) = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                    ++ " (" ++ usr ++ ") is now " ++ show (FreenodeNick new) ++ "."
    show (Mode nick usr ct mode)  = timeStamp ct ++ " " ++ show (FreenodeNick nick)
                                    ++ " (" ++ usr ++ ") changed mode to " ++ mode ++ "."

logPlugin :: Module (M.Map Channel ChanState)
logPlugin = newModule
    { moduleDefState  = return M.empty
    , moduleExit      = cleanLogState
    , moduleInit      = do
        let doLog f m hdl = logString hdl . show . f m
            connect signal cb = registerCallback signal $ \msg -> do
                now <- io getCurrentTime
                mapM_ (withValidLog (doLog cb msg) now) (Msg.channels msg)

        connect "PRIVMSG" msgCB
        connect "JOIN"    joinCB
        connect "PART"    partCB
        connect "KICK"    kickCB
        connect "NICK"    nickCB
        connect "MODE"    modeCB
    }


  ^  to fill to
showWidth width n = zeroes ++ num
    where num    = show n
          zeroes = replicate (width - length num) '0'

timeStamp :: UTCTime -> String
timeStamp (UTCTime _ ct) =
    (showWidth 2 (hours `mod` 24)) ++ ":" ++
    (showWidth 2 (mins  `mod` 60)) ++ ":" ++
    (showWidth 2 (secs  `mod` 60))
    where
        secs  = round ct :: Int
        mins  = secs `div` 60
        hours = mins `div` 60

  | Show a DateStamp .
dateToString :: DateStamp -> String
dateToString (d, m, y) = (showWidth 2 $ fromInteger y) ++ "-" ++
                         (showWidth 2 $ fromEnum m + 1) ++ "-" ++
                         (showWidth 2 d)

  | UTCTime - > DateStamp conversion
dateStamp :: UTCTime -> DateStamp
dateStamp (UTCTime day _) = (d, m, y)
    where (y,m,d) = toGregorian day


cleanLogState :: Log ()
cleanLogState =
    withMS $ \state writer -> do
      io $ M.foldr (\cs iom -> iom >> hClose (chanHandle cs)) (return ()) state
      writer M.empty

  | Fetch a channel from the internal map . Uses  's fail if not found .
getChannel :: Channel -> Log ChanState
getChannel c = (readMS >>=) . mLookup $ c
    where mLookup k = maybe (fail "getChannel: not found") return . M.lookup k

getDate :: Channel -> Log DateStamp
getDate c = fmap chanDate . getChannel $ c

getHandle :: Channel -> Log Handle
getHandle c = fmap chanHandle . getChannel $ c
  Unbound implicit parameters ( ? ref::GHC.IOBase . MVar LogState , ? name::String )

  | Put a DateStamp and a Handle . Used by ' openChannelFile ' and
putHdlAndDS :: Channel -> Handle -> DateStamp -> Log ()
putHdlAndDS c hdl ds =
        modifyMS (M.adjust (\cs -> cs {chanHandle = hdl, chanDate = ds}) c)



openChannelFile :: Channel -> UTCTime -> Log Handle
openChannelFile chan ct = do
    logDir <- lb $ findLBFileForWriting "Log"
    let dir  = logDir </> nTag chan </> nName chan
        file = dir </> (dateToString date) <.> "txt"
    io $ createDirectoryIfMissing True dir >> openFile file AppendMode
    where date = dateStamp ct

reopenChannelMaybe :: Channel -> UTCTime -> Log ()
reopenChannelMaybe chan ct = do
  date <- getDate chan
  when (date /= dateStamp ct) $ do
    hdl <- getHandle chan
    io $ hClose hdl
    hdl' <- openChannelFile chan ct
    putHdlAndDS chan hdl' (dateStamp ct)

initChannelMaybe :: Nick -> UTCTime -> Log ()
initChannelMaybe chan ct = do
  chanp <- liftM (M.member chan) readMS
  unless chanp $ do
    hdl <- openChannelFile chan ct
    modifyMS (M.insert chan $ CS hdl (dateStamp ct))

withValidLog :: (Handle -> UTCTime -> Log a) -> UTCTime -> Channel -> Log a
withValidLog f ct chan = do
  initChannelMaybe chan ct
  reopenChannelMaybe chan ct
  hdl <- getHandle chan
  rv <- f hdl ct
  return rv

logString :: Handle -> String -> Log ()
logString hdl str = io $ hPutStrLn hdl str >> hFlush hdl


joinCB :: IrcMessage -> UTCTime -> Event
joinCB msg ct = Joined (Msg.nick msg) (Msg.fullName msg) ct

partCB :: IrcMessage -> UTCTime -> Event
partCB msg ct = Parted (Msg.nick msg) (Msg.fullName msg) ct

kickCB :: IrcMessage -> UTCTime -> Event
kickCB msg ct = Kicked (Msg.nick msg) { nName = head $ tail $ ircMsgParams msg }
                       (Msg.nick msg)
                       (Msg.fullName msg)
                       ct
                       (tail . concat . tail . tail $ ircMsgParams msg)

nickCB :: IrcMessage -> UTCTime -> Event
nickCB msg ct = Renick (Msg.nick msg) (Msg.fullName msg) ct
                       (parseNick (Msg.server msg) $ drop 1 $ head $ ircMsgParams msg)

modeCB :: IrcMessage -> UTCTime -> Event
modeCB msg ct = Mode (Msg.nick msg) (Msg.fullName msg) ct
                     (unwords $ tail $ ircMsgParams msg)

msgCB :: IrcMessage -> UTCTime -> Event
msgCB msg ct = Said (Msg.nick msg) ct
                    (tail . concat . tail $ ircMsgParams msg)
