infinity-0.3: Net.hs

{-# OPTIONS -fglasgow-exts #-}
module Net (
  IState(IState),   -- types
  IrcLine(..),
  ReportChan(..),
  Net,

  runNet,  -- functions
  netlog,
  runPlugin,
  setupNick,
  identify,
  joinC,
  send,
  recv,
  privmsg,
  ping,
  pong,
  parseIRCmsg,
  quit,
  ifadmin,
  logmsg,
  waitForInput,
  getplugins,
  die,
  rebootmsg,
  chkreboot,
  getnick
) where
import Text.ParserCombinators.Parsec
import Control.Concurrent.STM
import Control.Monad.Reader
import Control.Concurrent
import System.Plugins
import Text.Printf
import qualified Network.IRC as IRC
import System.IO
import qualified Data.Map as Map
import Network
import PLoader
import Config as C
import Logger
import List
import API hiding (send)


data IState = IState {
  rebootvar :: TMVar Int,
  rchan   :: Chan ReportChan,
  plugins :: [InfinityPlugin],
  server  :: (Handle,Server),
  conf    :: Config,
  lFile   :: FilePath
}
type Net a = ReaderT IState IO a

data IrcLine = Cmd String String (String,String)
             | Line String String String
             | Err String
 deriving (Eq,Show)

data ReportChan = Reboot      -- sent when reboot is sent
                | Msg String  -- a regular message
                | Quit String -- signifies that a thread quit from a @quit command
                | Nil         -- signifies the death of a thread; only happens after a Reboot msg
 deriving (Eq,Show)

-- net API
runNet = runReaderT

parseIRCmsg :: String -> Net IrcLine
parseIRCmsg s = do
  let s' = if (last s) == '\n' then s else (reverse . (:) '\n' . reverse) s 
  case (parse IRC.message "message" s') of
    Right x -> do let (IRC.Message ircprefix irccmd (towho:params)) = x
                      nick    = getnick ircprefix
                      prefix  = ifnil params ' ' $ (head . head . words . head) params
                  cmdprefixes <- asks conf >>= return . commandPrefixes
                  if prefix `elem` cmdprefixes then do
                      let command = (tail . head . words . head) params
                          args    = (unwords . tail . words . head) params
                      return $ Cmd nick towho (command,args)
                   else return $ Line nick towho (ifnil params "" (head params))
    Left e -> return (Err $ "irc parser err") 
 where 
   ifnil [] x _ = x
   ifnil _  _ y = y
   getnick Nothing = "nobody"
   getnick (Just x) | (IRC.Server s) <- x = s
                    | (IRC.NickName nick user vhost) <- x = nick
          
netlog :: PrintStatus -> String -> Net ()
netlog p s = do
  tid <- io $ myThreadId
  f <- asks lFile
  io $ logger f p (concat ["Net: ","[",show tid,"]: ",s])

logmsg :: (String,String,String) -> Net ()
logmsg x = do
  (h,s) <- asks server
  io $ logstr (address s) x

ifadmin :: String -> Net a -> Net a -> Net a
ifadmin u y n = do
  (h,s) <- asks server
  if (u `elem` (administrators s)) then y else n

rebootmsg :: Net ()
rebootmsg = do
  r <- asks rchan
  io (writeChan r Reboot)
  netlog Normal "Sent Reboot msg..."

chkreboot :: Net Bool
chkreboot = do
  s <- asks rebootvar
  b <- atom $ (readTMVar s >> return True) `orElse` return False
  return b
 where
  atom = (io . atomically)

die :: Net ()
die = do
  r <- asks rchan
  io $ writeChan r Nil
  netlog Normal "Transactional Variable full, sent Nil msg, exiting..."

getplugins :: Net [InfinityPlugin]
getplugins = io $ getPlugins >>= return . fst . unzip

runPlugin :: String -> String -> String -> (Maybe String) -> Net (Maybe String)
runPlugin s user chan str = do
  st  <- ask
  pls <- asks plugins
  let x = lookupPlugin s pls
  case x of
    Left  err -> return $ Just err
    Right y -> do
                let z = action y
                let ps = PluginState {
                           handle   = (fst . server $ st),
                           addr     = (address . snd . server $ st),
                           admins   = (administrators . snd . server $ st),
                           chans    = (channels . snd . server $ st),
                           pluglist = (plugins st),
                           self     = y
                         }
                (r,_) <- liftIO $ runPlug ps [] (z user chan s str)
                return r

getnick :: Net String
getnick = do
  (_,s) <- asks server
  return $ nickname s

setupNick :: Net ()
setupNick = do
  (h,s) <- asks server
  let n = nickname s
      p = password s
      r = realname s
      c = channels s

  -- set nick, identify and join
  send "NICK" n
  send "USER" (n ++ " 0 * :" ++ r)

identify = do
  (_,s) <- asks server
  let p = password s
  unless (null p) $ do
     privmsg "nickserv" $ "identify "++p

joinC = do 
  (_,s) <- asks server
  let c = channels s
  mapM_ (send "JOIN") c

quit = do
  (h,s) <- asks server
  r     <- asks rchan
  let sname = C.address s
  send "QUIT" ":Exiting..."
  io $ writeChan r (Quit sname)
  io $ hClose h
  io $ (myThreadId >>= killThread)

report s = do
  c <- asks rchan
  (_,se) <- asks server
  let a = address se
  io $ writeChan c $ Msg (a ++ " *** " ++ s)

waitForInput n = do
  h <- asks server >>= return . fst
  b <- io (hWaitForInput h (n*1000))
  return b

-- lower level primitives
send msg str = do
  (h,s) <- asks server
  io $ hPrintf h "%s %s\r\n" msg str
  netlog Normal $ printf "%s %s" msg str

recv = do
  (h,_) <- asks server
  s <- io $ hGetLine h
  report s
  return s

privmsg n s = do
  send "PRIVMSG" (n++" :"++s)

ping = isPrefixOf "PING :"
pong = send "PONG" . (:) ':' . drop 6

-- convenience function
io :: IO a -> Net a
io = liftIO