lambdabot-core 5.0.3 → 5.1

raw patch · 19 files changed

+577/−512 lines, 19 filesdep +prim-uniqdep +sybdep ~dependent-mapdep ~dependent-sumdep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: prim-uniq, syb

Dependency ranges changed: dependent-map, dependent-sum, network

API changes (from Hackage documentation)

Files

• COMMENTARY.md +18/−16
• lambdabot-core.cabal +6/−5
• src/Lambdabot/Bot.hs +39/−82
• src/Lambdabot/Config.hs +24/−31
• src/Lambdabot/Config/Core.hs +4/−0
• src/Lambdabot/File.hs +1/−0
• src/Lambdabot/IRC.hs +2/−0
• src/Lambdabot/Main.hs +35/−31
• src/Lambdabot/Module.hs +30/−34
• src/Lambdabot/Monad.hs +211/−130
• src/Lambdabot/OutputFilter.hs +0/−48
• src/Lambdabot/Plugin.hs +0/−5
• src/Lambdabot/Plugin/Core/Base.hs +137/−84
• src/Lambdabot/Plugin/Core/Compose.hs +7/−6
• src/Lambdabot/Plugin/Core/Help.hs +7/−4
• src/Lambdabot/Plugin/Core/More.hs +6/−4
• src/Lambdabot/Plugin/Core/OfflineRC.hs +20/−8
• src/Lambdabot/Plugin/Core/System.hs +20/−12
• src/Lambdabot/State.hs +10/−12

@@ -2,7 +2,7 @@ =======================  Basic concepts-------------+--------------  Lambdabot's functionality is provided by a "core" that provides message routing and some basic infrastructure for several "plugins", which implement specific user-facing behaviors.  The core makes some assumptions about the nature of those behaviors.  The following, in no particular order, are some of the central concepts of the lambdabot design: @@ -19,7 +19,7 @@ - Callbacks.  Plugins can register callbacks to react to non-chat messages such as nick changes, join/part events, etc.  User code execution---------------------+-------------------  Lambdabot provides the ability to execute user-supplied Haskell code.  This is obviously a somewhat risky thing to do.  We use 2 main mechanisms to mitigate this risk: @@ -52,37 +52,39 @@     {- import your plugins here -}          main = lambdabotMain myPlugins -        [ configKey  :=> value-        , anotherKey :=> anotherValue+        [ configKey  ==> value+        , anotherKey ==> anotherValue         ]  Any key not listed will be assigned the default value specified in its original declaration. -Source layout and module heirarchy+Source layout and module hierarchy ---------------------------------- +**outdated**: this section predates the split of lambdabot into several subpackages+ - src/--- Lambdabot.Compat.*+  - Lambdabot.Compat.* -Modules supporting backward-compatibility with older versions of lambdabot (mostly functions to read old serialization formats)+    Modules supporting backward-compatibility with older versions of lambdabot (mostly functions to read old serialization formats) --- Lambdabot.Config.*+  - Lambdabot.Config.* -Currently only "Core", this module defines the configuration keys for the lambdabot core system.  Packages providing additional plugins are encouraged to use this namespace (or the module in which they are used, if they prefer) for additional configuration key definitions.  The configuration system is described above.+    Currently only "Core", this module defines the configuration keys for the lambdabot core system.  Packages providing additional plugins are encouraged to use this namespace (or the module in which they are used, if they prefer) for additional configuration key definitions.  The configuration system is described above. --- Lambdabot.Plugin.*+  - Lambdabot.Plugin.* -As the name suggests, all lambdabot plugins are defined in modules under this namespace.+    As the name suggests, all lambdabot plugins are defined in modules under this namespace. --- Lambdabot.Util.*+  - Lambdabot.Util.* -Utility functions for use by lambdabot plugins.  This is not considered a stable public interface; I am actively working on eliminating them in favor of external libraries that provide equivalent functionality.+    Utility functions for use by lambdabot plugins.  This is not considered a stable public interface; I am actively working on eliminating them in favor of external libraries that provide equivalent functionality. --- Lambdabot, Lambdabot.*+  - Lambdabot, Lambdabot.* -The core lambdabot system.  Like the Util namespace, these are not especially stable right now.+    The core lambdabot system.  Like the Util namespace, these are not especially stable right now.  - main/ -Defines the main lambdabot executable, usable either as-is or as a template for a customized executable.+  Defines the main lambdabot executable, usable either as-is or as a template for a customized executable. 

@@ -1,5 +1,5 @@ name:                   lambdabot-core-version:                5.0.3+version:                5.1  license:                GPL license-file:           LICENSE@@ -19,7 +19,7 @@  build-type:             Simple cabal-version:          >= 1.8-tested-with:            GHC == 7.6.3, GHC == 7.8.3+tested-with:            GHC == 7.8.4, GHC == 7.10.3  extra-source-files:     AUTHORS.md                         COMMENTARY.md@@ -49,7 +49,6 @@                         Lambdabot.Module                         Lambdabot.Monad                         Lambdabot.Nick-                        Lambdabot.OutputFilter                         Lambdabot.Plugin                         Lambdabot.Plugin.Core                         Lambdabot.State@@ -71,8 +70,8 @@                         binary                  >= 0.5,                         bytestring              >= 0.9,                         containers              >= 0.4,-                        dependent-map           == 0.1.*,-                        dependent-sum           == 0.2.*,+                        dependent-map           == 0.2.*,+                        dependent-sum           == 0.3.*,                         dependent-sum-template  >= 0.0.0.1,                         directory               >= 1.1,                         edit-distance           >= 0.2,@@ -86,12 +85,14 @@                         network                 >= 2.3.0.13,                         time                    >= 1.4,                         parsec                  >= 3,+                        prim-uniq               == 0.1.*,                         random                  >= 1,                         random-fu               >= 0.2,                         random-source           >= 0.3,                         regex-tdfa              >= 1.1,                         SafeSemaphore           >= 0.9,                         split                   >= 0.2,+                        syb                     >= 0.3,                         template-haskell        >= 2.7,                         transformers            >= 0.2,                         transformers-base       >= 0.4,

