module Lib
    ( runBirch
    ) where

import           System.IO                      -- base
import qualified Network.Socket as N            -- network
import           Control.Monad.Trans.Reader     -- transformers
import           Control.Monad.IO.Class
import           Data.List
import           System.Exit
import           Control.Exception

data Bot = Bot { botSocket :: Handle }
type Net = ReaderT Bot IO

type Nick = String
type Realname = String

-- Toplevel program
runBirch :: String -> N.PortNumber -> String -> [String] -> IO ()
runBirch myServer myPort myNick myChannels = bracket
    (connect myServer myPort)
    disconnect
    loop
  where
    disconnect = hClose . botSocket
    loop st = runReaderT (run myNick "tutorial bot") st


connect :: String -> N.PortNumber -> IO Bot
connect myServer myPort = notify $ do
    h <- connectTo myServer myPort
    return (Bot h)
  where
    notify a = bracket_
      (putStrLn ("Connecting to " ++ myServer ++ " ...") >> hFlush stdout)
      (putStrLn "done.")
      a

-- Connect to a server given its name and port number
connectTo :: N.HostName -> N.PortNumber -> IO Handle
connectTo host port = do
    addr : _ <- N.getAddrInfo Nothing (Just host) (Just (show port))
    sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
    N.connect sock (N.addrAddress addr)
    N.socketToHandle sock ReadWriteMode

-- Join a channel, and start processing commands
run :: Nick -> Realname -> Net ()
run myNick myRealname = do
    register myNick myRealname
    listen

-- Send a message to a handle
write :: String -> String -> Net ()
write cmd args = do
    h <- asks botSocket
    let msg = cmd ++ " " ++ args ++ "\r\n"
    liftIO $ hPutStr h msg          -- Send message on the wire
    liftIO $ putStr ("> " ++ msg)   -- Show sent message on the command line

-- Process each line from the server
listen :: Net ()
listen = forever $ do
    h <- asks botSocket
    line <- liftIO $ hGetLine h
    liftIO $ putStrLn line
    let s = init line
    if isPing s then pong s else eval (clean s)
  where
    forever :: Net () -> Net ()
    forever a = do a; forever a

clean :: String -> String
clean = drop 1 . dropWhile (/= ':') . drop 1

isPing :: String -> Bool
isPing x = "PING :" `isPrefixOf` x

pong :: String -> Net ()
pong x = write "PONG" (':' : drop 6 x)

-- Dispatch a command
eval :: String -> Net ()
eval "!quit"              = write "QUIT" ":Exiting" >> liftIO exitSuccess
eval x
  | "!id " `isPrefixOf` x = privmsg (drop 4 x)
eval _                    = return () -- ignore everything else

-- Send a privmsg to a channel
privmsg :: String -> Net ()
privmsg msg = write "PRIVMSG" ("#nais-testing" ++ " :" ++ msg)

-- Register with the server
register :: Nick -> Realname -> Net ()
register nick realname = do
  sendNICK nick
  sendUSER nick realname

-- Send NICK command
sendNICK :: Nick -> Net ()
sendNICK = write "NICK"

-- Send USER command
sendUSER :: Nick -> Realname -> Net ()
sendUSER nick realname = write "USER" (nick ++ " 0 * :" ++ realname)