{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RankNTypes #-}
module IrcLog where

import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Concurrent (ThreadId, threadDelay, forkIO, killThread, threadDelay)
import Control.Concurrent.Chan (Chan, dupChan, newChan, readChan, writeChan)
import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
import Control.Exception (IOException, catch)
import Control.Monad (MonadPlus(mplus, mzero), forever, when)
import Control.Monad.Reader (MonadReader(ask, local), MonadTrans, ReaderT(runReaderT), mapReaderT)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Trans (MonadIO(liftIO))
import Data.Data (Data)
import Data.Time.Calendar (Day(..))
import Data.Time.Clock (UTCTime(..), addUTCTime, getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Typeable (Typeable)
import Network (HostName, PortID(PortNumber), connectTo)
import Network.IRC (Command, Message(Message, msg_prefix, msg_command, msg_params), Prefix(NickName), UserName, encode, decode, joinChan, nick, user)
import Prelude hiding (catch)
import System.IO (BufferMode(LineBuffering), Handle, IOMode(AppendMode), hClose, hGetLine, hPutStrLn, hSetBuffering, openFile)
import System.FilePath((</>))
import System.Locale (defaultTimeLocale)
import System.Log.Logger (Priority(DEBUG, INFO, ERROR), logM, rootLoggerName, setHandlers, setLevel, updateGlobalLogger)
import System.Log.Handler.Simple (fileHandler, streamHandler)
import System.Posix.IO -- (openFd, 
import System.Posix.Types

class BotMonad m where
  askMessage   :: m Message
  askOutChan   :: m (Chan Message)
  localMessage :: (Message -> Message) -> m a -> m a
  sendMessage  :: Message -> m ()
  
newtype BotPartT m a = BotPartT { unBotPartT :: ReaderT (Message, Chan Message) m a }
                     deriving (Functor, Monad, MonadFix, MonadPlus, MonadTrans, MonadIO)
                              
runBotPartT :: BotPartT m a -> (Message, Chan Message) -> m a
runBotPartT botPartT = runReaderT (unBotPartT botPartT)
                              
mapBotPartT :: (m a -> n b) -> BotPartT m a -> BotPartT n b
mapBotPartT f (BotPartT r) = BotPartT $ mapReaderT f r

instance (Functor m, MonadIO m) => BotMonad (BotPartT m) where
  askMessage = BotPartT (fst <$> ask)
  askOutChan = BotPartT (snd <$> ask)
  localMessage f (BotPartT r) = BotPartT (local (first f) r)
  sendMessage msg =
    BotPartT $ do outChan <- snd <$> ask
                  -- liftIO $ print msg
                  liftIO $ writeChan outChan msg
                  return ()

data User = User { username   :: String
                 , hostname   :: HostName
                 , servername :: HostName
                 , realname   :: String
                 }
          deriving (Eq, Ord, Read, Show)

ircConnect :: HostName -> PortID -> String -> User -> IO Handle
ircConnect host port n u =
    do h <- connectTo host port
       hSetBuffering h LineBuffering
       hPutStrLn h (encode (nick n))
       hPutStrLn h (encode (user (username u) (hostname u) (servername u) (realname u)))
       return h
       
partLoop :: Chan Message -> Chan Message -> (BotPartT IO ()) -> IO ()
partLoop incomingChan outgoingChan botPart =
  forever $ do msg <- readChan incomingChan
               runBotPartT botPart (msg, outgoingChan)
               
ircLoop :: Chan Message -> Chan Message -> [BotPartT IO ()] -> IO [ThreadId]
ircLoop incomingChan outgoingChan parts = mapM forkPart parts
  where
    forkPart botPart =
      do inChan <- dupChan incomingChan
         forkIO $ partLoop inChan outgoingChan (botPart `mplus` return ())
       
ircLog :: FilePath -> HostName -> PortID -> String -> User -> String -> IO [ThreadId]
ircLog logDir host port nick user channel =  
  do logChan      <- newChan :: IO (Chan Message)
     logTid       <- forkIO $ logger logDir channel logChan
     -- message channels
     outgoingChan <- newChan :: IO (Chan Message)
     incomingChan <- newChan :: IO (Chan Message)
     mv <- newMVar =<< getCurrentTime
     (outgoingTid, incomingTid, forceReconnect) <- connectionLoop mv host port nick user outgoingChan incomingChan logChan (onConnect outgoingChan)
     watchDogTid <- forkIO $ forever $ 
                    do let timeout = 5*60
                       now          <- getCurrentTime
                       lastActivity <- readMVar mv
                       when (now > addUTCTime (fromIntegral timeout) lastActivity) forceReconnect
                       threadDelay (30*10^6) -- check every 30 seconds
     ircTids <- ircLoop incomingChan outgoingChan ircParts
     return $ (incomingTid : outgoingTid : logTid : watchDogTid : ircTids)
    where
      onConnect outgoingChan = 
        do logM "irc" INFO $ "joining channel " ++ channel
           writeChan outgoingChan (joinChan channel)
     
-- reconnect loop is still a bit buggy     
-- if you try to write multiple lines, and the all fail, reconnect will be called multiple times..
-- something should be done so that this does not happen
connectionLoop :: MVar UTCTime -> HostName -> PortID -> String -> User -> Chan Message -> Chan Message -> Chan Message -> IO () -> IO (ThreadId, ThreadId, IO ())
connectionLoop mv host port nick user outgoingChan incomingChan logChan onConnect =
  do hMVar <- newMVar (undefined :: Handle)
     doConnect host port nick user onConnect hMVar
     outgoingTid  <- forkIO $ forever $
                      do msg <- readChan outgoingChan
                         writeChan logChan msg
                         h <- readMVar hMVar
                         hPutStrLn h (encode msg) `catch` (reconnect host port nick user onConnect hMVar)
                         modifyMVar_ mv (const getCurrentTime) 
     incomingTid  <- forkIO $ forever $
                       do h <- readMVar hMVar
                          msgStr <- (hGetLine h) `catch` (\e -> reconnect host port nick user onConnect hMVar e >> return "")
                          modifyMVar_ mv (const getCurrentTime)
                          case decode (msgStr ++ "\n") of
                            Nothing -> logM "irc" INFO $ ("decode failed: " ++ msgStr)
                            (Just msg) -> 
                              do writeChan logChan msg
                                 writeChan incomingChan msg
     let forceReconnect = 
             do h <- readMVar hMVar
                hClose h
     return (outgoingTid, incomingTid, forceReconnect)

 
ircConnectLoop host port nick user =
        (ircConnect host port nick user) `catch` 
        (\e ->
          do logM "irc" INFO $ "irc connect failed ... retry in 60 seconds: " ++ show (e :: IOException)
             threadDelay (60 * 10^6)
             ircConnectLoop host port nick user)
 
doConnect host port nick user onConnect hMVar =
    do logM "irc" INFO $ showString "Connecting to " . showString host . showString " as " $ nick
       h <- ircConnectLoop host port nick user
       modifyMVar_ hMVar (const $ return h)
       logM "irc" INFO $ "Connected."
       onConnect
       return ()

reconnect :: String -> PortID -> String -> User -> IO a -> MVar Handle -> IOException -> IO ()
reconnect host port nick user onConnect hMVar e = 
    do logM "irc" INFO $ "IRC Connection died: " ++ show e
       doConnect host port nick user onConnect hMVar

ircParts :: [BotPartT IO ()]
ircParts = 
  [ pingPart
  ]

pingPart :: (Functor m, MonadPlus m, BotMonad m) => m ()     
pingPart =
  do (Ping hostName) <- ping
     sendCommand (Pong hostName)
     
-- TODO: This should be modified so that a formatting filter can be applied to the log messages
-- TODO: should be updated so that log file name matches channel
-- TODO: should support multiple channels
logger :: FilePath -> String -> Chan Message -> IO ()
logger logDir channel logChan =
  do now <- getCurrentTime
     let logDay = utctDay now
     logFd <- openLog now
     logLoop logDay logFd
    where
      openLog :: UTCTime -> IO Fd
      openLog now =
        do let logPath = logDir </> (formatTime defaultTimeLocale "happs-%Y-%m-%d.txt" now)
           fd <- openFd logPath WriteOnly (Just 0o0644) (defaultFileFlags { append = True })
           return fd
      updateLogHandle :: UTCTime -> Day -> Fd -> IO (Day, Fd)
      updateLogHandle now logDay logFd
        | logDay == (utctDay now) = return (logDay, logFd)
        | otherwise = do closeFd logFd
                         nowHandle <- openLog now
                         return (utctDay now, nowHandle)
          
      logLoop :: Day -> Fd -> IO ()
      logLoop logDay logFd =
        do msg <- readChan logChan
           now <- getCurrentTime 
           (logDay', logFd') <- updateLogHandle now logDay logFd
           let mPrivMsg = toPrivMsg msg
           case mPrivMsg of
             (Just (PrivMsg (Just (NickName nick _user _server)) receivers msg)) | channel `elem` receivers ->
                   do let logMsg = showString (formatTime defaultTimeLocale "%X " now) . showString "<" . showString nick . showString "> " $ msg
                      logM "irc" INFO logMsg
                      fdWrite logFd' (logMsg ++ "\n")
                      return ()
                      -- hPutStrLn logFd logMsg
             _ -> logM "irc" INFO (show msg)
           logLoop logDay' logFd'

-- * Commands
     
cmd :: (Functor m, MonadPlus m, BotMonad m) => Command -> m ()
cmd cmdName =
  do command <- msg_command <$> askMessage
     if cmdName == command
       then return ()
       else mzero

data Ping
  = Ping HostName
  deriving (Eq, Ord, Read, Show, Data, Typeable)
           
ping :: (Functor m, MonadPlus m, BotMonad m) => m Ping
ping =            
  do cmd "PING"
     params <- msg_params  <$> askMessage
     case params of
       (hostName:_) -> return $ Ping hostName
       _ -> mzero
       
           
data PrivMsg           
  = PrivMsg (Maybe Prefix) [String] String
      deriving (Eq, Read, Show)
       
privMsg :: (Functor m, MonadPlus m, BotMonad m) => m PrivMsg
privMsg =
  do msg <- askMessage
     maybe mzero return (toPrivMsg msg)
     
toPrivMsg :: Message -> Maybe PrivMsg     
toPrivMsg msg =
  let cmd = msg_command msg
      params = msg_params msg
      prefix = msg_prefix msg
  in case cmd of
      "PRIVMSG" -> Just $ PrivMsg prefix (init params) (last params)
      _ -> Nothing
     
class ToMessage a where
  toMessage :: a -> Message
  
sendCommand :: (ToMessage c, BotMonad m, Functor m) => c -> m ()
sendCommand c = sendMessage (toMessage c)

data Pong
  = Pong HostName
      deriving (Eq, Ord, Read, Show, Data, Typeable)

instance ToMessage Pong where
  toMessage (Pong hostName) = Message Nothing "PONG" [hostName]