@@ -9,8 +9,6 @@ module Lambdabot.Bot     ( ircLoadModule     , ircUnloadModule-    , ircSignalConnect-    , ircInstallOutputFilter     , checkPrivs     , checkIgnore     @@ -23,19 +21,18 @@     ) where  import Lambdabot.ChanName-import Lambdabot.Command+import Lambdabot.Config+import Lambdabot.Config.Core import Lambdabot.IRC import Lambdabot.Logging import Lambdabot.Message import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Nick-import Lambdabot.OutputFilter import Lambdabot.State-import Lambdabot.Util  import Control.Concurrent-import Control.Exception.Lifted+import Control.Exception.Lifted as E import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State@@ -47,90 +44,50 @@ -- -- | Register a module in the irc state ---ircLoadModule :: Module st -> String -> LB ()-ircLoadModule m modname = do-    infoM ("Loading module " ++ show modname)-    savedState <- readGlobalState m modname-    state'     <- maybe (moduleDefState m) return savedState-    ref        <- io $ newMVar state'+ircLoadModule :: String -> Module st -> LB ()+ircLoadModule mName m = do+    infoM ("Loading module " ++ show mName)     -    let modref = ModuleRef  m ref modname-        cmdref = CommandRef m ref modname+    savedState <- readGlobalState m mName+    mState     <- maybe (moduleDefState m) return savedState     -    mbCmds <- flip runReaderT (ref, modname) . runModuleT $ do-        initResult <- try (moduleInit m)-        case initResult of-            Left e  -> return (Left e)-            Right{} -> try (moduleCmds m)+    mInfo       <- registerModule mName m mState     -    case mbCmds of-        Left e@SomeException{} -> do-            errorM ("Module " ++ show modname ++ " failed to load.  Exception thrown: " ++ show e)+    flip runModuleT mInfo (do+            moduleInit m+            registerCommands =<< moduleCmds m)+        `E.catch` \e@SomeException{} -> do+            errorM ("Module " ++ show mName ++ " failed to load.  Exception thrown: " ++ show e)             +            unregisterModule mName             fail "Refusing to load due to a broken plugin"-        Right cmds -> do-            s <- get-            let modmap = ircModules s-                cmdmap = ircCommands s-            put s {-              ircModules = M.insert modname modref modmap,-              ircCommands = M.union (M.fromList [ (name,cmdref cmd) | cmd <- cmds, name <- cmdNames cmd ]) cmdmap-            }  -- -- | Unregister a module's entry in the irc state -- ircUnloadModule :: String -> LB ()-ircUnloadModule modname = do-    infoM ("Unloading module " ++ show modname)+ircUnloadModule mName = do+    infoM ("Unloading module " ++ show mName)     -    withModule modname (error "module not loaded") $ \m -> do+    inModuleNamed mName (fail "module not loaded") $ do+        m <- asks theModule         when (moduleSticky m) $ fail "module is sticky"         -        exitResult <- try (moduleExit m)-        case exitResult of-            Right{} -> return ()-            Left e@SomeException{} -> errorM ("Module " ++ show modname ++ " threw the following exception in moduleExit: " ++ show e)+        moduleExit m+            `E.catch` \e@SomeException{} -> +                errorM ("Module " ++ show mName ++ " threw the following exception in moduleExit: " ++ show e)         -        writeGlobalState m modname+        writeGlobalState     -    s <- get-    let modmap = ircModules s-        cmdmap = ircCommands s-        cbs    = ircCallbacks s-        svrs   = ircServerMap s-        ofs    = ircOutputFilters s-    put s-        { ircCommands      = M.filter (\(CommandRef _ _ name _) -> name /= modname) cmdmap-        , ircModules       = M.delete modname modmap-        , ircCallbacks     =   filter ((/=modname) . fst) `fmap` cbs-        , ircServerMap     = M.filter ((/=modname) . fst) svrs-        , ircOutputFilters =   filter ((/=modname) . fst) ofs-        }+    unregisterModule mName  ------------------------------------------------------------------------ -ircSignalConnect :: String -> Callback -> ModuleT mod LB ()-ircSignalConnect str f = do-    s <- lift get-    let cbs = ircCallbacks s-    name <- getModuleName-    case M.lookup str cbs of -- TODO: figure out what this TODO is for-        Nothing -> lift (put s { ircCallbacks = M.insert str [(name,f)]    cbs})-        Just fs -> lift (put s { ircCallbacks = M.insert str ((name,f):fs) cbs})--ircInstallOutputFilter :: OutputFilter LB -> ModuleT mod LB ()-ircInstallOutputFilter f = do-    name <- getModuleName-    lift . modify $ \s ->-        s { ircOutputFilters = (name, f): ircOutputFilters s }---- | Checks if the given user has admin permissions and excecute the action---   only in this case.+-- | Checks whether the given user has admin permissions checkPrivs :: IrcMessage -> LB Bool checkPrivs msg = gets (S.member (nick msg) . ircPrivilegedUsers) --- | Checks if the given user is being ignored.+-- | Checks whether the given user is being ignored. --   Privileged users can't be ignored. checkIgnore :: IrcMessage -> LB Bool checkIgnore msg = liftM2 (&&) (liftM not (checkPrivs msg))@@ -154,28 +111,28 @@ -- exceptoin, we clean up and go home ircQuit :: String -> String -> LB () ircQuit svr msg = do-    modify $ \state' -> state' { ircStayConnected = False }+    modify $ \state' -> state' { ircPersists = M.delete svr $ ircPersists state' }     send  $ quit svr msg     liftIO $ threadDelay 1000     noticeM "Quitting"  ircReconnect :: String -> String -> LB () ircReconnect svr msg = do+    modify $ \state' -> state' { ircPersists = M.insertWith (flip const) svr False $ ircPersists state' }     send $ quit svr msg     liftIO $ threadDelay 1000 --- | Send a message to a channel\/user. If the message is too long, the rest---   of it is saved in the (global) more-state.+-- | Send a message to a channel\/user, applying all output filters ircPrivmsg :: Nick      -- ^ The channel\/user.            -> String        -- ^ The message.            -> LB ()  ircPrivmsg who msg = do-    filters   <- gets ircOutputFilters-    sendlines <- foldr (\f -> (=<<) (f who)) ((return . lines) msg) $ map snd filters-    mapM_ (\s -> ircPrivmsg' who (take textwidth s)) (take 10 sendlines)+    sendlines <- applyOutputFilters who msg+    w <- getConfig textWidth+    mapM_ (\s -> ircPrivmsg' who (take w s)) (take 10 sendlines) --- A raw send version+-- A raw send version (bypasses output filters) ircPrivmsg' :: Nick -> String -> LB () ircPrivmsg' who ""  = ircPrivmsg' who " " ircPrivmsg' who msg = send $ privmsg who msg@@ -185,11 +142,11 @@ monadRandom [d|      instance MonadRandom LB where-        getRandomWord8          = LB (lift getRandomWord8)-        getRandomWord16         = LB (lift getRandomWord16)-        getRandomWord32         = LB (lift getRandomWord32)-        getRandomWord64         = LB (lift getRandomWord64)-        getRandomDouble         = LB (lift getRandomDouble)-        getRandomNByteInteger n = LB (lift (getRandomNByteInteger n))+        getRandomWord8          = liftIO getRandomWord8+        getRandomWord16         = liftIO getRandomWord16+        getRandomWord32         = liftIO getRandomWord32+        getRandomWord64         = liftIO getRandomWord64+        getRandomDouble         = liftIO getRandomDouble+        getRandomNByteInteger n = liftIO (getRandomNByteInteger n)   |]

@@ -1,16 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} -- | Extensible configuration system for lambdabot--- +-- -- TODO: there's notthing lambdabot-specific about this, it could be a useful standalone library. module Lambdabot.Config     ( Config     , getConfigDefault     , mergeConfig-    +     , MonadConfig(..)-    +     , config     , configWithMerge     ) where@@ -25,6 +26,7 @@ import Data.GADT.Compare.TH import Data.Maybe import Data.Typeable+import Data.Generics (everywhere, mkT) import Language.Haskell.TH  data Config t where Config :: (Typeable1 k, GCompare k) => !(k t) -> t -> (t -> t -> t) -> Config t@@ -38,7 +40,7 @@         geq k1 k2'  instance GCompare Config where-    gcompare (Config k1 _ _) (Config k2 _ _) = +    gcompare (Config k1 _ _) (Config k2 _ _) =         case compare t1 t2 of             LT -> GLT             EQ -> fromMaybe typeErr $ do@@ -48,7 +50,7 @@         where             t1 = typeOf1 k1             t2 = typeOf1 k2-            +             typeErr = error "TypeReps claim to be equal but cast failed"  getConfigDefault :: Config t -> t@@ -64,9 +66,9 @@ instance (MonadConfig m, Monoid w) => MonadConfig (WriterT w m) where getConfig = lift . getConfig instance  MonadConfig m            => MonadConfig (StateT  s m) where getConfig = lift . getConfig --- |Define a new configuration key with the specified name, type and +-- |Define a new configuration key with the specified name, type and -- default value--- +-- -- You should probably also provide an explicit export list for any -- module that defines config keys, because the definition introduces -- a few extra types that will clutter up the export list otherwise.@@ -75,7 +77,7 @@  -- |Like 'config', but also allowing you to specify a \"merge rule\" -- that will be used to combine multiple bindings of the same key.--- +-- -- For example, in "Lambdabot.Config.Core", 'onStartupCmds' is -- defined as a list of commands to execute on startup.  Its default -- value is ["offlinerc"], so if a user invokes the default lambdabot@@ -83,7 +85,7 @@ -- of "-e" on the command-line adds a binding of the form: -- -- > onStartupCmds :=> [command]--- +-- -- So if they give one "-e", it replaces the default (note that it -- is _not_ merged with the default - the default is discarded), and -- if they give more than one they are merged using the specified@@ -93,27 +95,18 @@     let keyName = mkName nameStr     tyName      <- newName (map toUpper nameStr)     conName     <- newName (map toUpper nameStr)-    tyVarName   <- newName "a'"-    -    ty          <- tyQ-    defVal      <- defValQ-    mergeExpr   <- mergeQ-    let tyDec   = DataD [] tyName [PlainTV tyVarName] [ForallC [] [mkEqualP (VarT tyVarName) ty] (NormalC conName [])] [''Typeable]-        keyDecs =-            [ SigD keyName (AppT (ConT ''Config) ty)-            , ValD (VarP keyName) (NormalB (ConE 'Config `AppE` ConE conName `AppE` defVal `AppE` mergeExpr)) []-            ]-    +    let patchNames :: Name -> Name+        patchNames (nameBase -> "keyName") = keyName+        patchNames (nameBase -> "TyName")  = tyName+        patchNames (nameBase -> "ConName") = conName+        patchNames d = d+    decs <- everywhere (mkT patchNames) <$>+        [d| data TyName a = a ~ $(tyQ) => ConName deriving Typeable++            keyName :: Config $(tyQ)+            keyName = Config ConName $(defValQ) $(mergeQ) |]     concat <$> sequence-        [ return [tyDec]-        , return keyDecs-        , deriveGEq tyDec-        , deriveGCompare tyDec+        [ return decs+        , deriveGEq (head decs)+        , deriveGCompare (head decs)         ]--mkEqualP :: Type -> Type -> Pred-#if __GLASGOW_HASKELL__ > 708-mkEqualP t1 t2 = EqualityT `AppT` t1 `AppT` t2-#else-mkEqualP = EqualP-#endif

@@ -11,6 +11,7 @@     , outputDir     , dataDir     , lbVersion+    , textWidth     , uncaughtExceptionHandler          , replaceRootLogger@@ -40,6 +41,9 @@ config "dataDir"            [t| FilePath                |] [| "."           |] -- ditto for lbVersion config "lbVersion"          [t| Version                 |] [| Version [] [] |]++-- IRC maximum msg length, minus a bit for safety.+config "textWidth"          [t| Int                     |] [| 200 :: Int    |]  -- basic logging.  for more complex setups, configure directly using System.Log.Logger config "replaceRootLogger"  [t| Bool                    |] [| True                        |]

@@ -17,6 +17,7 @@     , outputDir     ) where +import Lambdabot.Config import Lambdabot.Config.Core import Lambdabot.Monad import Lambdabot.Util

