infinity-0.1.1: IRC.hs

module IRC where
import Control.Concurrent
import Control.Monad.Reader
import System.Plugins
import Text.Printf
import System.IO
import List

import Plugins
import Config
import Utils
import qualified API as API

data Bot = Bot { socket      :: Handle,          -- server socket
                 rChan       :: Chan String,     -- response channel
                 cmdPrefixes :: String,          -- prefixes to be aware of
                 server      :: Server,          -- server info
                 pluginState :: API.PluginState, -- state given to all plugins
                 plugins     :: API.PluginList   -- list of module/plugin pairs
}
type InfBot = ReaderT Bot IO 


infInit :: InfBot ()
infInit = do
  -- pull all necessary data
  h      <- asks socket
  serv   <- asks server
  let n = nickname serv
      p = password serv
      r = realname serv
      c = channels serv

  -- set nick/user, give pass, join channels
  send "NICK" n
  send "USER" (n ++ " 0 * :"++r) 
  unless (null p) $ do
    privmsg "nickserv" $ "identify "++p
  mapM_ (send "JOIN") c

  listen h

-- thanks go to don stewart's IRC bot tutorial,
-- i cribbed a bit of code from there for my
-- own nefarious purposes. :)
listen h = infinity $ do
  s  <- io $ hGetLine h
  s' <- sanitize s
  report s
  if ping s then pong s else eval h s'
 where
  infinity a = a >> infinity a             -- useless plug ;)
  ping       = isPrefixOf "PING :"
  pong x     = send "PONG" (':':drop 6 x) 
  sanitize s = do  -- really ugly
    if ("PRIVMSG" `elem` (words s)) then do
          let  x    = (drop 1 . dropWhile (/="PRIVMSG") . words . drop 1) s
          let  chan = head x
               str  = (drop 1 . unwords . tail) x
               user = (takeWhile (/='!') . drop 1) s
          return (user,chan,str)
     else
         return ("","","")

eval :: Handle -> (String,String,String) -> InfBot ()
eval h (u,c,s) = do
  unless (null c && null s && null u) $ do
    p <- asks cmdPrefixes
    let com = (head . words) s
        arg = if (length $ words s) >= 2 then (drop 1 $ dropWhile (/=' ') s) else ""
    if (head com) `elem` p then
        let com' = tail com in
        case com' of
          -- here we've got a couple of commands that're built directly in
          "quit"    -> ifAdmin u (quit h) err
          x         -> do
                    plug <- findp x
                    case plug of
                      Left s -> do
                                privmsg c $ "Err: "++s
                      Right (_,p) -> do
                               let act = API.action p
                                   arg = (unwords . tail . words) s
                               pstate <- asks pluginState
                               ret <- io $ API.runAction (act u c com' arg) pstate
                               mapM_ (privmsg c) $ lines ret
     else return ()
 where
   ifAdmin :: String -> InfBot () -> InfBot () -> InfBot ()
   ifAdmin u y n = do
     serv <- asks server
     if (u `elem` (administrators serv)) then y else n
   quit :: Handle -> InfBot ()
   quit h = do
     send "QUIT" ":Exiting via command..."
     io $ hClose h
     report "disconnected..."
     io $ (myThreadId >>= killThread)
   err :: InfBot ()
   err = privmsg c "'fraid you can't do that, kid..."

-- convenience functions
io :: IO a -> InfBot a
io = liftIO

report :: String -> InfBot ()
report s = do
  c    <- asks rChan
  serv <- asks server
  io $ writeChan c ((address serv) ++ " *** " ++ s) 

findp :: String -> InfBot (Either String (Module,API.InfinityPlugin))
findp s = (return . lookupPlugin s) =<< (asks plugins)

send :: String -> String -> InfBot ()
send c s = do
  h <- asks socket
  io $ hPrintf h "%s %s\r\n" c s
  report $ ((printf "%s %s" c s) :: String)

privmsg :: String -> String -> InfBot ()
privmsg c s = do
  h <- asks socket
  send "PRIVMSG" (c++" :"++s)