infinity 0.1.1 → 0.3
raw patch · 23 files changed
+893/−489 lines, 23 filesdep +Cabaldep +binarydep +filepathdep −haskell98dep −mtldep −networkdep ~pluginssetup-changed
Dependencies added: Cabal, binary, filepath, ghc, irc
Dependencies removed: haskell98, mtl, network
Dependency ranges changed: plugins
Files
- API.hs +91/−30
- Config.hs +11/−8
- IMain.hs +118/−0
- INSTALL +14/−4
- IRC.hs +0/−124
- Infinity.hs +0/−49
- Logger.hs +60/−0
- Main.hs +49/−0
- Monitor.hs +94/−0
- Net.hs +219/−0
- PLoader.hs +66/−0
- PState.hs +44/−0
- Plugins.hs +0/−59
- Plugins/Greet.hs +16/−0
- Plugins/GreetPlugin.hs +0/−17
- Plugins/PLUGINS +0/−70
- Plugins/System.hs +57/−0
- Plugins/SystemPlugin.hs +0/−56
- Plugins/Test.hs +20/−0
- README +6/−8
- Setup.hs +7/−7
- Utils.hs +0/−40
- infinity.cabal +21/−17
API.hs view
@@ -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
Config.hs view
@@ -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" }-
+ IMain.hs view
@@ -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)
INSTALL view
@@ -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
− IRC.hs
@@ -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)
− Infinity.hs
@@ -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
+ Logger.hs view
@@ -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"+
+ Main.hs view
@@ -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
+ Monitor.hs view
@@ -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
+ Net.hs view
@@ -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
+ PLoader.hs view
@@ -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
+ PState.hs view
@@ -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
− Plugins.hs
@@ -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
+ Plugins/Greet.hs view
@@ -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!"
− Plugins/GreetPlugin.hs
@@ -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!"
− Plugins/PLUGINS
@@ -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...
+ Plugins/System.hs view
@@ -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
− Plugins/SystemPlugin.hs
@@ -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
+ Plugins/Test.hs view
@@ -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
README view
@@ -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
Setup.hs view
@@ -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 ()
− Utils.hs
@@ -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)
infinity.cabal view
@@ -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