@@ -26,6 +26,8 @@ import Control.Monad (liftM2)  -- | An IRC message is a server, a prefix, a command and a list of parameters.+--+-- Note that the strings here are treated as lists of bytes! data IrcMessage   = IrcMessage {         ircMsgServer   :: !String,

@@ -4,6 +4,7 @@          , Config     , DSum(..)+    , (==>)     , lambdabotMain      , Modules@@ -19,14 +20,15 @@ import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Plugin.Core-import Lambdabot.State import Lambdabot.Util import Lambdabot.Util.Signals  import Control.Exception.Lifted as E+import Control.Monad.Identity import Data.Dependent.Sum import Data.List-import Data.Typeable+import Data.IORef+import Data.Some import Data.Version import Language.Haskell.TH import Paths_lambdabot_core (version)@@ -63,46 +65,48 @@ -- Also, handle any fatal exceptions (such as non-recoverable signals), -- (i.e. print a message and exit). Non-fatal exceptions should be dealt -- with in the mainLoop or further down.-lambdabotMain :: LB () -> [DSum Config] -> IO ExitCode+lambdabotMain :: Modules -> [DSum Config Identity] -> IO ExitCode lambdabotMain initialise cfg = withSocketsDo . withIrcSignalCatch $ do     rost <- initRoState cfg-    r <- try $ evalLB (do setupLogging-                          noticeM "Initialising plugins"-                          initialise-                          noticeM "Done loading plugins"-                          reportInitDone rost-                          mainLoop-                          return ExitSuccess)-                       rost initRwState--    -- clean up and go home-    case r of-        Left (SomeException er) -> do-            case cast er of+    rwst <- newIORef initRwState+    runLB (lambdabotRun initialise) (rost, rwst)+        `E.catch` \e -> do+            -- clean up and go home+            case fromException e of                 Just code -> return code-                Nothing -> do-                    putStrLn "exception:"-                    print er+                Nothing   -> do+                    errorM (show e)                     return (ExitFailure 1)-        Right code -> return code --- Actually, this isn't a loop anymore.  TODO: better name.-mainLoop :: LB ()-mainLoop = do-    waitForQuit `E.catch`-        (\e@SomeException{} -> errorM (show e)) -- catch anything, print informative message, and clean up+lambdabotRun :: Modules -> LB ExitCode+lambdabotRun ms = do+    setupLogging+    infoM "Initialising plugins"+    withModules ms $ do+        infoM "Done loading plugins"+        reportInitDone+        +        waitForQuit `E.catch`+            (\e@SomeException{} -> errorM (show e)) -- catch anything, print informative message, and clean up     -    withAllModules moduleExit-    flushModuleState-+    -- clean up any dynamically loaded modules+    mapM_ ircUnloadModule =<< listModules+    return ExitSuccess  ------------------------------------------------------------------------ -type Modules = LB ()+type Modules = [(String, Some Module)]  modules :: [String] -> Q Exp-modules xs = [| sequence_ $(listE $ map instalify (nub xs)) |]+modules xs = [| $(listE $ map instalify (nub xs)) |]     where         instalify x =             let module' = varE $ mkName (x ++ "Plugin")-             in [| ircLoadModule $module' x |]+             in [| (x, This $module') |]++withModules :: Modules -> LB a -> LB a+withModules []      = id+withModules ((n, This m):ms)  = withModule n m . withModules ms++withModule :: String -> Module st -> LB a -> LB a+withModule name m = bracket_ (ircLoadModule name m) (ircUnloadModule name)

