{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.IRC.Client (run) where

import qualified Data.Text.Format as TF
import qualified Data.Text.Format.Params as TF

import ClassyPrelude
import Control.Exception.Lifted  (mask_, AsyncException (UserInterrupt))
import Control.Concurrent.Lifted (fork, Chan, newChan, readChan, writeChan, threadDelay)
import Control.Monad.Reader      (ask)
import Control.Monad.State       (get, put)
import Network                   (PortID (PortNumber), connectTo, withSocketsDo)
import System.IO                 (hIsEOF, hSetBuffering, BufferMode(..))
import System.Timeout            (timeout)

import Network.IRC.Handlers
import Network.IRC.Protocol
import Network.IRC.Types

oneSec :: Int
oneSec = 1000000

debug :: Text -> IO ()
debug msg = do
  time <- getCurrentTime
  TF.print "[{}] {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, msg)

type Latch = MVar ()

latchIt :: Latch -> IO ()
latchIt latch = putMVar latch ()

awaitLatch :: Latch -> IO ()
awaitLatch latch = void $ takeMVar latch

type Channel a = (Chan a, Latch)

data Line = Timeout | EOF | Line !Message deriving (Show, Eq)

sendCommand :: Chan Command -> Command -> IO ()
sendCommand = writeChan

sendMessage :: Chan Line -> Message -> IO ()
sendMessage = (. Line) . writeChan

sendEvent :: Chan SomeEvent -> SomeEvent -> IO ()
sendEvent = writeChan

readLine :: Chan Line -> IO Line
readLine = readChan

sendCommandLoop :: Channel Command -> Bot -> IO ()
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
  cmd       <- readChan commandChan
  time      <- getCurrentTime
  let mline = lineFromCommand botConfig cmd
  case mline of
    Nothing   -> return ()
    Just line -> do
      TF.hprint socket "{}\r\n" $ TF.Only line
      TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
  case cmd of
    QuitCmd -> latchIt latch
    _       -> sendCommandLoop (commandChan, latch) bot

readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
  botStatus <- readMVar mvBotStatus
  case botStatus of
    Disconnected -> latchIt latch
    _            -> do
      mLine <- timeout timeoutDelay readLine'
      case mLine of
        Nothing   -> writeChan lineChan Timeout
        Just line -> writeChan lineChan line
      readLineLoop mvBotStatus (lineChan, latch) bot timeoutDelay
      where
        readLine' = do
          eof <- hIsEOF socket
          if eof
            then return EOF
            else do
              line <- map initEx $ hGetLine socket
              debug $ "< " ++ line
              now <- getCurrentTime
              return . Line $ msgFromLine botConfig now line

listenerLoop :: Chan Line -> Chan Command -> Int -> IRC ()
listenerLoop lineChan commandChan !idleFor = do
  status         <- get
  bot@Bot { .. } <- ask
  let nick       = botNick botConfig

  nStatus <- liftIO . mask_ $
    if idleFor >= (oneSec * botTimeout botConfig)
      then debug "Timeout" >> return Disconnected
      else do
        when (status == Kicked) $
          threadDelay (5 * oneSec) >> sendCommand commandChan JoinCmd

        mLine <- readLine lineChan
        case mLine of
          Timeout      -> getCurrentTime >>= dispatchHandlers bot . IdleMsg  >> return Idle
          EOF          -> debug "Connection closed" >> return Disconnected
          Line message -> do
            nStatus <- case message of
              JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined
              KickMsg { .. } | kickedNick == nick    -> debug "Kicked" >> return Kicked
              NickInUseMsg { .. }                    ->
                debug "Nick already in use"     >> return NickNotAvailable
              ModeMsg { user = Self, .. }            ->
                sendCommand commandChan JoinCmd >> return Connected
              _                                      -> return Connected

            dispatchHandlers bot message
            return nStatus

  put nStatus
  case nStatus of
    Idle             -> listenerLoop lineChan commandChan (idleFor + oneSec)
    Disconnected     -> return ()
    NickNotAvailable -> return ()
    _                -> listenerLoop lineChan commandChan 0

  where
    dispatchHandlers Bot { .. } message =
      forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
        handle (\(e :: SomeException) ->
                  debug $ "Exception while processing message: " ++ pack (show e)) $ do
          mCmd <- handleMessage msgHandler botConfig message
          case mCmd of
            Nothing  -> return ()
            Just cmd -> sendCommand commandChan cmd

eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
  event <- readChan eventChan
  case fromEvent event of
    Just (QuitEvent, _) -> latchIt latch
    _                   -> do
      debug $ "Event: " ++ pack (show event)
      forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
        handle (\(ex :: SomeException) ->
                  debug $ "Exception while processing event: " ++ pack (show ex)) $ do
          resp <- handleEvent msgHandler botConfig event
          case resp of
            RespMessage message -> sendMessage lineChan message
            RespCommand command -> sendCommand commandChan command
            RespEvent event'    -> sendEvent eventChan event'
            _                   -> return ()
      eventProcessLoop (eventChan, latch) lineChan commandChan bot

connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent)
connect botConfig@BotConfig { .. } = do
  debug "Connecting ..."
  socket <- connectToWithRetry
  hSetBuffering socket LineBuffering
  debug "Connected"

  lineChan    <- newChannel
  commandChan <- newChannel
  eventChan   <- newChannel
  mvBotStatus <- newMVar Connected
  msgHandlers <- loadMsgHandlers (fst eventChan)

  return (Bot botConfig socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan)
  where
    connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
                           `catch` (\(e :: SomeException) -> do
                                      debug ("Error while connecting: " ++ pack (show e) ++ ". Waiting.")
                                      threadDelay (5 * oneSec)
                                      connectToWithRetry)

    newChannel = (,) <$> newChan <*> newEmptyMVar

    loadMsgHandlers eventChan = flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
      debug $ "Loading msg handler: " ++ msgHandlerName
      mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName
      case mMsgHandler of
        Nothing         -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap
        Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap

disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent) -> IO ()
disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
  debug "Disconnecting ..."
  sendCommand commandChan QuitCmd
  awaitLatch sendLatch
  swapMVar mvBotStatus Disconnected
  awaitLatch readLatch
  sendEvent eventChan =<< toEvent QuitEvent
  awaitLatch eventLatch

  unloadMsgHandlers
  hClose socket
  debug "Disconnected"
  where
    unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
      debug $ "Unloading msg handler: " ++ msgHandlerName
      stopMsgHandler msgHandler botConfig

run :: BotConfig -> IO ()
run botConfig' = withSocketsDo $ do
  hSetBuffering stdout LineBuffering
  debug "Running with config:"
  print botConfig
  status <- run_
  case status of
    Disconnected     -> debug "Restarting .." >> run botConfig
    Errored          -> debug "Restarting .." >> run botConfig
    Interrupted      -> return ()
    NickNotAvailable -> return ()
    _                -> error "Unsupported status"
  where
    botConfig = botConfig' { msgHandlerNames = hashNub $ msgHandlerNames botConfig' ++ coreMsgHandlerNames }

    handleErrors :: SomeException -> IO BotStatus
    handleErrors e = case fromException e of
        Just UserInterrupt -> debug "User interrupt"                 >> return Interrupted
        _                  -> debug ("Exception! " ++ pack (show e)) >> return Errored

    run_ = bracket (connect botConfig) disconnect $
      \(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) ->
        handle handleErrors $ do
          sendCommand commandChan NickCmd
          sendCommand commandChan UserCmd

          fork $ sendCommandLoop (commandChan, sendLatch) bot
          fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
          fork $ eventProcessLoop eventChannel lineChan commandChan bot
          runIRC bot Connected (listenerLoop lineChan commandChan 0)