diff --git a/API.hs b/API.hs --- a/API.hs +++ b/API.hs @@ -1,58 +1,119 @@ -module API where +{-# OPTIONS -fglasgow-exts #-} +module API ( + PLUG, + Conf, + InfinityPlugin(..), + PluginState(..), + PLUGIN, + runPlug, + putState, + getState, + updateState, + send, + joinchan, + partchan, + infinityVer, + version, + getplugs, + retNothing, + retJust +) where import qualified Data.Map as M import Control.Monad.Reader +import Control.Monad.State import Control.Concurrent import System.Plugins import Data.Version +import Data.Binary import System.Info import Text.Printf +import System.Info +import Data.Maybe import System.IO +import qualified PState as PState +import Logger import Config -type PluginAction a = ReaderT PluginState IO a -type InfAction = (String -> String -> String -> String -> PluginAction String) -type PluginList = [(Module,InfinityPlugin)] +version = unwords ["infinity 0.3;",arch,os,"-",(compilerName++"-"++(showVersion compilerVersion))] +type Conf = [String] + +newtype PLUG a = P (StateT Conf (ReaderT PluginState IO) a) + deriving (Functor,Monad,MonadState Conf,MonadReader PluginState,MonadIO) + +type PLUGIN = (String -> String -> String -> Maybe String -> PLUG (Maybe String)) + data InfinityPlugin = InfinityPlugin { name :: String, - commands :: [String], - help :: [(String,String)], - action :: InfAction + commands :: [(String,String)], + action :: PLUGIN } data PluginState = PluginState { handle :: Handle, - remotechan :: Chan String, addr :: String, admins :: [String], chans :: [String], - pluglist :: [InfinityPlugin] + pluglist :: [InfinityPlugin], + self :: InfinityPlugin } -runAction :: PluginAction String -> PluginState -> IO String -runAction x r = runReaderT x r +runPlug :: PluginState -> Conf -> PLUG a -> IO (a,Conf) +runPlug s c (P x) = runReaderT (runStateT x c) s --- functions usable by plugins -send :: String -> String -> PluginAction () -send c s = do - h <- asks handle - io $ hPrintf h "%s %s\r\n" c s - report $ ((printf "%s %s" c s) :: String) +-- api functions for plugins -privmsg :: String -> String -> PluginAction () -privmsg c s = do +putState :: Binary a => String -> a -> PLUG () +putState k v = do + x <- asks self >>= (return . name) + y <- io $ PState.putState x k v + case y of + Nothing -> return () + Just x -> io $ pluglog Error x + +getState :: Binary a => String -> PLUG (Maybe a) +getState k = do + x <- asks self >>= (return . name) + y <- io $ PState.getState x k + case y of + Left s -> return Nothing + Right t -> return (Just t) + +updateState :: Binary a => String -> a -> PLUG () +updateState k v = do + x <- asks self >>= (return . name) + y <- io $ PState.updateState x k v + case y of + Nothing -> return () + Just x -> io $ pluglog Error x + +getplugs :: PLUG [InfinityPlugin] +getplugs = do + s <- asks pluglist + return s + +send msg str = do h <- asks handle - send "PRIVMSG" (c++" :"++s) + n <- asks self >>= (return . name) + io $ hPrintf h "%s %s\r\n" msg str + io $ pluglog Normal $ printf "plugin[%s]:\t%s %s" n msg str -io :: IO a -> PluginAction a -io = liftIO +privmsg n s = send "PRIVMSG" (n++" :"++s) -report :: String -> PluginAction () -report s = do - c <- asks remotechan - serv <- asks addr - io $ writeChan c (serv ++ " *** " ++ s) +joinchan :: String -> PLUG () +joinchan = send "JOIN" -infinityVer = unwords ["Infinity",v,"-",arch,os,compilerName,(showVersion compilerVersion)] - where - v = "v0.1.1" +partchan :: String -> PLUG () +partchan = send "PART" + +retJust :: a -> PLUG (Maybe a) +retJust = return . Just +retNothing :: PLUG (Maybe a) +retNothing = return Nothing + +infinityVer :: PLUG String +infinityVer = return version + +-- convenience +io :: IO a -> PLUG a +io = liftIO diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -3,7 +3,7 @@ -- a datatype describing a particular IRC Server data Server = Server { address :: String, -- what server to connect to - portnum :: Int, -- what port + port :: Int, -- what port channels :: [String], -- what channels to enter nickname :: String, -- bot nick password :: String, -- bot password, can be empty @@ -15,26 +15,29 @@ -- options as well as a list of servers to connect to data Config = Config { commandPrefixes :: String, -- command prefixes - servers :: [Server] -- list of servers to connect to + servers :: [Server], -- list of servers to connect to + logFile :: FilePath -- where to log to } + -- define your servers to connect to here freenode = Server { address = "irc.freenode.org", - portnum = 6667, + port = 6667, channels = ["#bot-battle-royale"], nickname = "infinitybot", - password = "l0lic0nh4x", + password = "", realname = "time copper", administrators = ["thoughtpolice"] } --- global configuration holding all options + +-- your config options config :: Config config = Config { - commandPrefixes = "?!@", - servers = [freenode] + commandPrefixes = ['?','@','>'], + servers = [freenode], + logFile = "Log/infinity.log" } - diff --git a/IMain.hs b/IMain.hs new file mode 100644 --- /dev/null +++ b/IMain.hs @@ -0,0 +1,118 @@ +{-# OPTIONS -fglasgow-exts #-} +module IMain where +import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM +import Control.Concurrent +import Control.Monad.STM +import System.Plugins +import Control.Arrow +import Control.Monad +import Data.Maybe +import System.IO +import Network +import Data.Map as Map +import qualified Config as C +import Monitor +import PLoader +import Logger +import List +import API +import Net + +-- takes the Module referring to itself, +-- and a reboot function; starts dynmain +-- through main' with a state +main :: Module -> RebootT -> IO () +main mod reboot = do + hSetBuffering stdout NoBuffering + servs <- forM (C.servers C.config) $ \s -> do + let sname = C.address s + h <- connectTo (C.address s) (PortNumber . fromIntegral $ C.port s) + hSetBuffering h NoBuffering + return (sname,(h,s)) + putStrLn "Connected to servers..." + chan <- newChan + let st = MState undefined chan (fromList servs) C.config (C.logFile C.config) reboot mod [] + main' st mod + +-- thin wrapper which is what we'll reboot to so we don't have +-- to deal with reentrancy issues + +-- UPDATE: 10-08-07: my idea on how to approach this is roughly +-- to fall through to dynmain in the main thread in a 'Monitor' +-- monad that'll let us monitor other threads. Meanwhile, here in +-- main' since its our thin reboot wrapper, we'll just spawn threads +-- for each server connection. +main' st m = do + let s = (toList . servers) st + (plugs,mods) <- getPlugins >>= return . unzip + tvar <- atomically $ newEmptyTMVar + forM_ s $ \(name,(s,h)) -> do + let ist = IState tvar (rchan st) plugs (s,h) (conf st) (lFile st) + forkIO $ runNet listener ist + runMonitor dynmain $ st{rebootvar=tvar,imodule=m,pmodules=mods} + +-- this is the monitor thread, which keeps tracks and does reboots, etc. etc.. +dynmain :: Monitor () +dynmain = do + mlog Normal "Servers connected, threads forked..." + n <- serverNum + chanloop n + where + chanloop n = do + l <- cGetLine + case l of + Reboot -> do + mlog Normal "Got reboot msg..." + setrebootvar + s <- cGetLines + wait n s 0 + unloadplugs + restart + Msg s -> Monitor.cprint s + Quit s -> do + threadQuit s + let x = n-1 in if x == 0 then exit else chanloop x + chanloop n + + wait n x i = when (i < n) $ case x of + Nil:xs -> wait n xs $! i+1 + _:xs -> wait n xs i + +-- entry point for the subsequent threads. +listener :: Net () +listener = do + start -- this is idempotent, so it's reentry safe + infinity $ \s -> do + if ping s then pong s + else parseIRCmsg s >>= eval + return () + where start = setupNick >> identify >> joinC + ischan = isPrefixOf "#" + infinity a = do + i <- waitForInput 1 + if i then + do s <- recv + a s + infinity a + else + do re <- chkreboot + if re then die else (infinity a) + eval s | (Err e) <- s = netlog Error $ "eval: " ++ e + | (Line u c x) <- s = do name <- getnick + when (x /= [] && ischan c && u /= name) (logmsg (u,c,x)) + let n' = concat [name,":"] + when (n' `isPrefixOf` x) $ do + let str = drop (length n') x + (cmd',av) = ((tail.head.words) &&& (unwords.tail.words)) str + eval $ Cmd u c (cmd',av) + | (Cmd u c (cmd,av)) <- s = do + case cmd of + [] -> return () + "quit" -> ifadmin u quit (privmsg c "Can't do that...") + "reboot" -> ifadmin u (privmsg c "Rebooting..." >> rebootmsg) (privmsg c "Can't do that...") + x -> do logmsg (u,c,cmd++" "++av) + s <- runPlugin x u c (if List.null av then Nothing else Just av) + case s of + Nothing -> return () + Just r -> mapM_ (privmsg $ if ischan c then c else u) (lines r) diff --git a/INSTALL b/INSTALL --- a/INSTALL +++ b/INSTALL @@ -1,11 +1,17 @@ == prerequisites == o ghc >= 6.6 o hs-plugins + o binary >= 0.3 + o filepath + o irc >= 0.2.3 + o cabal >= 1.2 you may obtain hs-plugins by running: $ darcs get http://www.cse.unsw.edu.au/~dons/code/hs-plugins/ and going from there. +all the rest may be obtained from: +http://hackage.haskell.org == building == building is as simple as doing your cabal-dance after some @@ -20,12 +26,16 @@ as infinity dynamically loads its plugins; it is therefore copied to the root infinity directory upon being built. you should run it from there (the build process will move the needed files -automatically; notably the API.hi and API.o files, as well -as the infinity executable.) +automatically.) -08/12/07: infinity now loads and evaluates the Config.hs file -dynamically; meaning binary distributions can be made. :) +there is no need to recompile after changing your configuration, +infinity will notice the changes. + == cleaning up == to clean up the directory stucture, simply run: $ ./Setup.hs clean + +this will clean out all editor-based tmp files (e.g. foo~) +along with all the object files in the topmost directory +as well as the Plugins directory diff --git a/IRC.hs b/IRC.hs deleted file mode 100644 --- a/IRC.hs +++ /dev/null @@ -1,124 +0,0 @@ -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) diff --git a/Infinity.hs b/Infinity.hs deleted file mode 100644 --- a/Infinity.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Main where -import Control.Monad.Reader -import Control.Concurrent -import System.Environment -import Network.Socket -import System.Exit -import System.IO -import Network - -import qualified Config as C -import Plugins -import Utils -import API -import IRC - -main = do - a <- getArgs - putStrLn "Loading configuration..." - conf <- getConfig - unless (null a) $ do - case (head a) of - "-conf" -> do - print conf - exitWith ExitSuccess - "-h" -> do - putStrLn "usage: ./infinity [-h|-conf]" - putStrLn " -h This info" - putStrLn " -conf Display configuration (Config.hs)" - exitWith ExitSuccess - _ -> do - putStrLn "invalid command line option, try '-h'" - exitWith (ExitFailure 1) - putStrLn "infinity initializing..." - putStrLn "Global infinity configuration:" >> print conf - putStrLn "Compiling & loading infinity plugins..." - p <- (compilePlugins >>= loadPlugins) - putStrLn "Finished plugin compilation & loading\n\n" - -- spawn off our threads for every server - chan <- newChan - forM_ (C.servers conf) $ \s -> do - h <- connectTo (C.address s) (PortNumber . fromIntegral $ C.portnum s) - hSetBuffering h NoBuffering - let ps = PluginState h chan (C.address s) (C.administrators s) (C.channels s) $ map (\(_,plug) -> plug) p - st = Bot h chan (C.commandPrefixes conf) s ps p - forkIO $ runReaderT infInit st - - -- now collect all data from threads - reports <- getChanContents chan - mapM_ (putStrLn) reports diff --git a/Logger.hs b/Logger.hs new file mode 100644 --- /dev/null +++ b/Logger.hs @@ -0,0 +1,60 @@ +module Logger (logger,logstr,pluglog,PrintStatus(..)) where +import Control.Exception as Ex +import System.Directory +import System.Time +import Text.Printf +import List + +data PrintStatus = + Normal | + Warning | + Error | + Critical + +-- regular file logger +logger :: FilePath -> PrintStatus -> String -> IO () +logger lfile stat str = do + time <- (getClockTime >>= toCalendarTime) + let stime = calendarTimeToString time + p = case stat of + Normal -> "Normal["++stime++"]:\t\t" + Warning -> "WARN["++stime++"]:\t\t" + Error -> "ERROR["++stime++"]:\t\t" + Critical -> "CRITICAL["++stime++"]:\t\t" + + write lfile (printf "%s %s\n" p str :: String) + +-- logs channel strings +logstr :: String -> (String,String,String) -> IO () +logstr server (u,c,s) = do + time <- (getClockTime >>= toCalendarTime) + let hour = show $ ctHour time + hour' = if (length hour == 1) then ("0"++hour) else hour + min = show $ ctMin time + min' = if (length min == 1) then ("0"++min) else min + str = ci " " [(hour'++":"++min'),"::",("<"++u++">"),s] + date = ci "-" . map show $ [(fromEnum $ ctMonth time)+1,(ctDay time),(ctYear time)] + fpath = ci "/" ["Log",server,c,date] + mkdir $ ci "/" ["Log",server] + mkdir $ ci "/" ["Log",server,c] + + write fpath (printf "%s\n" str :: String) + where + mkdir d = do + b <- doesDirectoryExist d + if (not b) then do createDirectory d + else return () + ci x l = (concat . intersperse x) l + + +write f s = write' f s 1 +write' :: FilePath -> String -> Int -> IO () +write' f s i = do + b <- doesFileExist f + let g = if b then appendFile else writeFile + Ex.catch (g f s) (\_ -> write' (f++(show i)) s $! i+1) + +-- used to log plugin activity; it's actually just a wrapper around logger +pluglog :: PrintStatus -> String -> IO () +pluglog = logger "Log/plugins.log" + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,49 @@ +-- This is the actual startup code, however, +-- each thread is spawned off in it's own +-- thread which is started in the dynamically +-- loaded IMain.dynmain +module Main where +import Control.Concurrent +import System.Plugins +import System.Exit +import GHC.Exts + +ghcargs = [] + +main = do + putStrLn "infinity starting..." + m <- makeAll "IMain.hs" ghcargs + (mod,imain) <- case m of + MakeSuccess _ obj -> do + ldstat <- load_ obj ["."] "main" -- pull main first off + case ldstat of + LoadSuccess v m -> return (v,m) + LoadFailure e -> do + putStrLn "Couldn't load IMain.dynmain:" + mapM_ putStrLn e + exitWith $ ExitFailure 127 + MakeFailure e -> do + putStrLn "FATAL: Couldn't compile IMain.hs:" + mapM_ putStrLn e + exitWith $ ExitFailure 127 + putStrLn "Compiled & Loaded IMain.main..." + imain mod reboot + +reboot :: Module -> a -> IO () +reboot mod st = do + mkstat <- makeAll "IMain.hs" ghcargs + case mkstat of + MakeSuccess _ o -> do + unloadAll mod + ldstat <- load_ "IMain.o" ["."] "main'" + case ldstat of + LoadSuccess v main' -> do + putStrLn "REBOOT: Successful recompilation & reloading, rebooting..." + main' st v + LoadFailure e -> fatality e + MakeFailure e -> fatality e + + where + fatality errs = do + putStrLn $ "REBOOT: FATAL: Couldn't reboot thread, err:" + mapM_ putStrLn errs diff --git a/Monitor.hs b/Monitor.hs new file mode 100644 --- /dev/null +++ b/Monitor.hs @@ -0,0 +1,94 @@ +module Monitor ( + MState(..), + RebootT, + Monitor, + + runMonitor, + restart, + unloadplugs, + setrebootvar, + threadQuit, + cGetLine, + cGetLines, + cprint, + mlog, + serverNum, + exit +) where +import Control.Concurrent.STM +import Control.Monad.State +import System.Plugins +import Control.Concurrent +import System.Exit +import System.IO +import Data.Map +import qualified Config as C +import Logger +import API +import Net + +data MState = MState { + rebootvar :: TMVar Int, + rchan :: Chan ReportChan, + servers :: Map String (Handle,C.Server), + conf :: C.Config, + lFile :: FilePath, + reboot :: RebootT, + imodule :: Module, + pmodules :: [Module] +} +type RebootT = (Module -> MState -> IO ()) +type Monitor a = StateT MState IO a + +-- monitor api +runMonitor :: Monitor a -> MState -> IO a +runMonitor = evalStateT + +restart :: Monitor () +restart = do + m <- gets imodule + r <- gets reboot + st <- get + io $ r m st + +unloadplugs = do + p <- gets pmodules + io $ mapM_ unload p + +threadQuit s = do + st <- get + p <- gets servers + let new = delete s p + put $ st{servers=new} + +exit = do + io $ putStrLn "all servers closed, infinity exiting..." + io $ (exitWith ExitSuccess) + +setrebootvar :: Monitor () +setrebootvar = do + s <- gets rebootvar + io (atomically $ putTMVar s 1) + +cGetLines :: Monitor [ReportChan] +cGetLines = do + r <- gets rchan + c <- io $ getChanContents r + return c + +cGetLine :: Monitor ReportChan +cGetLine = cGetLines >>= return . head + +cprint = io . putStrLn + +mlog :: PrintStatus -> String -> Monitor () +mlog p s = do + f <- gets lFile + io $ logger f p (concat ["Monitor: ",s]) + +serverNum :: Monitor Int +serverNum = gets servers >>= return . size + +-- convenience +io :: IO a -> Monitor a +io = liftIO diff --git a/Net.hs b/Net.hs new file mode 100644 --- /dev/null +++ b/Net.hs @@ -0,0 +1,219 @@ +{-# 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 diff --git a/PLoader.hs b/PLoader.hs new file mode 100644 --- /dev/null +++ b/PLoader.hs @@ -0,0 +1,66 @@ +module PLoader where +import Control.Monad.Writer +import System.Directory +import System.Plugins +import Text.Printf +import Config +import List +import API + + +-- plugin based functions +compilePlugins :: IO [String] +compilePlugins = do + c <- getDirectoryContents "Plugins/" + let plugs = filter (isSuffixOf ".hs") c -- ugly + objs <- execWriterT $ compile plugs + return objs + where + compile :: [String] -> WriterT [String] IO () + compile [] = return () + compile (x:xs) = do + o <- liftIO $ make ("Plugins/"++x) [] + case o of + MakeSuccess code obj -> do + tell [obj] + case code of + ReComp -> liftIO $ putStrLn $ "Plugin compiled: " ++ x + _ -> return () + MakeFailure e -> do + liftIO $ putStrLn $ "Compile of plugin '"++x++"' failed:" + liftIO $ mapM_ putStrLn e + compile xs + +loadPlugins :: [String] -> IO [(InfinityPlugin,Module)] +loadPlugins l = do + lo <- execWriterT $ loadplugs l + return lo + where + loadplugs :: [String] -> WriterT [(InfinityPlugin,Module)] IO () + loadplugs [] = return () + loadplugs (x:xs) = do + ls <- liftIO $ load_ x ["."] "plugin" + case ls of + LoadSuccess m v -> do + liftIO $ putStrLn $ "Plugin loaded: " ++ (name v) + tell [(v,m)] + LoadFailure err -> do + liftIO $ putStrLn $ "Loading of plugin '"++x++"' failed:" + liftIO $ mapM_ putStrLn err + loadplugs xs + + +-- simple wrapper to load & compile in one swoop +getPlugins :: IO [(InfinityPlugin,Module)] +getPlugins = compilePlugins >>= loadPlugins + + +lookupPlugin :: String -> [InfinityPlugin] -> Either String InfinityPlugin +lookupPlugin n l = + let x = filter (elem n . fst . unzip . commands) l in + case x of + [] -> Left $ "No plugin with command '"++n++"' found" + _ -> if (length x) > 1 then + Left $ "Multiple modules with same command '"++n++"' found!" + else + Right $ head x diff --git a/PState.hs b/PState.hs new file mode 100644 --- /dev/null +++ b/PState.hs @@ -0,0 +1,44 @@ +module PState ( + putState, + getState, + updateState +) where +import System.IO +import Data.Maybe +import Data.Binary +import Control.Monad +import System.FilePath +import System.Directory + +putState :: Binary a => String -> String -> a -> IO (Maybe String) +putState n k v = do + let file = foldr1 combine ["State",n,(k++".st")] + dir = takeDirectory file + b <- doesFileExist file + if b then + return (Just $ "State already exists: " ++ file) + else do + unlessM (doesDirectoryExist dir) (createDirectory dir) + encodeFile file v + return Nothing + +getState :: Binary a => String -> String -> IO (Either String a) +getState n k = do + let file = foldr1 combine ["State",n,(k++".st")] + b <- doesFileExist file + if b == False then + return $ Left ("State doesn't exist: " ++ file) + else decodeFile file >>= return . Right + + +updateState :: Binary a => String -> String -> a -> IO (Maybe String) +updateState n k v = do + let file = foldr1 combine ["State",n,(k++".st")] + b <- doesFileExist file + if b == False then + return (Just $ "State doesn't exist: " ++ file) + else encodeFile file v >> return Nothing + +-- convenience +create f = (openFile f WriteMode) >>= hClose +unlessM b f = b >>= \x -> unless x f diff --git a/Plugins.hs b/Plugins.hs deleted file mode 100644 --- a/Plugins.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Plugins where -import Control.Monad.Writer -import System.Directory -import System.Plugins -import Text.Printf -import Network -import API - -compilePlugins :: IO [String] -compilePlugins = do - c <- getDirectoryContents "Plugins/" - let plugs = filter (\s -> (".hs"==) $ flip drop s $ (length s) - 3) c -- ugly - objs <- execWriterT $ compile plugs - return objs - where - compile :: [String] -> WriterT [String] IO () - compile [] = return () - compile (x:xs) = do - o <- liftIO $ make ("Plugins/"++x) [] - case o of - MakeSuccess code obj -> do - tell [obj] - case code of - ReComp -> liftIO $ putStrLn $ "Plugin compiled: " ++ x - _ -> return () - MakeFailure e -> do - liftIO $ putStrLn $ "Compile of plugin '"++x++"' failed:" - liftIO $ mapM_ putStrLn e - compile xs - -loadPlugins :: [String] -> IO PluginList -loadPlugins l = do - lo <- execWriterT $ loadplugs l - return lo - where - loadplugs :: [String] -> WriterT PluginList IO () - loadplugs [] = return () - loadplugs (x:xs) = do - ls <- liftIO $ load_ x ["."] "plugin" - case ls of - LoadSuccess m v -> do - liftIO $ putStrLn $ "Plugin loaded: " ++ (name v) - tell [(m,v)] - LoadFailure err -> do - liftIO $ putStrLn $ "Loading of plugin '"++x++"' failed:" - liftIO $ mapM_ putStrLn err - loadplugs xs - - - -lookupPlugin :: String -> PluginList -> Either String (Module,InfinityPlugin) -lookupPlugin n l = - let x = filter (\(_,ip) -> n `elem` (commands ip)) l in - case x of - [] -> Left $ "No plugin with command '"++n++"' found" - _ -> if (length x) > 1 then - Left $ "Multiple modules with same command '"++n++"' found!" - else - Right $ head x diff --git a/Plugins/Greet.hs b/Plugins/Greet.hs new file mode 100644 --- /dev/null +++ b/Plugins/Greet.hs @@ -0,0 +1,16 @@ +module Greet where +import API + +plugin :: InfinityPlugin +plugin = InfinityPlugin { + name = "Greet", + commands = [("hi","says 'hello world!'") + ,("bye","says 'goodbye cruel world!'")], + action = greet +} + +greet :: PLUGIN +greet user chan command str = do + case command of + "hi" -> retJust "hello world!" + "bye" -> retJust "goodbye cruel world!" diff --git a/Plugins/GreetPlugin.hs b/Plugins/GreetPlugin.hs deleted file mode 100644 --- a/Plugins/GreetPlugin.hs +++ /dev/null @@ -1,17 +0,0 @@ -module GreetPlugin where -import API - -plugin :: InfinityPlugin -plugin = InfinityPlugin { - name = "Greet", - commands = ["hi","bye"], - help = [("hi","says 'hello world!") - ,("bye","says 'goodbye cruel world!")], - action = greet -} - -greet :: InfAction -greet user chan command str = do - case command of - "hi" -> return "hello world!" - "bye" -> return "goodbye cruel world!" diff --git a/Plugins/PLUGINS b/Plugins/PLUGINS deleted file mode 100644 --- a/Plugins/PLUGINS +++ /dev/null @@ -1,70 +0,0 @@ -== introduction == -writing plugins for infinity is remarkably simple. - -here's a ~30 second tutorial to writing a plugin -that takes a string as an argument, and simply -reverses it. - -1. create a file in Plugins/ under the name - ReversePlugin.hs. -2. Put this in the file: - --- snip -module ReversePlugin where -import API -- imports Infinity's API - -plugin :: InfinityPlugin -plugin = InfinityPlugin { - name = "ReverseString", - commands = ["rev"], - description = "reverses a string", - action = rev -} - -rev :: InfAction -rev _ _ s = (return . reverse) s --- end snip - -3. start infinity -4. done. infinity automatically compiles - and loads the plugin on startup! no - static compilation! (this has the - benefit that you don't need to - recompile upon adding new plugins - or modifying old ones, simply - restart infinity) - - -== notes == -while writing plugins is quite simple, there -are a few things you should note: - -1. the name of the file and the name - of the module as declared in the first - line of the file *must* be the same; - you cannot have a plugin with a module - name of "DestroyEarth" in the file - Plugins/NuclearBomb.hs. -2. plugins can register multiple commands, - these are passed to the action upon - invocation as the first parameter -3. the action in the plugin needs to have - a type of: - String -> String -> String -> IO String - - the first argument is the nick of who - invoked the command, the second is the - name of the command that was invoked, - while the third is the actual - string that the user passed to - the command -4. if you need to return multiple lines of - output, simply turn your return your string - enclosed in unlines, i.e.: - - return $ unlines ["Hello","World"] - - infinity will correctly break this - into multiple lines and output it. - -that is all. happy hacking... diff --git a/Plugins/System.hs b/Plugins/System.hs new file mode 100644 --- /dev/null +++ b/Plugins/System.hs @@ -0,0 +1,57 @@ +module System where +import qualified Data.Map as M +import Control.Monad.Reader +import System.IO +import Data.List +import API + + +plugin :: InfinityPlugin +plugin = InfinityPlugin { + name = "System", + commands = [("join","joins a channel") + ,("part","parts a channel") + ,("list","list commands") + ,("help","shows help for a command") + ,("version","show version info")], + action = system +} + +system :: PLUGIN +system user channel command args = do + case command of + "join" -> do + admins <- asks admins + if user `elem` admins then + case args of + Nothing -> retJust $ "Need a channel..." + Just av -> do + mapM_ (send "JOIN") (words av) + retJust $ "joined " ++ (concat $ intersperse " " $ words av) + else retJust "Can't do that..." + "part" -> do + admins <- asks admins + if user `elem` admins then + case args of + Nothing -> send "PART" channel >> retNothing + Just av -> do + mapM_ (\ch -> send "PART" ch) (words av) + retJust $ "parted " ++ (concat $ intersperse " " $ words av) + else retJust "Can't do that..." + "list" -> do + plist <- getplugs + let plist' = map (\p -> ((name p)++" provides: "++(concat . (intersperse " ") . fst . unzip . commands $ p))) plist + retJust $ unlines plist' + "help" -> do + plist <- getplugs + case args of + Nothing -> retJust $ "Need a command, try '!help help!" + Just av -> do + let cmd = (head . words) av + plist' = filter (\p -> cmd `elem` (fst . unzip . commands $ p)) plist + if null plist' then do + retJust $ "No plugin with command '"++cmd++"' found..." + else do + let x = head plist' + retJust $ M.findWithDefault "No help available..." cmd $ (M.fromList . commands) x + "version" -> infinityVer >>= retJust diff --git a/Plugins/SystemPlugin.hs b/Plugins/SystemPlugin.hs deleted file mode 100644 --- a/Plugins/SystemPlugin.hs +++ /dev/null @@ -1,56 +0,0 @@ -module SystemPlugin where -import qualified Data.Map as M -import Control.Monad.Reader -import System.IO -import Data.List -import API - - -plugin :: InfinityPlugin -plugin = InfinityPlugin { - name = "System", - commands = ["join" - ,"part" - ,"list" - ,"help" - ,"version"], - help = [("join","joins a channel") - ,("part","parts a channel") - ,("list","list commands") - ,("help","shows help for a command") - ,("version","show version info")], - action = system -} - -system :: InfAction -system user channel command args = do - case command of - "join" -> do - admins <- asks admins - if user `elem` admins then do - mapM_ (\ch -> send "JOIN" ch) (words args) - return $ "joined " ++ (concat $ intersperse " " $ words args) - else return "Can't do that..." - "part" -> do - admins <- asks admins - if user `elem` admins then do - mapM_ (\ch -> send "PART" ch) (words args) - return $ "parted " ++ (concat $ intersperse " " $ words args) - else return "Can't do that..." - "list" -> do - plist <- asks pluglist - let plist' = map (\p -> ((name p)++" provides: "++(concat $ intersperse " " $ commands p))) plist - return $ unlines plist' - "help" -> do - plist <- asks pluglist - if (not.null) args then do - let cmd = (head . words) args - plist' = filter (\p -> cmd `elem` (commands p)) plist - if null plist' then do - return $ "No plugin with command '"++cmd++"' found..." - else do - let x = head plist' - return $ M.findWithDefault "No help available..." cmd $ (M.fromList . help) x - else return "Need a command, try '!help help'" - "version" -> do - return infinityVer diff --git a/Plugins/Test.hs b/Plugins/Test.hs new file mode 100644 --- /dev/null +++ b/Plugins/Test.hs @@ -0,0 +1,20 @@ +module Test where +import API + +plugin :: InfinityPlugin +plugin = InfinityPlugin { + name = "Test", + commands = [("put","put value to disk"), + ("get","get value from disk")], + action = test +} + +test :: PLUGIN +test user chan cmd av = do + case cmd of + "put" -> do putState "hello" ("test") + retJust "done..." + "get" -> do x <- getState "hello" :: PLUG (Maybe String) + case x of + Nothing -> retJust "No state..." + Just y -> retJust $ show y diff --git a/README b/README --- a/README +++ b/README @@ -1,26 +1,24 @@ name: infinity synopsis: a small, pluggable, configurable irc bot in haskell -description: infinity is an IRC bot written in haskell that is -designed to be extendable and modifiable. it is inspired largely -by don stewart's (or should I say #haskell's?) lambdabot. +desc: infinity is an IRC bot written in haskell that is + designed to be extendable and modifiable. it is + inspired largely by don stewart's (or should I + say #haskell's?) lambdabot. == installation == see INSTALL for more information + == usage == standard usage is like so after being built: $ ./infinity infinity is now operational. :) -if you want to see infinity's compiled -in configuration, run -$ ./infinity -conf + == configuration == please see Config.hs -== writing plugins == -please see Plugins/PLUGINS == bugs, patches and feedback == if you have identified any bugs in infinity, have any patches diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -8,7 +8,6 @@ import List b = "infinity" -api = ["API.hi","API.o"] -- needed for plugins to load main = defaultMainWithHooks $ defaultUserHooks { postBuild = copyInfinity, @@ -18,22 +17,23 @@ copyInfinity _ _ _ _ = do copyFile ("dist/build/infinity/"++b) b - mapM_ (\x -> copyFile ("dist/build/infinity/infinity-tmp/"++x) x) api - return ExitSuccess + Ex.catch (createDirectory "Log" >> createDirectory "State") + (\_ -> return ()) + return () cleanInfinity _ _ _ _ = do - Ex.catch (removeFile b >> -- we don't care too much if there's no - removeDirectory "dist") -- infinity binary in the topmost dir, or - (\_ -> return ()) -- a dist/ dir + Ex.catch (removeFile b) + (\_ -> return ()) clean "." clean "Plugins" - return ExitSuccess + return () where clean s = do c <- getDirectoryContents s forM_ c $ \f -> do if (".o" `isSuffixOf` f || ".hi" `isSuffixOf` f || + "#" `isSuffixOf` f || "~" `isSuffixOf` f) then removeFile $ s++"/"++f else return () diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Utils where -import Control.Monad.Reader -import System.Plugins -import Data.Version -import System.Info -import System.Exit -import Config - -instance Show Server where - show s = unlines $ ["\tServer:\t\t" ++ (address s), - "\tPort:\t\t" ++ (show . portnum $ s), - "\tChannels:\t" ++ (show . channels $ s), - "\tNickname:\t" ++ (nickname s), - "\tPassword:\t*****", -- we don't ever show the password - "\tReal name:\t" ++ (realname s) - ] - -instance Show Config where - show c = unlines $ ["Command prefixes:\t" ++ (show . commandPrefixes $ c), - "Server list:\n\n" ++ (unlines . map show $ servers c) - ] - -getConfig :: IO Config -getConfig = do - o <- make "Config.hs" [] - case o of - MakeSuccess _ obj -> do - sym <- load_ obj ["."] "config" - case sym of - LoadSuccess _ v -> do - putStrLn "Loaded Config.hs..." - return v :: IO Config - LoadFailure e -> do - putStrLn "Loading of Configuration FAILED:" - mapM_ putStrLn e - exitWith (ExitFailure 1) - MakeFailure e -> do - putStrLn "Compilation of Config.HS FAILED:" - mapM_ putStrLn e - exitWith (ExitFailure 1) diff --git a/infinity.cabal b/infinity.cabal --- a/infinity.cabal +++ b/infinity.cabal @@ -1,24 +1,28 @@ Name: infinity -Version: 0.1.1 -Description: a tiny IRC bot, extendable through - plugins written in haskell -Synopsis: a tiny IRC bot -Category: network +Version: 0.3 +Description: a tiny, pluggable irc bot License: BSD3 License-file: LICENSE +Stability: Provisional Author: Austin Seipp Maintainer: austin@youareinferior.net -Build-Depends: base, mtl, network, plugins, haskell98 -Extra-Source-Files: INSTALL, README, - API.hs, - Utils.hs, - IRC.hs, +Cabal-Version: >= 1.2 +Extra-Source-Files: README, + INSTALL, + PLoader.hs, + Monitor.hs, Config.hs, - Plugins.hs, - Plugins/PLUGINS - Plugins/GreetPlugin.hs, - Plugins/SystemPlugin.hs + Logger.hs, + PState.hs, + IMain.hs, + Main.hs, + API.hs, + Net.hs, + Plugins/System.hs, + Plugins/Greet.hs, + Plugins/Test.hs -Executable: infinity -Main-is: Infinity.hs -ghc-options: -O +executable infinity + main-is: Main.hs + build-depends: Cabal >= 1.2, plugins >= 1.0, ghc >= 6.6 && < 6.8, binary >= 0.3, filepath, irc >= 0.2.3, base + ghc-options: -O2 -threaded