@@ -7,13 +7,12 @@     ( Module(..)     , newModule     -    , ModuleT(..)--    , getRef-    , getModuleName-    , bindModule0-    , bindModule1-    , bindModule2+    , ModuleID+    , newModuleID+    +    , ModuleInfo(..)+    , ModuleT+    , runModuleT     ) where  import qualified Lambdabot.Command as Cmd@@ -26,9 +25,10 @@ import Control.Concurrent (MVar) import Control.Monad import Control.Monad.Base-import Control.Monad.Reader (MonadReader(..), ReaderT(..))+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import Control.Monad.Trans (MonadTrans(..), MonadIO(..)) import Control.Monad.Trans.Control+import Data.Unique.Tag import System.Console.Haskeline.MonadException (MonadException)  ------------------------------------------------------------------------@@ -81,17 +81,33 @@     , moduleDefState     = return $ error "state not initialized"     } ---+newtype ModuleID st = ModuleID (Tag RealWorld st)+    deriving (GEq, GCompare)++newModuleID :: IO (ModuleID st)+newModuleID = ModuleID <$> newTag++-- |Info about a running module.+data ModuleInfo st = ModuleInfo+    { moduleName   :: !String+    , moduleID     :: !(ModuleID st)+    , theModule    :: !(Module st)+    , moduleState  :: !(MVar st)+    }+ -- | This transformer encodes the additional information a module might --   need to access its name or its state.----newtype ModuleT st m a = ModuleT { runModuleT :: ReaderT (MVar st, String) m a }-    deriving (Applicative, Functor, Monad, MonadTrans, MonadIO, MonadException, MonadConfig)+newtype ModuleT st m a = ModuleT { unModuleT :: ReaderT (ModuleInfo st) m a }+    deriving (Applicative, Functor, Monad, MonadReader (ModuleInfo st), +        MonadTrans, MonadIO, MonadException, MonadConfig) +runModuleT :: ModuleT st m a -> ModuleInfo st -> m a+runModuleT = runReaderT . unModuleT+ instance MonadLogging m => MonadLogging (ModuleT st m) where     getCurrentLogger = do         parent <- lift getCurrentLogger-        self   <- getModuleName+        self   <- asks moduleName         return (parent ++ ["Plugin", self])     logM a b c = lift (logM a b c) @@ -102,7 +118,7 @@     type StT (ModuleT st) a = a     liftWith f = do         r <- ModuleT ask-        lift $ f $ \t -> runReaderT (runModuleT t) r+        lift $ f $ \t -> runModuleT t r     restoreT = lift     {-# INLINE liftWith #-}     {-# INLINE restoreT #-}@@ -113,23 +129,3 @@     restoreM     = defaultRestoreM     {-# INLINE liftBaseWith #-}     {-# INLINE restoreM #-}--getRef :: Monad m => ModuleT st m (MVar st)-getRef  = ModuleT $ ask >>= return . fst--getModuleName :: Monad m => ModuleT mod m String-getModuleName = ModuleT $ ask >>= return . snd---- | bind an action to the current module so it can be run from the plain---   `LB' monad.-bindModule0 :: ModuleT mod LB a -> ModuleT mod LB (LB a)-bindModule0 act = bindModule1 (const act) >>= return . ($ ())---- | variant of `bindModule0' for monad actions with one argument-bindModule1 :: (a -> ModuleT mod LB b) -> ModuleT mod LB (a -> LB b)-bindModule1 act = ModuleT $-    ask >>= \st -> return (\val -> runReaderT (runModuleT $ act val) st)---- | variant of `bindModule0' for monad actions with two arguments-bindModule2 :: (a -> b -> ModuleT mod LB c) -> ModuleT mod LB (a -> b -> LB c)-bindModule2 act = bindModule1 (uncurry act) >>= return . curry

@@ -14,24 +14,35 @@     , waitForQuit          , Callback-    , ModuleRef(..)-    , CommandRef(..)+    , OutputFilter+    , Server     , IRCRWState(..)     , initRwState     -    , LB(..)+    , LB+    , runLB+         , MonadLB(..)-    , evalLB     -    , addServer-    , remServer+    , registerModule+    , registerCommands+    , registerCallback+    , registerOutputFilter+    , unregisterModule+    +    , registerServer+    , unregisterServer     , send     , received     -    , getConfig+    , applyOutputFilters     -    , withModule+    , inModuleNamed+    , inModuleWithID+         , withCommand+    +    , listModules     , withAllModules     ) where @@ -44,18 +55,20 @@ import           Lambdabot.Module import qualified Lambdabot.Message as Msg import           Lambdabot.Nick-import           Lambdabot.OutputFilter import           Lambdabot.Util  import Control.Applicative import Control.Concurrent.Lifted import Control.Exception.Lifted as E (catch) import Control.Monad.Base+import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Control import qualified Data.Dependent.Map as D+import Data.Dependent.Sum import Data.IORef+import Data.Some import qualified Data.Map as M import qualified Data.Set as S import System.Console.Haskeline.MonadException (MonadException)@@ -69,23 +82,27 @@ data IRCRState = IRCRState     { ircInitDoneMVar   :: MVar ()     , ircQuitMVar       :: MVar ()-    , ircConfig         :: D.DMap Config+    , ircConfig         :: D.DMap Config Identity     }  -- | Default ro state-initRoState :: [D.DSum Config] -> IO IRCRState+initRoState :: [D.DSum Config Identity] -> IO IRCRState initRoState configuration = do     quitMVar     <- newEmptyMVar     initDoneMVar <- newEmptyMVar     +    let mergeConfig' k (Identity x) (Identity y) = Identity (mergeConfig k y x)+         return IRCRState          { ircQuitMVar       = quitMVar         , ircInitDoneMVar   = initDoneMVar-        , ircConfig         = D.fromListWithKey (flip . mergeConfig) configuration+        , ircConfig         = D.fromListWithKey mergeConfig' configuration         } -reportInitDone :: MonadIO m => IRCRState -> m ()-reportInitDone = io . flip putMVar () . ircInitDoneMVar+reportInitDone :: LB ()+reportInitDone = do+    mvar <- LB (asks (ircInitDoneMVar . fst))+    io $ putMVar mvar ()  askLB :: MonadLB m => (IRCRState -> a) -> m a askLB f  = lb . LB $ asks (f . fst)@@ -96,97 +113,50 @@ waitForQuit :: MonadLB m => m () waitForQuit = readMVar =<< askLB ircQuitMVar -type Callback = IrcMessage -> LB ()--data ModuleRef = forall st.-    ModuleRef (Module st) (MVar st) String+type Callback     st = IrcMessage -> ModuleT st LB ()+type OutputFilter st = Nick -> [String] -> ModuleT st LB [String]+type Server       st = IrcMessage -> ModuleT st LB () -data CommandRef = forall st.-    CommandRef (Module st) (MVar st) String (Command (ModuleT st LB))+newtype CallbackRef     st = CallbackRef     (Callback st)+newtype CommandRef      st = CommandRef      (Command (ModuleT st LB))+newtype OutputFilterRef st = OutputFilterRef (OutputFilter st)+newtype ServerRef       st = ServerRef       (Server st)  -- | Global read\/write state. data IRCRWState = IRCRWState-    { ircServerMap       :: M.Map String (String, IrcMessage -> LB ())+    { ircServerMap       :: M.Map String (DSum ModuleID ServerRef)     , ircPrivilegedUsers :: S.Set Nick     , ircIgnoredUsers    :: S.Set Nick          , ircChannels        :: M.Map ChanName String     -- ^ maps channel names to topics+    , ircPersists        :: M.Map String Bool+    -- ^ lists servers to which to reconnect on failure (one-time or always)     -    , ircModules         :: M.Map String ModuleRef-    , ircCallbacks       :: M.Map String [(String,Callback)]-    , ircOutputFilters   :: [(String, OutputFilter LB)]+    , ircModulesByName   :: M.Map String (Some ModuleInfo)+    , ircModulesByID     :: D.DMap ModuleID ModuleInfo+    , ircCallbacks       :: M.Map String (D.DMap ModuleID CallbackRef)+    , ircOutputFilters   :: [DSum ModuleID OutputFilterRef]     -- ^ Output filters, invoked from right to left     -    , ircCommands        :: M.Map String CommandRef-    , ircStayConnected   :: !Bool+    , ircCommands        :: M.Map String (DSum ModuleID CommandRef)     }  -- | Default rw state initRwState :: IRCRWState initRwState = IRCRWState-    { ircPrivilegedUsers = S.singleton (Nick "offlinerc" "null")+    { ircPrivilegedUsers = S.empty     , ircIgnoredUsers    = S.empty     , ircChannels        = M.empty-    , ircModules         = M.empty+    , ircPersists        = M.empty+    , ircModulesByName   = M.empty+    , ircModulesByID     = D.empty     , ircServerMap       = M.empty     , ircCallbacks       = M.empty-    , ircOutputFilters   = -        [ ([],cleanOutput)-        , ([],lineify)-        , ([],cleanOutput)-        ]+    , ircOutputFilters   = []     , ircCommands        = M.empty-    , ircStayConnected   = True     } ---- The virtual chat system.------ The virtual chat system sits between the chat drivers and the rest of--- Lambdabot.  It provides a mapping between the String server "tags" and--- functions which are able to handle sending messages.------ When a message is recieved, the chat module is expected to call--- `Lambdabot.Main.received'.  This is not ideal.--addServer :: String -> (IrcMessage -> LB ()) -> ModuleT mod LB ()-addServer tag sendf = do-    s <- lift get-    let svrs = ircServerMap s-    name <- getModuleName-    case M.lookup tag svrs of-        Nothing -> lift (put s { ircServerMap = M.insert tag (name,sendf) svrs})-        Just _ -> fail $ "attempted to create two servers named " ++ tag--remServer :: String -> LB ()-remServer tag = do-    s <- get-    let svrs = ircServerMap s-    case M.lookup tag svrs of-        Just _ -> do-            let svrs' = M.delete tag svrs-            put (s { ircServerMap = svrs' })-            when (M.null svrs') $ do-                quitMVar <- askLB ircQuitMVar-                io $ putMVar quitMVar ()-        Nothing -> fail $ "attempted to delete nonexistent servers named " ++ tag--send :: IrcMessage -> LB ()-send msg = do-    s <- gets ircServerMap-    case M.lookup (Msg.server msg) s of-        Just (_, sendf) -> sendf msg-        Nothing -> warningM $ "sending message to bogus server: " ++ show msg--received :: IrcMessage -> LB ()-received msg = do-    s       <- get-    handler <- getConfig uncaughtExceptionHandler-    case M.lookup (ircMsgCommand msg) (ircCallbacks s) of-        Just cbs -> mapM_ (\(_, cb) -> cb msg `E.catch` (liftIO . handler)) cbs-        _        -> return ()- -- --------------------------------------------------------------------- -- -- The LB (LambdaBot) monad@@ -197,16 +167,18 @@ -- -- instances Monad, Functor, MonadIO, MonadState, MonadError --newtype LB a = LB { runLB :: ReaderT (IRCRState,IORef IRCRWState) IO a }+newtype LB a = LB { unLB :: ReaderT (IRCRState, IORef IRCRWState) IO a }     deriving (Functor, Applicative, Monad, MonadIO, MonadException) +runLB :: LB a -> (IRCRState, IORef IRCRWState) -> IO a+runLB = runReaderT . unLB+ instance MonadBase IO LB where     liftBase = LB . liftBase  instance MonadBaseControl IO LB where     type StM LB a = StM (ReaderT (IRCRState,IORef IRCRWState) IO) a-    liftBaseWith action = LB (liftBaseWith (\run -> action (run . runLB)))+    liftBaseWith action = LB (liftBaseWith (\run -> action (run . unLB)))     restoreM = LB . restoreM  class (MonadIO m, MonadBaseControl IO m, MonadConfig m, MonadLogging m, Applicative m) => MonadLB m where@@ -217,68 +189,177 @@ instance MonadLB m => MonadLB (Cmd m)        where lb = lift . lb  instance MonadState IRCRWState LB where-    get = LB $ do-        ref <- asks snd-        lift $ readIORef ref-    put x = LB $ do+    state f = LB $ do         ref <- asks snd-        lift $ writeIORef ref x+        lift . atomicModifyIORef ref $ \s -> +            let (s', x) = f s+             in seq s' (x, s')  instance MonadConfig LB where-    getConfig k = liftM (maybe (getConfigDefault k) id . D.lookup k) (lb (askLB ircConfig))+    getConfig k = liftM (maybe (getConfigDefault k) runIdentity . D.lookup k) (lb (askLB ircConfig))  instance MonadLogging LB where     getCurrentLogger = getConfig lbRootLoggerPath     logM a b c = io (logM a b c) --- | run a computation in the LB monad-evalLB :: LB a -> IRCRState -> IRCRWState -> IO a-evalLB (LB lb') rs rws = do-    ref  <- newIORef rws-    lb' `runReaderT` (rs,ref)+---------------+-- state management (registering/unregistering various things) +registerModule :: String -> Module st -> st -> LB (ModuleInfo st)+registerModule mName m mState = do+    mTag    <- io newModuleID+    mInfo   <- ModuleInfo mName mTag m <$> newMVar mState+    +    modify $ \s -> s+        { ircModulesByName  = M.insert mName (This mInfo) (ircModulesByName s)+        , ircModulesByID    = D.insert mTag        mInfo  (ircModulesByID   s)+        }+    +    return mInfo++registerCommands :: [Command (ModuleT st LB)] -> ModuleT st LB ()+registerCommands cmds = do+    mTag <- asks moduleID+    let taggedCmds = +            [ (cName, mTag :=> CommandRef cmd)+            | cmd   <- cmds+            , cName <- cmdNames cmd+            ]+    +    lift $ modify $ \s -> s+        { ircCommands = M.union (M.fromList taggedCmds) (ircCommands s)+        }++registerCallback :: String -> Callback st -> ModuleT st LB ()+registerCallback str f = do+    mTag <- asks moduleID+    +    lift . modify $ \s -> s+        { ircCallbacks = M.insertWith D.union str+            (D.singleton mTag (CallbackRef f))+            (ircCallbacks s)+        }++registerOutputFilter :: OutputFilter st -> ModuleT st LB ()+registerOutputFilter f = do+    mTag <- asks moduleID+    lift . modify $ \s -> s+        { ircOutputFilters = (mTag :=> OutputFilterRef f) : ircOutputFilters s+        }++unregisterModule :: String -> LB ()+unregisterModule mName = maybe (return ()) warningM <=< state $ \s -> +    case M.lookup mName (ircModulesByName s) of+        Nothing                 -> (Just $ "Tried to unregister module that wasn't registered: " ++ show mName, s)+        Just (This modInfo)     ->+            let mTag = moduleID modInfo+                +                notThisTag :: DSum ModuleID f -> Bool+                notThisTag (tag :=> _) = This tag /= This mTag+                s' = s+                    { ircModulesByName  = M.delete mName        (ircModulesByName s)+                    , ircModulesByID    = D.delete mTag         (ircModulesByID   s)+                    , ircCommands       = M.filter notThisTag   (ircCommands      s)+                    , ircCallbacks      = M.map (D.delete mTag) (ircCallbacks     s)+                    , ircServerMap      = M.filter notThisTag   (ircServerMap     s)+                    , ircOutputFilters  =   filter notThisTag   (ircOutputFilters s)+                    }+             in (Nothing, s')++-- The virtual chat system.+--+-- The virtual chat system sits between the chat drivers and the rest of+-- Lambdabot.  It provides a mapping between the String server "tags" and+-- functions which are able to handle sending messages.+--+-- When a message is recieved, the chat module is expected to call+-- `Lambdabot.Main.received'.  This is not ideal.++registerServer :: String -> Server st -> ModuleT st LB ()+registerServer sName sendf = do+    mTag <- asks moduleID+    maybe (return ()) fail <=< lb . state $ \s ->+        case M.lookup sName (ircServerMap s) of+            Just _  -> (Just $ "attempted to create two servers named " ++ sName, s)+            Nothing -> +                let s' = s { ircServerMap = M.insert sName (mTag :=> ServerRef sendf) (ircServerMap s)}+                 in (Nothing, s')++-- TODO: fix race condition+unregisterServer :: String -> ModuleT mod LB ()+unregisterServer tag = lb $ do+    s <- get+    let svrs = ircServerMap s+    case M.lookup tag svrs of+        Just _ -> do+            let svrs' = M.delete tag svrs+            put (s { ircServerMap = svrs' })+            when (M.null svrs') $ do+                quitMVar <- askLB ircQuitMVar+                io $ putMVar quitMVar ()+        Nothing -> fail $ "attempted to delete nonexistent servers named " ++ tag++withUEHandler :: LB () -> LB ()+withUEHandler f = do+    handler <- getConfig uncaughtExceptionHandler+    E.catch f (io . handler)++send :: IrcMessage -> LB ()+send msg = do+    s <- gets ircServerMap+    let bogus = warningM $ "sending message to bogus server: " ++ show msg+    case M.lookup (Msg.server msg) s of+        Just (mTag :=> ServerRef sendf) -> +            withUEHandler (inModuleWithID mTag bogus (sendf msg))+        Nothing -> bogus++received :: IrcMessage -> LB ()+received msg = do+    s       <- get+    case M.lookup (ircMsgCommand msg) (ircCallbacks s) of+        Just cbs -> forM_ (D.toList cbs) $ \(tag :=> CallbackRef cb) ->+            withUEHandler (inModuleWithID tag (return ()) (cb msg))+        _        -> return ()++applyOutputFilter :: Nick -> DSum ModuleID OutputFilterRef -> [String] -> LB [String]+applyOutputFilter who (mTag :=> OutputFilterRef f) msg =+    inModuleWithID mTag (return msg) (f who msg)++applyOutputFilters :: Nick -> String -> LB [String]+applyOutputFilters who msg = do+    filters   <- gets ircOutputFilters+    foldr (\a x -> applyOutputFilter who a =<< x) ((return . lines) msg) filters+ ------------------------------------------------------------------------ -- Module handling  -- | Interpret an expression in the context of a module.--- Arguments are which map to use (@ircModules@ and @ircCommands@ are--- the only sensible arguments here), the name of the module\/command,--- action for the case that the lookup fails, action if the lookup--- succeeds.----withModule :: String-           -> LB a-           -> (forall st. Module st -> ModuleT st LB a)-           -> LB a--withModule modname def f = do-    maybemod <- gets (M.lookup modname . ircModules)-    case maybemod of-      -- TODO stick this ref stuff in a monad instead. more portable in-      -- the long run.-      Just (ModuleRef m ref name) -> do-          runReaderT (runModuleT $ f m) (ref, name)-      _                           -> def+inModuleNamed :: String -> LB a -> (forall st. ModuleT st LB a) -> LB a+inModuleNamed name nothing just = do+    mbMod <- gets (M.lookup name . ircModulesByName)+    case mbMod of+        Nothing             -> nothing+        Just (This modInfo) -> runModuleT just modInfo -withCommand :: String-            -> LB a-            -> (forall st. Module st-                        -> Command (ModuleT st LB)-                        -> ModuleT st LB a)-            -> LB a+inModuleWithID :: ModuleID st -> LB a -> (ModuleT st LB a) -> LB a+inModuleWithID tag nothing just = do+    mbMod <- gets (D.lookup tag . ircModulesByID )+    case mbMod of+        Nothing         -> nothing+        Just modInfo    -> runModuleT just modInfo +withCommand :: String -> LB a -> (forall st. Command (ModuleT st LB) -> ModuleT st LB a) -> LB a withCommand cmdname def f = do-    maybecmd <- gets (M.lookup cmdname . ircCommands)-    case maybecmd of-      -- TODO stick this ref stuff in a monad instead. more portable in-      -- the long run.-      Just (CommandRef m ref name cmd) -> do-          runReaderT (runModuleT $ f m cmd) (ref, name)-      _                           -> def+    mbCmd <- gets (M.lookup cmdname . ircCommands)+    case mbCmd of+        Just (tag :=> CommandRef cmd)   -> inModuleWithID tag def (f cmd)+        _                               -> def +listModules :: LB [String]+listModules = gets (M.keys . ircModulesByName)+ -- | Interpret a function in the context of all modules-withAllModules :: (forall st. Module st -> ModuleT st LB a) -> LB ()+withAllModules :: (forall st. ModuleT st LB a) -> LB () withAllModules f = do-    mods <- gets $ M.elems . ircModules :: LB [ModuleRef]-    (`mapM_` mods) $ \(ModuleRef m ref name) -> do-        runReaderT (runModuleT $ f m) (ref, name)+    mods <- gets $ M.elems . ircModulesByName+    forM_ mods $ \(This modInfo) -> runModuleT f modInfo

@@ -1,48 +0,0 @@-module Lambdabot.OutputFilter-    ( OutputFilter-    , textwidth-    -    , cleanOutput-    , lineify-    ) where--import Lambdabot.Nick-import Lambdabot.Util--import Data.Char-import Data.List--type OutputFilter m = Nick -> [String] -> m [String]--textwidth :: Int-textwidth = 200 -- IRC maximum msg length, minus a bit for safety.---- | For now, this just checks for duplicate empty lines.-cleanOutput :: Monad m => OutputFilter m-cleanOutput _ msg = return $ remDups True msg'-    where-        remDups True  ([]:xs) =    remDups True xs-        remDups False ([]:xs) = []:remDups True xs-        remDups _     (x: xs) = x: remDups False xs-        remDups _     []      = []-        msg' = map (dropFromEnd isSpace) msg---- | wrap long lines.-lineify :: Monad m => OutputFilter m-lineify = const (return . mlines . unlines)---- | break into lines-mlines :: String -> [String]-mlines = (mbreak =<<) . lines-    where-        mbreak :: String -> [String]-        mbreak xs-            | null bs   = [as]-            | otherwise = (as++cs) : filter (not . null) (mbreak ds)-            where-                (as,bs) = splitAt (w-n) xs-                breaks  = filter (not . isAlphaNum . last . fst) $ drop 1 $-                                  take n $ zip (inits bs) (tails bs)-                (cs,ds) = last $ (take n bs, drop n bs): breaks-                w = textwidth-                n = 10

@@ -10,11 +10,6 @@     , ModuleT     , newModule     -    , getModuleName-    , bindModule0-    , bindModule1-    , bindModule2-         , LB     , MonadLB(..)     , lim80

@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, FlexibleContexts #-} -- | Lambdabot base module. Controls message send and receive module Lambdabot.Plugin.Core.Base (basePlugin) where @@ -8,6 +8,7 @@ import Lambdabot.IRC import Lambdabot.Logging import Lambdabot.Message+import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Nick import Lambdabot.Plugin@@ -16,7 +17,9 @@ import Control.Applicative import Control.Exception.Lifted as E import Control.Monad+import Control.Monad.Reader import Control.Monad.State+import Data.Char import Data.List import Data.List.Split import qualified Data.Map as M@@ -30,46 +33,50 @@ basePlugin = newModule     { moduleDefState = return $ mkGlobalPrivate 20 ()     , moduleInit = do-             ircSignalConnect "PING"    doPING-             bindModule1 doNOTICE >>= ircSignalConnect "NOTICE"-             ircSignalConnect "PART"    doPART-             bindModule1 doKICK   >>= ircSignalConnect "KICK"-             ircSignalConnect "JOIN"    doJOIN-             ircSignalConnect "NICK"    doNICK-             ircSignalConnect "MODE"    doMODE-             ircSignalConnect "TOPIC"   doTOPIC-             ircSignalConnect "QUIT"    doQUIT-             bindModule1 doPRIVMSG >>= ircSignalConnect "PRIVMSG"-             ircSignalConnect "001"     doRPL_WELCOME--          {- ircSignalConnect "002"     doRPL_YOURHOST-             ircSignalConnect "003"     doRPL_CREATED-             ircSignalConnect "004"     doRPL_MYINFO -}--             ircSignalConnect "005"     doRPL_BOUNCE--          {- ircSignalConnect "250"     doRPL_STATSCONN-             ircSignalConnect "251"     doRPL_LUSERCLIENT-             ircSignalConnect "252"     doRPL_LUSEROP-             ircSignalConnect "253"     doRPL_LUSERUNKNOWN-             ircSignalConnect "254"     doRPL_LUSERCHANNELS-             ircSignalConnect "255"     doRPL_LUSERME-             ircSignalConnect "265"     doRPL_LOCALUSERS-             ircSignalConnect "266"     doRPL_GLOBALUSERS -}--             ircSignalConnect "332"     doRPL_TOPIC--          {- ircSignalConnect "353"     doRPL_NAMRELY-             ircSignalConnect "366"     doRPL_ENDOFNAMES-             ircSignalConnect "372"     doRPL_MOTD-             ircSignalConnect "375"     doRPL_MOTDSTART-             ircSignalConnect "376"     doRPL_ENDOFMOTD -}+        registerOutputFilter cleanOutput+        registerOutputFilter lineify+        registerOutputFilter cleanOutput+        +        registerCallback "PING"    doPING+        registerCallback "NOTICE"  doNOTICE+        registerCallback "PART"    doPART+        registerCallback "KICK"    doKICK+        registerCallback "JOIN"    doJOIN+        registerCallback "NICK"    doNICK+        registerCallback "MODE"    doMODE+        registerCallback "TOPIC"   doTOPIC+        registerCallback "QUIT"    doQUIT+        registerCallback "PRIVMSG" doPRIVMSG+        registerCallback "001"     doRPL_WELCOME+        +        -- registerCallback "002"     doRPL_YOURHOST+        -- registerCallback "003"     doRPL_CREATED+        -- registerCallback "004"     doRPL_MYINFO+        +        registerCallback "005"     doRPL_BOUNCE+        +        -- registerCallback "250"     doRPL_STATSCONN+        -- registerCallback "251"     doRPL_LUSERCLIENT+        -- registerCallback "252"     doRPL_LUSEROP+        -- registerCallback "253"     doRPL_LUSERUNKNOWN+        -- registerCallback "254"     doRPL_LUSERCHANNELS+        -- registerCallback "255"     doRPL_LUSERME+        -- registerCallback "265"     doRPL_LOCALUSERS+        -- registerCallback "266"     doRPL_GLOBALUSERS+        +        registerCallback "332"     doRPL_TOPIC+        +        -- registerCallback "353"     doRPL_NAMRELY+        -- registerCallback "366"     doRPL_ENDOFNAMES+        -- registerCallback "372"     doRPL_MOTD+        -- registerCallback "375"     doRPL_MOTDSTART+        -- registerCallback "376"     doRPL_ENDOFMOTD     } -doIGNORE :: Callback+doIGNORE :: IrcMessage -> Base () doIGNORE = debugM . show -doPING :: Callback+doPING :: IrcMessage -> Base () doPING = noticeM . showPingMsg     where showPingMsg msg = "PING! <" ++ ircMsgServer msg ++ (':' : ircMsgPrefix msg) ++             "> [" ++ ircMsgCommand msg ++ "] " ++ show (ircMsgParams msg)@@ -85,7 +92,7 @@         body = ircMsgParams msg         isCTCPTimeReply = ":\SOHTIME" `isPrefixOf` (last body) -doJOIN :: Callback+doJOIN :: IrcMessage -> Base () doJOIN msg      | lambdabotName msg /= nick msg = doIGNORE msg     | otherwise                     = do@@ -95,18 +102,20 @@                 aloc    -> aloc             loc = Nick (server msg) (dropWhile (== ':') chan)         -        s <- get-        put (s { ircChannels = M.insert  (mkCN loc) "[currently unknown]" (ircChannels s)}) -- the empty topic causes problems-        send $ getTopic loc -- initialize topic+        -- the empty topic causes problems+        -- TODO: find out what they are and fix them properly+        lb . modify $ \s -> s+            { ircChannels = M.insert  (mkCN loc) "[currently unknown]" (ircChannels s)}+        lb . send $ getTopic loc -- initialize topic    where  -doPART :: Callback+doPART :: IrcMessage -> Base () doPART msg   = when (lambdabotName msg == nick msg) $ do         let body = ircMsgParams msg             loc = Nick (server msg) (head body)-        s <- get-        put (s { ircChannels = M.delete (mkCN loc) (ircChannels s) })+        lb . modify $ \s -> s+            { ircChannels = M.delete (mkCN loc) (ircChannels s) }  doKICK :: IrcMessage -> Base () doKICK msg@@ -118,36 +127,46 @@             lift $ modify $ \s ->                 s { ircChannels = M.delete (mkCN loc) (ircChannels s) } -doNICK :: Callback+doNICK :: IrcMessage -> Base () doNICK msg   = doIGNORE msg -doMODE :: Callback+doMODE :: IrcMessage -> Base () doMODE msg   = doIGNORE msg  -doTOPIC :: Callback-doTOPIC msg-    = do let loc = Nick (server msg) (head (ircMsgParams msg))-         s <- get-         put (s { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ ircMsgParams msg) (ircChannels s)})+doTOPIC :: IrcMessage -> Base ()+doTOPIC msg = lb . modify $ \s -> s+    { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ ircMsgParams msg) (ircChannels s) }+    where loc = Nick (server msg) (head (ircMsgParams msg)) -doRPL_WELCOME :: Callback-doRPL_WELCOME = doIGNORE+doRPL_WELCOME :: IrcMessage -> Base ()+doRPL_WELCOME msg = lb $ do+    modify $ \state' -> +        let persists = if M.findWithDefault True (server msg) (ircPersists state')+                then ircPersists state'+                else M.delete (server msg) $ ircPersists state'+         in state' { ircPersists = persists }+    chans <- gets ircChannels+    forM_ (M.keys chans) $ \chan -> do+        let cn = getCN chan+        when (nTag cn == server msg) $ do+            modify $ \state' -> state' { ircChannels = M.delete chan $ ircChannels state' }+            lb $ send $ joinChannel cn -doQUIT :: Callback+doQUIT :: IrcMessage -> Base () doQUIT msg = doIGNORE msg -doRPL_BOUNCE :: Callback+doRPL_BOUNCE :: IrcMessage -> Base () doRPL_BOUNCE _msg = debugM "BOUNCE!" -doRPL_TOPIC :: Callback+doRPL_TOPIC :: IrcMessage -> Base () doRPL_TOPIC msg -- nearly the same as doTOPIC but has our nick on the front of body     = do let body = ircMsgParams msg              loc = Nick (server msg) (body !! 1)-         s <- get-         put (s { ircChannels = M.insert (mkCN loc) (tail $ last body) (ircChannels s) })+         lb . modify $ \s -> s+            { ircChannels = M.insert (mkCN loc) (tail $ last body) (ircChannels s) }  doPRIVMSG :: IrcMessage -> Base () doPRIVMSG msg = do@@ -155,7 +174,7 @@     commands    <- getConfig commandPrefixes          if ignored-        then lift $ doIGNORE msg+        then doIGNORE msg         else mapM_ (doPRIVMSG' commands (lambdabotName msg) msg) targets     where         alltargets = head (ircMsgParams msg)@@ -198,7 +217,7 @@ doPublicMsg :: [String] -> IrcMessage -> Nick -> String -> String -> Base () doPublicMsg commands msg target s r     | commands `arePrefixesOf` s  = doMsg msg (tail s) r target-    | otherwise                   = (lift $ doIGNORE msg)+    | otherwise                   = doIGNORE msg  -- -- normal commands.@@ -227,8 +246,8 @@ docmd msg towhere rest cmd' = withPS towhere $ \_ _ -> do     withCommand cmd'   -- Important.         (ircPrivmsg towhere "Unknown command, try @list")-        (\_ theCmd -> do-            name'   <- getModuleName+        (\theCmd -> do+            name'   <- asks moduleName              hasPrivs <- lb (checkPrivs msg)             @@ -261,11 +280,16 @@ -- them bubble back up to the mainloop -- doContextualMsg :: IrcMessage -> Nick -> Nick -> [Char] -> Base ()-doContextualMsg msg target towhere r = lift $ withAllModules $ \m -> do-    name' <- getModuleName-    E.catch-        (lift . mapM_ (ircPrivmsg towhere) =<< execCmd (contextual m r) msg target "contextual") -        (\e@SomeException{} -> debugM . (name' ++) . (" module failed in contextual handler: " ++) $ show e)+doContextualMsg msg target towhere r = lb (withAllModules (withHandler invokeContextual))+    where+        withHandler x = E.catch x $ \e@SomeException{} -> do+            mName   <- asks moduleName+            debugM ("Module " ++ show mName ++ " failed in contextual handler: " ++ show e)+        +        invokeContextual = do+            m       <- asks theModule+            reply   <- execCmd (contextual m r) msg target "contextual"+            lb $ mapM_ (ircPrivmsg towhere) reply  ------------------------------------------------------------------------ @@ -286,56 +310,85 @@ --  {--doRPL_YOURHOST :: Callback+doRPL_YOURHOST :: IrcMessage -> LB () doRPL_YOURHOST _msg = return () -doRPL_CREATED :: Callback+doRPL_CREATED :: IrcMessage -> LB () doRPL_CREATED _msg = return () -doRPL_MYINFO :: Callback+doRPL_MYINFO :: IrcMessage -> LB () doRPL_MYINFO _msg = return () -doRPL_STATSCONN :: Callback+doRPL_STATSCONN :: IrcMessage -> LB () doRPL_STATSCONN _msg = return () -doRPL_LUSERCLIENT :: Callback+doRPL_LUSERCLIENT :: IrcMessage -> LB () doRPL_LUSERCLIENT _msg = return () -doRPL_LUSEROP :: Callback+doRPL_LUSEROP :: IrcMessage -> LB () doRPL_LUSEROP _msg = return () -doRPL_LUSERUNKNOWN :: Callback+doRPL_LUSERUNKNOWN :: IrcMessage -> LB () doRPL_LUSERUNKNOWN _msg = return () -doRPL_LUSERCHANNELS :: Callback+doRPL_LUSERCHANNELS :: IrcMessage -> LB () doRPL_LUSERCHANNELS _msg = return () -doRPL_LUSERME :: Callback+doRPL_LUSERME :: IrcMessage -> LB () doRPL_LUSERME _msg = return () -doRPL_LOCALUSERS :: Callback+doRPL_LOCALUSERS :: IrcMessage -> LB () doRPL_LOCALUSERS _msg = return () -doRPL_GLOBALUSERS :: Callback+doRPL_GLOBALUSERS :: IrcMessage -> LB () doRPL_GLOBALUSERS _msg = return () -doUNKNOWN :: Callback+doUNKNOWN :: IrcMessage -> Base () doUNKNOWN msg     = debugM $ "UNKNOWN> <" ++ msgPrefix msg ++       "> [" ++ msgCommand msg ++ "] " ++ show (body msg) -doRPL_NAMREPLY :: Callback+doRPL_NAMREPLY :: IrcMessage -> LB () doRPL_NAMREPLY _msg = return () -doRPL_ENDOFNAMES :: Callback+doRPL_ENDOFNAMES :: IrcMessage -> LB () doRPL_ENDOFNAMES _msg = return () -doRPL_MOTD :: Callback+doRPL_MOTD :: IrcMessage -> LB () doRPL_MOTD _msg = return () -doRPL_MOTDSTART :: Callback+doRPL_MOTDSTART :: IrcMessage -> LB () doRPL_MOTDSTART _msg = return () -doRPL_ENDOFMOTD :: Callback+doRPL_ENDOFMOTD :: IrcMessage -> LB () doRPL_ENDOFMOTD _msg = return () -}++-- Initial output filters++-- | For now, this just checks for duplicate empty lines.+cleanOutput :: Monad m => a -> [String] -> m [String]+cleanOutput _ msg = return $ remDups True msg'+    where+        remDups True  ([]:xs) =    remDups True xs+        remDups False ([]:xs) = []:remDups True xs+        remDups _     (x: xs) = x: remDups False xs+        remDups _     []      = []+        msg' = map (dropFromEnd isSpace) msg++-- | wrap long lines.+lineify :: MonadConfig m => a -> [String] -> m [String]+lineify _ msg = do+    w <- getConfig textWidth+    return (lines (unlines msg) >>= mbreak w)+    where+        -- | break into lines+        mbreak w xs+            | null bs   = [as]+            | otherwise = (as++cs) : filter (not . null) (mbreak w ds)+            where+                (as,bs) = splitAt (w-n) xs+                breaks  = filter (not . isAlphaNum . last . fst) $ drop 1 $+                                  take n $ zip (inits bs) (tails bs)+                (cs,ds) = last $ (take n bs, drop n bs): breaks+                n = 10

@@ -7,12 +7,13 @@ module Lambdabot.Plugin.Core.Compose (composePlugin) where  import Lambdabot.Command+import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Plugin  import Control.Arrow (first) import Control.Monad-import Control.Monad.Trans+import Control.Monad.Reader import Data.Char import Data.List import Data.List.Split@@ -64,11 +65,11 @@ lookupP cmd = withMsg $ \a -> do     b <- getTarget     lb $ withCommand cmd-        (error $ "Unknown command: " ++ show cmd)-        (\_m theCmd -> do-            when (privileged theCmd) $ error "Privileged commands cannot be composed"-            bindModule1 (runCommand theCmd a b cmd))-+        (fail $ "Unknown command: " ++ show cmd)+        (\theCmd -> do+            when (privileged theCmd) $ fail "Privileged commands cannot be composed"+            mTag <- asks moduleID+            return (inModuleWithID mTag (return []) . runCommand theCmd a b cmd))  ------------------------------------------------------------------------ 

@@ -3,10 +3,13 @@  import Lambdabot.Command import Lambdabot.Message (Message)+import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util +import Control.Monad.Reader+ helpPlugin :: Module () helpPlugin = newModule     { moduleCmds = return@@ -32,16 +35,16 @@ doHelp msg tgt [] = doHelp msg tgt "help" doHelp msg tgt rest =     withCommand arg                  -- see if it is a command-        (withModule arg              -- else maybe it's a module name+        (inModuleNamed arg           -- else maybe it's a module name             (doHelp msg tgt "help")             -- else give up-            (\md -> do -- its a module-                cmds <- moduleCmds md+            (do -- its a module+                cmds <- moduleCmds =<< asks theModule                 let ss = cmds >>= cmdNames                 let s | null ss   = arg ++ " is a module."                       | otherwise = arg ++ " provides: " ++ showClean ss                 return [s]))          -- so it's a valid command, try to find its help-        (\_md theCmd -> moduleHelp theCmd msg tgt arg)+        (\theCmd -> moduleHelp theCmd msg tgt arg)      where (arg:_) = words rest

@@ -1,8 +1,9 @@ -- | Support for more(1) buffering module Lambdabot.Plugin.Core.More (morePlugin) where -import Lambdabot.Plugin import Lambdabot.Bot+import Lambdabot.Monad+import Lambdabot.Plugin  import Control.Monad.Trans @@ -13,9 +14,10 @@ morePlugin :: Module (GlobalPrivate () [String]) morePlugin = newModule     { moduleDefState = return $ mkGlobalPrivate 20 ()-    , moduleInit-        =   bindModule2 moreFilter-        >>= ircInstallOutputFilter+    , moduleInit = registerOutputFilter moreFilter+        -- TODO: improve output filter system...+        -- currently, @more output will bypass any filters in the+        -- chain after 'moreFilter'      , moduleCmds = return         [ (command "more")

@@ -12,12 +12,15 @@ import Control.Concurrent.Lifted import Control.Exception.Lifted ( evaluate, finally ) import Control.Monad( void, when )-import Control.Monad.State( gets )+import Control.Monad.State( gets, modify ) import Control.Monad.Trans( lift, liftIO ) import Data.Char+import qualified Data.Map as M+import qualified Data.Set as S import System.Console.Haskeline (InputT, Settings(..), runInputT, defaultSettings, getInputLine) import System.IO import System.Timeout.Lifted+import Codec.Binary.UTF8.String  -- We need to track the number of active sourcings so that we can -- unregister the server (-> allow the bot to quit) when it is not@@ -29,6 +32,10 @@ offlineRCPlugin = newModule     { moduleDefState = return 0     , moduleInit = do+        lb . modify $ \s -> s+            { ircPrivilegedUsers = S.insert (Nick "offlinerc" "null") (ircPrivilegedUsers s)+            }+                 void . fork $ do             waitForInit             lockRC@@ -66,19 +73,21 @@             '>':xs -> cmdPrefix ++ "run " ++ xs             '!':xs -> xs             _      -> cmdPrefix ++ dropWhile (== ' ') msg-    lift . (>> return ()) . timeout (15 * 1000 * 1000) . received $+    -- note that `msg'` is unicode, but lambdabot wants utf-8 lists of bytes+    lb . void . timeout (15 * 1000 * 1000) . received $               IrcMessage { ircMsgServer = "offlinerc"                          , ircMsgLBName = "offline"                          , ircMsgPrefix = "null!n=user@null"                          , ircMsgCommand = "PRIVMSG"-                         , ircMsgParams = ["offline", ":" ++ msg' ] }+                         , ircMsgParams = ["offline", ":" ++ encodeString msg' ] } -handleMsg :: IrcMessage -> LB ()+handleMsg :: IrcMessage -> OfflineRC () handleMsg msg = liftIO $ do     let str = case (tail . ircMsgParams) msg of             []    -> []             (x:_) -> tail x-    hPutStrLn stdout str+    -- str contains utf-8 list of bytes; convert to unicode+    hPutStrLn stdout (decodeString str)     hFlush stdout  replLoop :: InputT OfflineRC ()@@ -90,16 +99,19 @@             let s' = dropWhile isSpace x             when (not $ null s') $ do                 lift $ feed s'-            continue <- lift (lift (gets ircStayConnected))+            continue <- lift $ lift $ gets (M.member "offlinerc" . ircPersists)             when continue replLoop  lockRC :: OfflineRC () lockRC = do     withMS $ \ cur writ -> do-        when (cur == 0) (addServer "offlinerc" handleMsg)+        when (cur == 0) $ do+            registerServer "offlinerc" handleMsg+            lift $ modify $ \state' ->+                state' { ircPersists = M.insert "offlinerc" True $ ircPersists state' }         writ (cur + 1)  unlockRC :: OfflineRC () unlockRC = withMS $ \ cur writ -> do-    when (cur == 1) $ lb $ remServer "offlinerc"+    when (cur == 1) $ unregisterServer "offlinerc"     writ (cur - 1)

@@ -5,12 +5,13 @@ import Lambdabot.Compat.AltTime import Lambdabot.Compat.FreenodeNick import Lambdabot.IRC+import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util +import Control.Monad.Reader import Control.Monad.State (gets, modify)-import Control.Monad.Trans import qualified Data.Map as M import qualified Data.Set as S @@ -38,7 +39,7 @@             }         , (command "listmodules")             { help = say "listmodules. Show available plugins"-            , process = \_ -> listKeys ircModules+            , process = \_ -> say . showClean =<< lb listModules             }         , (command "listservers")             { help = say "listservers. Show current servers"@@ -63,7 +64,7 @@         , (command "listall")             { privileged = True             , help = say "list all commands"-            , process = \_ -> mapM_ doList . M.keys =<< lb (gets ircModules)+            , process = \_ -> mapM_ doList =<< lb listModules             }         , (command "join")             { privileged = True@@ -103,10 +104,18 @@                 server <- getServer                 lb (ircQuit server $ if null rest then "requested" else rest)             }+        , (command "disconnect")+            { privileged = True+            , help = say "disconnect <server> [msg], disconnect from a server with msg"+            , process = \rest -> do+                let (server, msg) = splitFirstWord rest+                lb (ircQuit server $ if null msg then "requested" else msg)+            }         , (command "flush")             { privileged = True             , help = say "flush. flush state to disk"-            , process = \_ -> lb flushModuleState+            , process = \_ -> lb (withAllModules writeGlobalState)+                             }         , (command "admin")             { privileged = True@@ -123,7 +132,7 @@             , help = say "reconnect to server"             , process = \rest -> do                 server <- getServer-                lb (ircReconnect server $ if null rest then "requested" else rest)+                lb (ircReconnect server $ if null rest then "reconnect requested" else rest)             }         ]     }@@ -174,17 +183,16 @@     lb . modify $ edit f nck  listModule :: String -> LB String-listModule s = withModule s fromCommand printProvides+listModule s = inModuleNamed s fromCommand printProvides   where     fromCommand = withCommand s-        (return $ "No module \""++s++"\" loaded") (const . printProvides)+        (return $ "No module \""++s++"\" loaded") (const printProvides) -    -- ghc now needs a type annotation here-    printProvides :: Module st -> ModuleT st LB String-    printProvides m = do-        cmds <- moduleCmds m+    printProvides :: ModuleT st LB String+    printProvides = do+        cmds <- moduleCmds =<< asks theModule         let cmds' = filter (not . privileged) cmds-        name' <- getModuleName+        name' <- asks moduleName         return . concat $ if null cmds'                           then [name', " has no visible commands"]                           else [name', " provides: ", showClean (concatMap cmdNames cmds')]

@@ -22,7 +22,6 @@     , writeGS          -- ** Handling global state-    , flushModuleState     , readGlobalState     , writeGlobalState   ) where@@ -38,7 +37,7 @@  import Control.Concurrent.Lifted import Control.Exception.Lifted as E-import Control.Monad.Trans+import Control.Monad.Reader import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as P import Data.IORef.Lifted@@ -69,7 +68,7 @@ instance MonadLB m => MonadLBState (ModuleT st m) where     type LBState (ModuleT st m) = st     withMS f = do-        ref <- getRef+        ref <- asks moduleState         withMWriter ref f  instance MonadLBState m => MonadLBState (Cmd m) where@@ -173,22 +172,21 @@ -- Handling global state -- --- | flush state of modules-flushModuleState :: LB ()-flushModuleState = withAllModules (\m -> getModuleName >>= writeGlobalState m)- -- | Peristence: write the global state out-writeGlobalState :: Module st -> String -> ModuleT st LB ()-writeGlobalState module' name = do-    debugM ("saving state for module " ++ show name)-    case moduleSerialize module' of+writeGlobalState :: ModuleT st LB ()+writeGlobalState = do+    m     <- asks theModule+    mName <- asks moduleName+    +    debugM ("saving state for module " ++ show mName)+    case moduleSerialize m of         Nothing  -> return ()         Just ser -> do             state' <- readMS             case serialize ser state' of                 Nothing  -> return ()   -- do not write any state                 Just out -> do-                    stateFile <- lb (findLBFileForWriting name)+                    stateFile <- lb (findLBFileForWriting mName)                     io (P.writeFile stateFile out)  -- | Read it in