{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Hirc.Bot where

import Prelude hiding (read)
import Network
import System.IO
import Control.Concurrent.STM
import Control.Monad.Reader
import Control.Exception
import Hirc.Parser as P
import Hirc.Types
import Text.Parsec (parse)

runBot :: Config -> Hooks -> IO ()
runBot Config{..} Hooks{..} =
    bracket (connect config_server) disconnect run
  where
    connect Server{..} = do
      socket <- connectTo hostname (PortNumber (fromIntegral port))
      nick <- atomically $ newTVar config_nick
      chan <- atomically $ newTVar config_chan
      hSetBuffering socket NoBuffering
      return Bot {
        bot_server = config_server,
        bot_nick = nick,
        bot_chan = chan,
        bot_socket = socket
      }

    disconnect bot@Bot{bot_socket=h} = do
        hClose h
        runReaderT hooks_onDisconnect bot

    run bot = do
      runReaderT (hooks_onConnect >> receive hooks_onMessage hooks_onError) bot

    receive :: (Message -> Net ()) -> (Error -> Net ()) -> Net ()
    receive onMessage onError = do
      server <- asks bot_server
      socket <- asks bot_socket
      forever $ do
        s <- init <$> liftIO (hGetLine socket)
        case parse P.message (show server) s of
          Right m -> do
              case m of
                  Message _ "PING" [x] -> do
                      h <- asks bot_socket
                      liftIO $ hPutStr h $ "PONG :" ++ x ++ "\r\n"
                  _ -> return ()
              onMessage m
          e -> onError $ BadMessage $ show e -- TODO

atomic :: (Bot -> a) -> (a -> STM b) -> Net b
atomic v f = asks v >>= liftIO . atomically . f

read :: (Bot -> TVar a) -> Net a
read v = atomic v readTVar

write :: (Bot -> TVar a) -> a -> Net ()
write v = atomic v . flip writeTVar


bumpNick :: Net String
bumpNick =
    atomic bot_nick $ flip updateTVar $ \nick ->
      case parse P.nickNum "bumpNick" nick of
        Right (n,i) -> n ++ show (i+1)
        _ -> nick ++ "_"


-- Like modifyTVar but returns the new value.
updateTVar :: TVar a -> (a -> a) -> STM a
updateTVar v f = do
    x <- readTVar v
    let x' = f x
    writeTVar v x'
    return x'