lambdabot-core (empty) → 5.0

raw patch · 37 files changed

+3906/−0 lines, 37 filesdep +HTTPdep +SafeSemaphoredep +basesetup-changed

Dependencies added: HTTP, SafeSemaphore, base, binary, bytestring, containers, dependent-map, dependent-sum, dependent-sum-template, directory, edit-distance, filepath, haskeline, hslogger, lifted-base, monad-control, mtl, network, parsec, random, random-fu, random-source, regex-tdfa, split, template-haskell, time, transformers, transformers-base, unix, utf8-string, zlib

Files

• AUTHORS.md +158/−0
• COMMENTARY.md +88/−0
• LICENSE +22/−0
• README.md +99/−0
• Setup.hs +3/−0
• lambdabot-core.cabal +102/−0
• src/Lambdabot/Bot.hs +195/−0
• src/Lambdabot/ChanName.hs +20/−0
• src/Lambdabot/Command.hs +136/−0
• src/Lambdabot/Compat/AltTime.hs +192/−0
• src/Lambdabot/Compat/FreenodeNick.hs +38/−0
• src/Lambdabot/Compat/PackedNick.hs +29/−0
• src/Lambdabot/Config.hs +119/−0
• src/Lambdabot/Config/Core.hs +50/−0
• src/Lambdabot/File.hs +122/−0
• src/Lambdabot/IRC.hs +119/−0
• src/Lambdabot/Logging.hs +67/−0
• src/Lambdabot/Main.hs +108/−0
• src/Lambdabot/Message.hs +25/−0
• src/Lambdabot/Module.hs +135/−0
• src/Lambdabot/Monad.hs +283/−0
• src/Lambdabot/Monad.hs-boot +16/−0
• src/Lambdabot/Nick.hs +46/−0
• src/Lambdabot/OutputFilter.hs +48/−0
• src/Lambdabot/Plugin.hs +69/−0
• src/Lambdabot/Plugin/Core.hs +24/−0
• src/Lambdabot/Plugin/Core/Base.hs +341/−0
• src/Lambdabot/Plugin/Core/Compose.hs +159/−0
• src/Lambdabot/Plugin/Core/Help.hs +47/−0
• src/Lambdabot/Plugin/Core/More.hs +46/−0
• src/Lambdabot/Plugin/Core/OfflineRC.hs +105/−0
• src/Lambdabot/Plugin/Core/System.hs +190/−0
• src/Lambdabot/Plugin/Core/Version.hs +23/−0
• src/Lambdabot/State.hs +211/−0
• src/Lambdabot/Util.hs +185/−0
• src/Lambdabot/Util/Serial.hs +155/−0
• src/Lambdabot/Util/Signals.hs +131/−0

@@ -0,0 +1,158 @@+AUTHORS+========++The following people have made contributions to the Lambdabot project.  There are probably others as well.++* Andrew J. Bromage <ajb@spamcop.net> aka Pseudonym on #haskell++  - the 'bot itself+  - @free++* Shae M. Erisson <shae@ScannedInAvian.com> aka shapr on #haskell++  - FactModule+  - FortuneModule+  - StateModule+  - SystemModule++* Taylor Campbell <riastradh@users.sourceforge.net> aka Riastradh on #haskell++  - KarmaModule++* Derek Elkins <ddarius@users.sourceforge.net> aka Darius on #haskell++  - EvalModule++* Sven M. Hallberg <pesco@haquebright.de> aka pesco on #haskell++  - TopicModule++* Tom Moertel <tom@moertel.com> aka tmoertel on #haskell++  - DictModule++* Mats-Ola Persson <polli@users.sourceforge.net> aka polli on #haskell++  - rewrite of the plugin system++* Ganesh Sittampalam <ganesh@earth.li> aka Heffalump on #haskell++  - Various restructuring to improve bot robustness+  - Dynamic module loading++* Don Stewart <dons@galois.com> aka dons on #haskell++  - New build system, 6.4 port+  - dynamic module loading with hs-plugins+  - Simplfied module interface+  - @babel, @plugs, @version, @code, @spell, @djinn, @unlambda, @hylo, @freshname, @ft, @src+  - Offline mode+  - General hacking+  - Cabalised build system+  - GHCi build system++* Jesper Louis Andersen <jlouis@mongers.org> aka jlouis on #haskell++  - Code/Documentation cleanups++* Thomas Jäger <TheHunter2000@web.de> aka TheHunter on #haskell++  - PlModule+  - General hacking/refactoring.++* Stefan Wehr <mail@stefanwehr.de> aka stefanw on #haskell++  - DarcsPatchWatch module++* Simon Winwood++  - Babel module+  - Log module++* Mark Wotton (blackdog)++  - Vixen++* Paolo Martini (xerox)++  - @hoogle, @botsnack, work on @karma++* Vaclav Haisman++  - Tweaks to textual interface++* Joel Koerwer++  - google calculator++* Josef Svenningsson++  - @elite++* Ketil Malde++  - Improved @seen++* Echo Nolan++  - grammar++* Samuel Bronson++  - Improved search code. @google++* Peter Davis++  - @moos ++++* andres@cs.uu.nl++  - line breaks, topics,++* Kenneth Hoste++  - @vote++* softpro@gmx.net++  - @pretty++* tatd2@kent.ac.uk++  - actions / slapping++* rizzix <rizzixs@fastmail.fm>++  - Minor fixed and workarounds+  - @gsite++* David House <dmhouse@gmail.com>++  - Instances, Tell.++* Pete Kazmier <pete-lambdabot@kazmier.com>++  - Url page title chaser+  - Contextual messages++* Stefan O'Rear <stefanor@cox.net> aka sorear on #haskell++  - @nazi-on, @nazi-off, @activity+  - Non-flat nick namespace+  - Separation of servers out of base++* Spencer Janssen <sjanssen@cse.unl.edu> aka sjanssen on #haskell++  - @undo, @redo++* Gwern Branwen <gwern0@gmail.com> aka gwern on #haskell++  - Packaging of unlambda and brainfuck++* James Cook <mokus@deepbondi.net> aka mokus on #haskell++  - Stuff.  I dedicate all my contributions to the public domain.++* Jan Stolarek <jan.stolarek@p.lodz.pl> aka killy9999 on #haskell++  - More stuff, mostly code cleanup.

@@ -0,0 +1,88 @@+COMMENTARY ON LAMBDABOT+=======================++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:++- Messages.  An IRC-centric representation of a chat message.  Includes information about the sender and addressee, as well as the "kind" (PRIVMSG, CTCP PING, etc.) and the text of the message.++- Servers.  A "server" is a simplified model of the kind of user interaction provided by an IRC server.  It accepts messages from a user, feeds them into the lambdabot core, and forwards messages from the core back to users.  There are currently 2 types of server defined - IRC connections and the "OfflineRC" REPL.++- Plugins (sometimes called "modules").  A plugin is described by a record of type `Module st`, where `st` is the type of the plugin's internal state.  The plugin is able to define functions to initialize, serialize, deserialize, and clean-up that state, and may additionally define "commands" and "contextual" behaviors, both defined below.++- Commands.  A plugin defines zero or more commands, which are keywords users can use in chat (prefixed by a sigil, '@' or '?' by default) to interact with the plugin.++- Contextual behaviors.  Every time a chat message is received that isn't processed as a command, plugins are offered a chance to process and respond to it.++- 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:++- Safe Haskell.  The "Safe Haskell" GHC extension tracks usage of features such as `unsafePerformIO` and the FFI (among others) which subvert the type system.  The full details are available in the GHC documentation.  By default, lambdabot only trusts a small set of common libraries.  The user may override this set on the command-line.++- Sandboxing and resource limits.  The `mueval` program implements timeouts and resource limits to keep user-provided code from hogging the system.  Lambdabot uses `mueval` to run code++Monads+------++Lambdabot uses a few different monads/transformers to encapsulate state and provide additional context for various subsystems.  They are:++- LB.  The `LB` monad is the base environment for all operations that depend on or affect the core system.  These are mainly things like loading or unloading plugins, registering servers or callbacks, etc.++- ModuleT.  The `ModuleT` monad transformer is used for all code provided by a plugin.  It provides access to the plugin's name and current state.++- CmdT. The `CmdT` monad transformer is used for implementing commands within modules, and provides access to information such as the name the command was invoked as, the message that triggered the command, and information about that message such as the sender and addressee.+++Configuration system+--------------------++Code in all the monads above has access to the configuration system, which is a typed key-value store that is initialized at startup and thenceforth immutable.  The `getConfig` function provides access to the value associated with any config key.  New keys can be defined using the `config` Template Haskell function - see `Lambdabot.Config` for the interface and `Lambdabot.Config.Core` for some examples.++To set a config value, add a binding to the configuration parameter of `lambdabotMain`.  For example:++    module MyBot where+    +    import Lambdabot.Main+    {- import your plugins here -}+    +    main = lambdabotMain myPlugins +        [ configKey  :=> value+        , anotherKey :=> anotherValue+        ]++Any key not listed will be assigned the default value specified in its original declaration.++Source layout and module heirarchy+----------------------------------++- src/+-- Lambdabot.Compat.*++Modules supporting backward-compatibility with older versions of lambdabot (mostly functions to read old serialization formats)++-- 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.++-- Lambdabot.Plugin.*++As the name suggests, all lambdabot plugins are defined in modules under this namespace.++-- 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.++-- Lambdabot, Lambdabot.*++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.+

@@ -0,0 +1,22 @@+Copyright (c) 2003 Andrew J. Bromage+Portions Copyright (c) 2003 Shae Erisson, Sven M. Hallberg, Taylor Campbell+Portions Copyright (c) 2003-2006 Members of the AUTHORS file++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject+to the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY+KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE+WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,99 @@+lambdabot ![Build Status](https://travis-ci.org/mokus0/lambdabot.png)+===============++Lambdabot is an IRC bot written over several years by those on freenode's #haskell [IRC channel](http://www.haskell.org/haskellwiki/IRC_channel). It also operates in an offline mode as a Haskell development tool, and embedded as an extension to ghci.++PREREQUISITES+-------------++You'll need GHC >= 7.4.  cabal-install is highly recommended.++External executable dependencies:++- `aspell` for the "spell" spell-checking plugin.  This is not a Haskell program, but is available in pretty much all Linux, BSD and Mac OS package managers.+- `bf` for interpreting brainfuck programs.  This is a provided by the "brainfuck" package on Hackage.+- `djinn` for the "djinn" plugin, which tries to find Haskell functions matching arbitrary types.  Available on Hackage.+- `ghc` and `mueval` for the "eval" plugin, which evaluates Haskell expressions in chat (when prefixed with "> "; e.g. `> 1 + 1`).  GHC is available from haskell.org (the Haskell Platform is recommended).  Mueval is available on Hackage.+- `hoogle` for the "hoogle" plugin, which provides a command for searching Haskell APIs.  Available from Hackage.+- GNU talk-filters (optional) for the "filters" plugin.  Available via most package managers, I believe.+- `unlambda` for executing unlambda programs.  Available on Hackage.++Some of these dependencies (those with corresponding hackage libraries) will be installed by cabal, but not all of them will.  In all cases, cabal does not actually track the executables so if they have previously been installed and deleted on your system (without unregistering the matching library), you will have to manually reinstall them.++RUNNING+=======++Lambdabot can be installed system-wide or per user, but currently the lambdabot binary makes certain assumptions about what directory it is being run in & where files it needs can be found. (This is the subject of future work.)++Your best bet is currently to read the code and see what it does, and decide for yourself whether that's what you want.++OFFLINE MODE+------------++    lambdabot++CONNECTING+----------++    lambdabot -e 'rc online.rc'++SSL MODE (with stunnel)+-----------------------++append the following to your stunnel.conf:++    client = yes+    [irc]+    accept = 6667+    connect = ssl-irc-server.org:6667++and edit online.rc to use localhost as server, then restart the stunnel+server and restart lambdabot with:++    ./lambdabot -e 'rc online.rc'++SCRIPTS+-------++    The scripts directory contains some shell scripts for Vim editor support+    They are self-explanatory++CONFIGURING+===========++Lambdabot uses an extensible configuration system which allows plugins to define their own configuration variables.  The lambdabot core system defines several, listed in the module `Lambdabot.Config.Core`.  The default `lambdabot` executable provides a command-line interface to set some of the most common ones, but currently the only way to set others is to define your own executable (which you must currently do anyway to change the default set of modules).++When doing so, configuration is passed in to the `lambdabotMain` function as a list of bindings.  Configuration variables are bound using the `:=>` operator (actually the data constructor of the `DSum` type), for example:++    ghcBinary :=> "ghc-7.4.2"++So a typical custom lambdabot executable might look something like:++    module MyBot where+    +    import Lambdabot.Main+    {- import your plugins here -}+    +    main = lambdabotMain myPlugins +        [ configKey  :=> value+        , anotherKey :=> anotherValue+        ]++BUGS+====++Bug reports, patches, new modules etc., open issues on GitHub or contact:++        James Cook <mokus@deepbondi.net>+        aka mokus on #haskell++REPOSITORY+==========++    git clone https://github.com/mokus0/lambdabot++CONTRIBUTING+============++Send pull requests to mokus0 on github. Add yourself to the AUTHORS+file if you haven't already.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks

@@ -0,0 +1,102 @@+name:                   lambdabot-core+version:                5.0++license:                GPL+license-file:           LICENSE++author:                 Don Stewart+maintainer:             James Cook <mokus@deepbondi.net>++category:               Development, Web+synopsis:               Lambdabot core functionality+description:            Lambdabot is an IRC bot written over several years by+                        those on the #haskell IRC channel.+                        .+                        Manage plugins, network connections, configurations+                        and much more.++homepage:               http://haskell.org/haskellwiki/Lambdabot++build-type:             Simple+cabal-version:          >= 1.8+tested-with:            GHC == 7.6.3, GHC == 7.8.3++extra-source-files:     AUTHORS.md+                        COMMENTARY.md+                        README.md++source-repository head+  type:                 git+  location:             https://github.com/lambdabot/lambdabot.git++library+  hs-source-dirs:       src+  ghc-options:          -Wall+                        -funbox-strict-fields++  exposed-modules:      Lambdabot.Bot+                        Lambdabot.ChanName+                        Lambdabot.Command+                        Lambdabot.Compat.AltTime+                        Lambdabot.Compat.FreenodeNick+                        Lambdabot.Compat.PackedNick+                        Lambdabot.Config+                        Lambdabot.File+                        Lambdabot.IRC+                        Lambdabot.Logging+                        Lambdabot.Main+                        Lambdabot.Message+                        Lambdabot.Module+                        Lambdabot.Monad+                        Lambdabot.Nick+                        Lambdabot.OutputFilter+                        Lambdabot.Plugin+                        Lambdabot.Plugin.Core+                        Lambdabot.State+                        Lambdabot.Util++  other-modules:        Paths_lambdabot_core+                        Lambdabot.Config.Core+                        Lambdabot.Plugin.Core.Base+                        Lambdabot.Plugin.Core.Compose+                        Lambdabot.Plugin.Core.Help+                        Lambdabot.Plugin.Core.More+                        Lambdabot.Plugin.Core.OfflineRC+                        Lambdabot.Plugin.Core.System+                        Lambdabot.Plugin.Core.Version+                        Lambdabot.Util.Serial+                        Lambdabot.Util.Signals++  build-depends:        base                    >= 4.4 && < 5,+                        binary                  >= 0.5,+                        bytestring              >= 0.9,+                        containers              >= 0.4,+                        dependent-map           == 0.1.*,+                        dependent-sum           == 0.2.*,+                        dependent-sum-template  >= 0.0.0.1,+                        directory               >= 1.1,+                        edit-distance           >= 0.2,+                        filepath                >= 1.3,+                        haskeline               >= 0.7,+                        hslogger                >= 1.2.1,+                        HTTP                    >= 4000,+                        lifted-base             >= 0.2,+                        monad-control           >= 0.3 && < 1,+                        mtl                     >= 2,+                        network                 >= 2.3.0.13,+                        time                    >= 1.4,+                        parsec                  >= 3,+                        random                  >= 1,+                        random-fu               >= 0.2,+                        random-source           >= 0.3,+                        regex-tdfa              >= 1.1,+                        SafeSemaphore           >= 0.9,+                        split                   >= 0.2,+                        template-haskell        >= 2.7,+                        transformers            >= 0.2,+                        transformers-base       >= 0.4,+                        utf8-string             >= 0.3,+                        zlib                    >= 0.5++  if !os(windows)+    build-depends:      unix                    >= 2.5

@@ -0,0 +1,195 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+-- | The guts of lambdabot.+--+-- The LB/Lambdabot monad+-- Generic server connection,disconnection+-- The module typeclass, type and operations on modules+module Lambdabot.Bot+    ( ircLoadModule+    , ircUnloadModule+    , ircSignalConnect+    , ircInstallOutputFilter+    , checkPrivs+    , checkIgnore+    +    , ircCodepage+    , ircGetChannels+    , ircQuit+    , ircReconnect+    , ircPrivmsg+    , ircPrivmsg'+    ) where++import Lambdabot.ChanName+import Lambdabot.Command+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.Monad.Error+import Control.Monad.Reader+import Control.Monad.State+import qualified Data.Map as M+import Data.Random.Source+import qualified Data.Set as S++------------------------------------------------------------------------+--+-- | 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'+    +    let modref = ModuleRef  m ref modname+        cmdref = CommandRef m ref modname+    +    mbCmds <- flip runReaderT (ref, modname) . runModuleT $ do+        initResult <- try (moduleInit m)+        case initResult of+            Left e  -> return (Left e)+            Right{} -> try (moduleCmds m)+    +    case mbCmds of+        Left e@SomeException{} -> do+            errorM ("Module " ++ show modname ++ " failed to load.  Exception thrown: " ++ show e)+            +            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)+    +    withModule modname (error "module not loaded") $ \m -> do+        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)+        +        writeGlobalState m modname+    +    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+        }++------------------------------------------------------------------------++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.+checkPrivs :: IrcMessage -> LB Bool+checkPrivs msg = gets (S.member (nick msg) . ircPrivilegedUsers)++-- | Checks if the given user is being ignored.+--   Privileged users can't be ignored.+checkIgnore :: IrcMessage -> LB Bool+checkIgnore msg = liftM2 (&&) (liftM not (checkPrivs msg))+                  (gets (S.member (nick msg) . ircIgnoredUsers))++------------------------------------------------------------------------+-- Some generic server operations++-- Send a CODEPAGE command to set encoding for current session.+-- Some IRC networks don't provide UTF-8 ports, but allow+-- switching it in runtime+ircCodepage :: String -> String -> LB ()+ircCodepage svr cpage = do+    send $ codepage svr cpage++ircGetChannels :: LB [Nick]+ircGetChannels = (map getCN . M.keys) `fmap` gets ircChannels++-- Send a quit message, settle and wait for the server to drop our+-- handle. At which point the main thread gets a closed handle eof+-- exceptoin, we clean up and go home+ircQuit :: String -> String -> LB ()+ircQuit svr msg = do+    modify $ \state' -> state' { ircStayConnected = False }+    send  $ quit svr msg+    liftIO $ threadDelay 1000+    noticeM "Quitting"++ircReconnect :: String -> String -> LB ()+ircReconnect svr msg = do+    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.+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)++-- A raw send version+ircPrivmsg' :: Nick -> String -> LB ()+ircPrivmsg' who ""  = ircPrivmsg' who " "+ircPrivmsg' who msg = send $ privmsg who msg++------------------------------------------------------------------------++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))++ |]

@@ -0,0 +1,20 @@+module Lambdabot.ChanName+    ( ChanName+    , mkCN+    , getCN+    ) where++import Lambdabot.Nick++import Control.Applicative+import Data.Char++newtype ChanName = ChanName Nick -- always lowercase+  deriving (Eq, Ord)++mkCN :: Nick -> ChanName+mkCN = ChanName . liftA2 Nick nTag (map toLower . nName)++getCN :: ChanName -> Nick+getCN (ChanName n) = n+

@@ -0,0 +1,136 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Lambdabot.Command +    ( Command(..)+    , cmdNames+    , command+    , runCommand+    , Cmd+    , execCmd+    , getCmdName+    , withMsg+    , readNick+    , showNick+    , getServer+    , getSender+    , getTarget+    , getLambdabotName+    , say+    ) where++import Lambdabot.Config+import Lambdabot.Logging+import qualified Lambdabot.Message as Msg+import Lambdabot.Nick++import Control.Applicative+import Control.Monad.Base+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Writer++data CmdArgs = forall a. Msg.Message a => CmdArgs+    { _message  :: a+    , target    :: Nick+    , invokedAs :: String+    }++newtype Cmd m a = Cmd { unCmd :: ReaderT CmdArgs (WriterT [String] m) a }+instance Functor f => Functor (Cmd f) where+    fmap f (Cmd x) = Cmd (fmap f x)+instance Applicative f => Applicative (Cmd f) where+    pure = Cmd . pure+    Cmd f <*> Cmd x = Cmd (f <*> x)+instance Monad m => Monad (Cmd m) where+    return = Cmd . return+    Cmd x >>= f = Cmd (x >>= (unCmd . f))+    fail = lift . fail+instance MonadIO m => MonadIO (Cmd m) where+    liftIO = lift . liftIO+instance MonadBase b m => MonadBase b (Cmd m) where+    liftBase = lift . liftBase+instance MonadTrans Cmd where+    lift = Cmd . lift . lift+instance MonadTransControl Cmd where+    newtype StT Cmd a = StCmd {unStCmd :: (a, [String])}+    liftWith f = do+        r <- Cmd ask+        lift $ f $ \t -> liftM StCmd (runWriterT (runReaderT (unCmd t) r))+    restoreT = Cmd . lift . WriterT . liftM unStCmd+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}+instance MonadBaseControl b m => MonadBaseControl b (Cmd m) where+    newtype StM (Cmd m) a = StMCmd {unStMCmd :: ComposeSt Cmd m a}+    liftBaseWith = defaultLiftBaseWith StMCmd+    restoreM     = defaultRestoreM     unStMCmd+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}+instance MonadConfig m => MonadConfig (Cmd m) where+    getConfig = lift . getConfig+instance MonadLogging m => MonadLogging (Cmd m) where+    getCurrentLogger = do+        parent <- lift getCurrentLogger+        self   <- getCmdName+        return (parent ++ ["Command", self])+    logM a b c = lift (logM a b c)++data Command m = Command+    { cmdName       :: String+    , aliases       :: [String]+    , privileged    :: Bool+    , help          :: Cmd m ()+    , process       :: String -> Cmd m ()+    }++cmdNames :: Command m -> [String]+cmdNames c = cmdName c : aliases c++command :: String -> Command Identity+command name = Command+    { cmdName       = name+    , aliases       = []+    , privileged    = False+    , help          = bug "they haven't created any help text!"+    , process       = const (bug "they haven't implemented this command!")+    } where+        bug reason = say $ unwords [ "You should bug the author of the", show name, "command, because", reason]++runCommand :: (Monad m, Msg.Message a) => Command m -> a -> Nick -> String -> String -> m [String]+runCommand cmd msg tgt arg0 args = execCmd (process cmd args) msg tgt arg0++execCmd ::  (Monad m, Msg.Message a) => Cmd m t -> a -> Nick -> String -> m [String]+execCmd cmd msg tgt arg0 = execWriterT (runReaderT (unCmd cmd) (CmdArgs msg tgt arg0))++getTarget :: Monad m => Cmd m Nick+getTarget = Cmd (asks target)++getCmdName :: Monad m => Cmd m String+getCmdName = Cmd (asks invokedAs)++say :: Monad m => String -> Cmd m ()+say [] = return ()+say it = Cmd (tell [it])++withMsg :: Monad m => (forall a. Msg.Message a => a -> Cmd m t) -> Cmd m t+withMsg f = Cmd ask >>= f'+    where f' (CmdArgs msg _ _) = f msg++readNick :: Monad m => String -> Cmd m Nick+readNick nick = withMsg (\msg -> return (parseNick (Msg.server msg) nick))++showNick :: Monad m => Nick -> Cmd m String+showNick nick = withMsg (\msg -> return (fmtNick (Msg.server msg) nick))++getServer :: Monad m => Cmd m String+getServer = withMsg (return . Msg.server)++getSender :: Monad m => Cmd m Nick+getSender = withMsg (return . Msg.nick)++getLambdabotName :: Monad m => Cmd m Nick+getLambdabotName = withMsg (return . Msg.lambdabotName)

@@ -0,0 +1,192 @@+-- | Time compatibility layer+-- (stuff to support old lambdabot state serialization formats)+--+-- TODO: trim this down to just the explicitly serialization-related stuff+module Lambdabot.Compat.AltTime +    ( ClockTime+    , getClockTime+    , diffClockTimes+    , addToClockTime+    , timeDiffPretty+    +    , TimeDiff(..)+    , noTimeDiff+    ) where++import Control.Arrow (first)++import Data.Binary++import Data.List+import Data.Time+import Text.Read hiding (get, lexP, readPrec)+import Text.Read.Lex++-- | Wrapping ClockTime (which doesn't provide a Read instance!) seems+-- easier than talking care of the serialization of UserStatus+-- ourselves.+--+newtype ClockTime = ClockTime UTCTime+    deriving Eq++newtype TimeDiff = TimeDiff NominalDiffTime+    deriving (Eq, Ord)++noTimeDiff :: TimeDiff+noTimeDiff = TimeDiff 0++epoch :: UTCTime+epoch = UTCTime (fromGregorian 1970 1 1) 0++-- convert to/from the format in old-time, so we can serialize things +-- in the same way as older versions of lambdabot.+toOldTime :: ClockTime -> (Integer, Integer)+toOldTime (ClockTime t) = round (diffUTCTime t epoch * 1e12) `divMod` 1000000000000++fromOldTime :: Integer -> Integer -> ClockTime+fromOldTime x y = ClockTime (addUTCTime (fromIntegral x + fromIntegral y * 1e-12) epoch)++instance Show ClockTime where+    showsPrec p = showsPrec p . toOldTime++instance Read ClockTime where+    readsPrec p = map (first (uncurry fromOldTime)) . readsPrec p++instance Show TimeDiff where+    showsPrec p td = showParen (p > 10) $+        ( showString "TimeDiff {tdYear = "+        . showsPrec 11 ye+        . showString ", tdMonth = "+        . showsPrec 11 mo+        . showString ", tdDay = "+        . showsPrec 11 da+        . showString ", tdHour = "+        . showsPrec 11 ho+        . showString ", tdMin = "+        . showsPrec 11 mi+        . showString ", tdSec = "+        . showsPrec 11 se+        . showString ", tdPicosec = "+        . showsPrec 11 ps+        . showString "}")+        where (ye, mo, da, ho, mi, se, ps) = toOldTimeDiff td++instance Read TimeDiff where+    readsPrec = readPrec_to_S $ parens+        (prec 11 (do+            let lexP = lift Text.Read.Lex.lex+                readPrec :: Read a => ReadPrec a+                readPrec = readS_to_Prec readsPrec+            Ident "TimeDiff"    <- lexP+            Punc "{"            <- lexP+            Ident "tdYear"      <- lexP+            Punc "="            <- lexP+            ye                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdMonth"     <- lexP+            Punc "="            <- lexP+            mo                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdDay"       <- lexP+            Punc "="            <- lexP+            da                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdHour"      <- lexP+            Punc "="            <- lexP+            ho                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdMin"       <- lexP+            Punc "="            <- lexP+            mi                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdSec"       <- lexP+            Punc "="            <- lexP+            se                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdPicosec"   <- lexP+            Punc "="            <- lexP+            ps                  <- reset readPrec+            Punc "}"            <- lexP+            return (fromOldTimeDiff ye mo da ho mi se ps)))+    readList = readListDefault+    readListPrec = readListPrecDefault++-- | Retrieve the current clocktime+getClockTime :: IO ClockTime+getClockTime = ClockTime `fmap` getCurrentTime++-- | Difference of two clock times+diffClockTimes :: ClockTime -> ClockTime -> TimeDiff+diffClockTimes (ClockTime ct1) (ClockTime ct2) = TimeDiff (diffUTCTime ct1 ct2)++-- | @'addToClockTime' d t@ adds a time difference @d@ and a -- clock+-- time @t@ to yield a new clock time.+addToClockTime :: TimeDiff -> ClockTime -> ClockTime+addToClockTime (TimeDiff td) (ClockTime ct) = ClockTime (addUTCTime td ct)++-- | Pretty-print a TimeDiff. Both positive and negative Timediffs produce+--   the same output.+--+-- 14d 17h 8m 53s+--+timeDiffPretty :: TimeDiff -> String+timeDiffPretty td = concat . intersperse " " $ filter (not . null)+    [ prettyP ye "y"+    , prettyP mo "m"+    , prettyP da "d"+    , prettyP ho "h"+    , prettyP mi "m"+    , prettyP se "s"+    ]+  where+    prettyP 0 _ = []+    prettyP i s = show i ++ s+    +    (ye, mo, da, ho, mi, se, _) = toOldTimeDiff td++toOldTimeDiff :: TimeDiff -> (Int, Int, Int, Int, Int, Int, Integer)+toOldTimeDiff (TimeDiff td) = (fromInteger ye, fromInteger mo, fromInteger da, fromInteger ho, fromInteger mi, fromInteger se, ps)+    where+        (a,  ps) = round (td * 1e12) `divMod` 1000000000000+        (b,  se) = a `divMod` 60+        (c,  mi) = b `divMod` 60+        (d,  ho) = c `divMod` 24+        (e,  da) = d `divMod` 28+        (ye, mo) = e `divMod` 12++fromOldTimeDiff :: Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff+fromOldTimeDiff ye mo da ho mi se ps =+    TimeDiff+        (1e-12 * fromIntegral (ps +            + 1000000000000 * (toInteger se +                + 60 * (toInteger mi +                    + 60 * (toInteger ho+                        + 24 * (toInteger da+                            + 28 * (toInteger mo+                                + 12 * toInteger ye)))))))++------------------------------------------------------------------------++instance Binary ClockTime where+        put t = put i >> put j+            where (i, j) = toOldTime t+        get = do +            i <- get+            j <- get+            return (fromOldTime i j)++instance Binary TimeDiff where+        put td = do+            put ye; put mo; put da; put ho; put mi; put se; put ps+            where (ye, mo, da, ho, mi, se, ps) = toOldTimeDiff td+        get = do+            ye <- get+            mo <- get+            da <- get+            ho <- get+            mi <- get+            se <- get+            ps <- get+            return (fromOldTimeDiff ye mo da ho mi se ps)++

@@ -0,0 +1,38 @@+-- | Backward-compatibility shim for (de-)serializing 'Nick's+-- using the old 'Read'/'Show' instances which gave freenode+-- special treatment.+module Lambdabot.Compat.FreenodeNick+    ( FreenodeNick(..)+    , freenodeNickMapSerial+    ) where++import Control.Arrow+import qualified Data.Map as M+import Lambdabot.Nick+import Lambdabot.Util.Serial++newtype FreenodeNick = FreenodeNick { getFreenodeNick :: Nick }+    deriving (Eq, Ord)++instance Show FreenodeNick where+    show (FreenodeNick x)+        | nTag x == "freenode" = show $ nName x+        | otherwise            = show $ pckStr x++instance Read FreenodeNick where+    readsPrec prec str = map (first (FreenodeNick . upckStr "freenode")) (readsPrec prec str)++-- Helper functions+upckStr :: String -> String -> Nick+upckStr def str+    | null ac   = Nick def str+    | otherwise = Nick bc (tail ac)+    where (bc, ac) = break (==':') str++pckStr :: Nick -> String+pckStr nck = nTag nck ++ ':' : nName nck++freenodeNickMapSerial :: (Show v, Read v) => Serial (M.Map Nick v)+freenodeNickMapSerial = Serial+    (serialize mapSerial . M.mapKeysMonotonic FreenodeNick)+    (fmap (M.mapKeysMonotonic getFreenodeNick) . deserialize mapSerial)

@@ -0,0 +1,29 @@+module Lambdabot.Compat.PackedNick+    ( PackedNick+    , packNick+    , unpackNick+    ) where++import Lambdabot.Nick+import qualified Data.ByteString.Char8 as BS++-- | The type of nicknames+type PackedNick = BS.ByteString++-- Helper functions+upckStr :: String -> String -> Nick+upckStr def str | null ac   = Nick def str+                | otherwise = Nick bc (tail ac)+    where (bc, ac) = break (==':') str++pckStr :: Nick -> String+pckStr nck = nTag nck ++ ':' : nName nck++-- | Pack a nickname into a ByteString.  Note that the resulting strings are+-- not optimally formatted for human consumtion.+packNick :: Nick -> BS.ByteString+packNick = BS.pack . pckStr++-- | Unpack a nickname packed by 'packNick'.+unpackNick :: BS.ByteString -> Nick+unpackNick = upckStr "freenode" . BS.unpack

@@ -0,0 +1,119 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# 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++import Control.Applicative+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Data.Char+import Data.GADT.Compare+import Data.GADT.Compare.TH+import Data.Maybe+import Data.Typeable+import Language.Haskell.TH++data Config t where Config :: (Typeable1 k, GCompare k) => !(k t) -> t -> (t -> t -> t) -> Config t++cast1 :: (Typeable1 f, Typeable1 g) => f a -> Maybe (g a)+cast1 = fmap runIdentity . gcast1 . Identity++instance GEq Config where+    geq (Config k1 _ _) (Config k2 _ _) = do+        k2' <- cast1 k2+        geq k1 k2'++instance GCompare Config where+    gcompare (Config k1 _ _) (Config k2 _ _) = +        case compare t1 t2 of+            LT -> GLT+            EQ -> fromMaybe typeErr $ do+                k2'  <- cast1 k2+                return (gcompare k1 k2')+            GT -> GGT+        where+            t1 = typeOf1 k1+            t2 = typeOf1 k2+            +            typeErr = error "TypeReps claim to be equal but cast failed"++getConfigDefault :: Config t -> t+getConfigDefault (Config _ def _) = def++mergeConfig :: Config t -> t -> t -> t+mergeConfig (Config _ _ f) = f++class Monad m => MonadConfig m where+    getConfig :: Config a -> m a++instance  MonadConfig m            => MonadConfig (ReaderT r m) where getConfig = lift . getConfig+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 +-- 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.+config :: String -> TypeQ -> ExpQ -> Q [Dec]+config = configWithMerge [| flip const |]++-- |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+-- executable without arguments, they will get a REPL.  Each instance+-- 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+-- operation (in this case, `(++)`).+configWithMerge :: ExpQ -> String -> TypeQ -> ExpQ -> Q [Dec]+configWithMerge mergeQ nameStr tyQ defValQ = do+    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)) []+            ]+    +    concat <$> sequence+        [ return [tyDec]+        , return keyDecs+        , deriveGEq tyDec+        , deriveGCompare tyDec+        ]++mkEqualP :: Type -> Type -> Pred+#if __GLASGOW_HASKELL__ > 708+mkEqualP t1 t2 = EqualityT `AppT` t1 `AppT` t2+#else+mkEqualP = EqualP+#endif

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+module Lambdabot.Config.Core+    ( commandPrefixes+    , disabledCommands+    , editDistanceLimit+    , enableInsults+    , onStartupCmds+    , outputDir+    , uncaughtExceptionHandler+    +    , replaceRootLogger+    , lbRootLoggerPath+    , consoleLogHandle+    , consoleLogLevel+    , consoleLogFormat+    ) where++import Lambdabot.Config+import Lambdabot.Logging++import Control.Exception+import System.IO++-------------------------------------+-- Core configuration variables++config "commandPrefixes"    [t| [String]                |] [| ["@", "?"]    |]+config "disabledCommands"   [t| [String]                |] [| []            |]+config "editDistanceLimit"  [t| Int                     |] [| 3 :: Int      |]+config "enableInsults"      [t| Bool                    |] [| True          |]+configWithMerge [| (++) |] "onStartupCmds" [t| [String] |] [| ["offline"]   |]+config "outputDir"          [t| FilePath                |] [| "State/"      |]++-- basic logging.  for more complex setups, configure directly using System.Log.Logger+config "replaceRootLogger"  [t| Bool                    |] [| True                        |]+config "lbRootLoggerPath"   [t| [String]                |] [| []                          |]+config "consoleLogHandle"   [t| Handle                  |] [| stderr                      |]+config "consoleLogLevel"    [t| Priority                |] [| NOTICE                      |]+config "consoleLogFormat"   [t| String                  |] [| "[$prio] $loggername: $msg" |]++--------------------------------------------+-- Default values with longer definitions++defaultIrcHandler :: SomeException -> IO ()+defaultIrcHandler = errorM . ("Main: caught (and ignoring) "++) . show++config "uncaughtExceptionHandler" [t| SomeException -> IO () |] [| defaultIrcHandler |]

@@ -0,0 +1,122 @@+module Lambdabot.File+    ( findLBFile+    , findOrCreateLBFile+    , outputDir+    ) where++import Lambdabot.Config.Core+import Lambdabot.Monad+import Lambdabot.Util++import Control.Applicative+import Control.Monad+import Paths_lambdabot_core+import System.Directory+import System.FilePath++-- | Constants.+lambdabot :: FilePath+lambdabot = ".lambdabot"++stateDir :: LB FilePath+stateDir = (lambdabot </>) <$> getConfig outputDir++maybeFileExists :: FilePath -> IO (Maybe FilePath)+maybeFileExists path = do+    b <- doesFileExist path+    return $! if b then Just path else Nothing++-- | For a given file, look locally under State/. That is, suppose one is+-- running out of a Lambdabot darcs repository in /home/cale/lambdabot. Then+--+-- > lookLocally "fact" ~> "/home/cale/lambdabot/State/fact"+lookLocally :: FilePath -> LB (Maybe String)+lookLocally file = do+    local <- getConfig outputDir+    io $ maybeFileExists (local </> file)++-- | For a given file, look at the home directory. By default, we stash files in+-- ~/.lambdabot. So, running Lambdabot normally would let us do:+--+-- > lookHome "fact" ~> "/home/cale/lambdabot/State/fact"+--+-- (Note that for convenience we preserve the "State/foo" address pattern.)+lookHome :: FilePath -> LB (Maybe String)+lookHome f = do+    home    <- io getHomeDirectory+    state   <- stateDir+    io (maybeFileExists $ home </> state </> f)++-- | Do ~/.lambdabot & ~/.lambdabot/State exist?+isHome :: LB Bool+isHome = do+    home  <- io getHomeDirectory+    state <- stateDir+    io . fmap and . mapM (doesDirectoryExist . (home </>)) $ [lambdabot, state]++-- | Create ~/.lambdabot and ~/.lambdabot/State+mkdirL :: LB ()+mkdirL = do+    home  <- io getHomeDirectory+    state <- stateDir+    +    io . mapM_ (createDirectory . (home </>)) $ [lambdabot, state]++-- | Ask Cabal for the read-only copy of a file, and copy it into ~/.lambdabot/State.+-- if there isn't a read-only copy, create an empty file.+cpDataToHome :: FilePath -> LB ()+cpDataToHome f = do +    local   <- getConfig outputDir+    state   <- stateDir+    +    rofile  <- io (getDataFileName (local </> f))+    home    <- io getHomeDirectory+    -- cp /.../lambdabot-4.foo/State/foo ~/.lambdabot/State/foo+    +    let outFile = home </> state </> f+    exists  <- io (doesFileExist rofile)+    if exists+        then io (copyFile rofile outFile)+        else io (writeFile outFile "")++-- | Try to find a pre-existing file, searching first in ./State and then in +-- ~/.lambdabot/State+findLBFile :: FilePath -> LB (Maybe String)+findLBFile f = do+    first <- lookLocally f+    case first of+        -- With any luck we can exit quickly+        Just a -> return (Just a)+        -- OK, we didn't get lucky with local, so+        -- hopefully it's in ~/.lambdabot+        Nothing -> lookHome f++-- | Complicated. If a file exists locally, we return that. If a file exists in+-- ~/lambdabot/State, we return that. If neither the file nor ~/lambdabot/State+-- exist, we create the directories and then copy the file into it if a template+-- exists, or create an empty file if it does not.+-- Note that the return type is simple so we can just do a binding and stuff it+-- into the conventional functions easily; unfortunately, this removes+-- error-checking, as an error is now just \"\".+findOrCreateLBFile :: FilePath -> LB String+findOrCreateLBFile f = do+    mbFile <- findLBFile f+    case mbFile of+        Just file   -> return file+        -- Uh oh. We didn't find it locally, nor did we+        -- find it in ~/.lambdabot/State. So now we+        -- need to make ~/.lambdabot/State and copy it in.+        Nothing -> do+            exists <- isHome+            when (not exists) mkdirL+            cpDataToHome f+            -- With the file copied/created,+            -- a second attempt should work.+            g <- lookHome f+            case g of+                Just a -> return a+                Nothing -> do+                    home  <- io getHomeDirectory +                    state <- stateDir+                    fail $ "findOrCreateLBFile: couldn't find file " +                        ++ f ++ " in " ++ home </> state

@@ -0,0 +1,119 @@+--+-- | The IRC module processes the IRC protocol and provides a nice API for sending+--   and recieving IRC messages with an IRC server.+--+module Lambdabot.IRC+    ( IrcMessage(..)+    , joinChannel+    , partChannel+    , getTopic+    , setTopic+    , codepage+    , privmsg+    , quit+    , timeReply+    , pass+    , user+    , setNick+    ) where++import Lambdabot.Message+import Lambdabot.Nick++import Data.Char (chr,isSpace)+import Data.List.Split++import Control.Monad (liftM2)++-- | An IRC message is a server, a prefix, a command and a list of parameters.+data IrcMessage+  = IrcMessage {+        ircMsgServer   :: !String,+        ircMsgLBName   :: !String,+        ircMsgPrefix   :: !String,+        ircMsgCommand  :: !String,+        ircMsgParams   :: ![String]+  }+  deriving (Show)++instance Message IrcMessage where+    nick                = liftM2 Nick ircMsgServer (takeWhile (/= '!') . ircMsgPrefix)+    server              = ircMsgServer+    fullName            = dropWhile (/= '!') . ircMsgPrefix+    channels msg        = +      let cstr = head $ ircMsgParams msg+        in map (Nick (server msg)) $+           map (\(x:xs) -> if x == ':' then xs else x:xs) (splitOn "," cstr)+               -- solves what seems to be an inconsistency in the parser+    lambdabotName msg   = Nick (server msg) (ircMsgLBName msg)++-- | 'mkMessage' creates a new message from a server, a cmd, and a list of parameters.+mkMessage :: String -- ^ Server+          -> String -- ^ Command+          -> [String] -- ^ Parameters+          -> IrcMessage -- ^ Returns: The created message++mkMessage svr cmd params = IrcMessage +    { ircMsgServer = svr+    , ircMsgPrefix = ""+    , ircMsgCommand = cmd+    , ircMsgParams = params+    , ircMsgLBName = "urk!<outputmessage>"+    }++joinChannel :: Nick -> IrcMessage+joinChannel loc     = mkMessage (nTag loc)  "JOIN"  [nName loc]++partChannel :: Nick -> IrcMessage+partChannel loc     = mkMessage (nTag loc)  "PART"  [nName loc]++getTopic :: Nick -> IrcMessage+getTopic chan       = mkMessage (nTag chan) "TOPIC" [nName chan]++setTopic :: Nick -> String -> IrcMessage+setTopic chan topic = mkMessage (nTag chan) "TOPIC" [nName chan, ':' : topic]++-- | 'privmsg' creates a private message to the person designated.+privmsg :: Nick -- ^ Who should recieve the message (nick)+        -> String -- ^ What is the message?+        -> IrcMessage -- ^ Constructed message+privmsg who msg = if action then mk [nName who, ':':(chr 0x1):("ACTION " ++ clean_msg ++ ((chr 0x1):[]))]+                            else mk [nName who, ':' : clean_msg]+    where mk = mkMessage (nTag who) "PRIVMSG"+          cleaned_msg = case filter (/= '\CR') msg of+              str@('@':_) -> ' ':str+              str         -> str+          (clean_msg,action) = case cleaned_msg of+              ('/':'m':'e':r) -> (dropWhile isSpace r,True)+              str             -> (str,False)++-- | 'codepage' creates a server CODEPAGE message. The input string given is the+--   codepage name for current session.+codepage :: String -> String -> IrcMessage+codepage svr codepage = mkMessage svr "CODEPAGE" [' ':codepage]++-- | 'quit' creates a server QUIT message. The input string given is the+--   quit message, given to other parties when leaving the network.+quit :: String -> String -> IrcMessage+quit svr msg = mkMessage svr "QUIT" [':' : msg]++-- | Construct a privmsg from the CTCP TIME notice, to feed up to+-- the @localtime-reply plugin, which then passes the output to+-- the appropriate client.+timeReply :: IrcMessage -> IrcMessage+timeReply msg = msg+    { ircMsgCommand = "PRIVMSG"+    , ircMsgParams  = [head (ircMsgParams msg)+                   ,":@localtime-reply " ++ (nName $ nick msg) ++ ":" +++                      (init $ drop 7 (last (ircMsgParams msg))) ]+    }++user :: String -> String -> String -> String -> IrcMessage+user svr nick_ server_ ircname = mkMessage svr "USER" [nick_, "localhost", server_, ircname]++pass :: String -> String -> IrcMessage+pass svr pwd = mkMessage svr "PASS" [pwd]++setNick :: Nick -> IrcMessage+setNick nick_ = mkMessage (nTag nick_) "NICK" [nName nick_]+

@@ -0,0 +1,67 @@+module Lambdabot.Logging+    ( L.Priority(..)+    , MonadLogging(..)+    , debugM+    , infoM+    , noticeM+    , warningM+    , errorM+    , criticalM+    , alertM+    , emergencyM+    ) where++import Control.Monad+import Data.List+import qualified System.Log.Logger as L++class Monad m => MonadLogging m where+    getCurrentLogger :: m [String]+    logM :: String -> L.Priority -> String -> m ()++instance MonadLogging IO where+    getCurrentLogger = return []+    logM = L.logM++getCurrentLoggerName :: MonadLogging m => m String+getCurrentLoggerName = liftM (intercalate "." . filter (not . null)) getCurrentLogger++debugM :: MonadLogging m => String -> m ()+debugM msg = do+    logger <- getCurrentLoggerName+    logM logger L.DEBUG msg++infoM :: MonadLogging m => String -> m ()+infoM msg = do+    logger <- getCurrentLoggerName+    logM logger L.INFO msg++noticeM :: MonadLogging m => String -> m ()+noticeM msg = do+    logger <- getCurrentLoggerName+    logM logger L.NOTICE msg++warningM :: MonadLogging m => String -> m ()+warningM msg = do+    logger <- getCurrentLoggerName+    logM logger L.WARNING msg++errorM :: MonadLogging m => String -> m ()+errorM msg = do+    logger <- getCurrentLoggerName+    logM logger L.ERROR msg++criticalM :: MonadLogging m => String -> m ()+criticalM msg = do+    logger <- getCurrentLoggerName+    logM logger L.CRITICAL msg++alertM :: MonadLogging m => String -> m ()+alertM msg = do+    logger <- getCurrentLoggerName+    logM logger L.ALERT msg++emergencyM :: MonadLogging m => String -> m ()+emergencyM msg = do+    logger <- getCurrentLoggerName+    logM logger L.EMERGENCY msg

@@ -0,0 +1,108 @@+{-# LANGUAGE TemplateHaskell #-}+module Lambdabot.Main+    ( lambdabotVersion+    +    , Config+    , DSum(..)+    , lambdabotMain++    , Modules+    , modules++    , module Lambdabot.Plugin.Core+    , Priority(..)+    ) where++import Lambdabot.Bot+import Lambdabot.Config+import Lambdabot.Logging+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 Data.Dependent.Sum+import Data.List+import Data.Typeable+import Data.Version+import Language.Haskell.TH+import Paths_lambdabot_core+import System.Exit+import System.Log.Formatter+import qualified System.Log.Logger as L+import System.Log.Handler.Simple+import Network (withSocketsDo)++lambdabotVersion :: Version+lambdabotVersion = version++setupLogging :: LB ()+setupLogging = do+    stream <- getConfig consoleLogHandle+    level  <- getConfig consoleLogLevel+    format <- getConfig consoleLogFormat+    +    unformattedHandler <- io (streamHandler stream level)+    let consoleHandler = unformattedHandler+            { formatter = simpleLogFormatter format }+    +    setRoot <- getConfig replaceRootLogger+    +    io $ if setRoot+        then L.updateGlobalLogger L.rootLoggerName+            (L.setLevel level . L.setHandlers [consoleHandler])+        else L.updateGlobalLogger "Lambdabot"+            (L.setLevel level . L.addHandler consoleHandler)++-- | The Lambdabot entry point.+-- Initialise plugins, connect, and run the bot in the LB monad+--+-- 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 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+                Just code -> return code+                Nothing -> do+                    putStrLn "exception:"+                    print er+                    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+    +    withAllModules moduleExit+    flushModuleState+++------------------------------------------------------------------------++type Modules = LB ()++modules :: [String] -> Q Exp+modules xs = [| sequence_ $(listE $ map instalify (nub xs)) |]+    where+        instalify x =+            let module' = varE $ mkName (x ++ "Plugin")+             in [| ircLoadModule $module' x |]

@@ -0,0 +1,25 @@+--+-- Provides interface to messages, message pipes+--+module Lambdabot.Message+    ( Message(..)+    ) where++import Lambdabot.Nick++-- TODO: probably remove "Show a" later (used only to implement @echo)+class Show a => Message a where+    -- | extracts the tag of the server involved in a given message+    server      :: a -> String++    -- | extracts the nickname involved in a given message.+    nick        :: a -> Nick++    -- | 'fullName' extracts the full user name involved in a given message.+    fullName    :: a -> String++    -- | 'channels' extracts the channels a Message operate on.+    channels    :: a -> [Nick]++    -- TODO: there must be a better way of handling this ...+    lambdabotName :: a -> Nick

@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Lambdabot.Module+    ( Module(..)+    , newModule+    +    , ModuleT(..)++    , getRef+    , getModuleName+    , bindModule0+    , bindModule1+    , bindModule2+    ) where++import qualified Lambdabot.Command as Cmd+import Lambdabot.Config+import Lambdabot.Logging+import {-# SOURCE #-} Lambdabot.Monad+import Lambdabot.Util.Serial++import Control.Applicative+import Control.Concurrent (MVar)+import Control.Monad+import Control.Monad.Base+import Control.Monad.Reader (MonadReader(..), ReaderT(..))+import Control.Monad.Trans (MonadTrans(..), MonadIO(..))+import Control.Monad.Trans.Control+import System.Console.Haskeline.MonadException (MonadException)++------------------------------------------------------------------------++-- | The Module type class.+data Module st = Module {+        -- | If the module wants its state to be saved, this function should+        --   return a Serial.+        --+        --   The default implementation returns Nothing.+        moduleSerialize :: !(Maybe (Serial st)),++        -- | If the module maintains state, this method specifies the default state+        --   (for example in case the state can't be read from a state).+        --+        --   The default implementation returns an error and assumes the state is+        --   never accessed.+        moduleDefState  :: !(LB st),++        -- | Is the module sticky? Sticky modules (as well as static ones) can't be+        --   unloaded. By default, modules are not sticky.+        moduleSticky    :: !Bool,++        -- | The commands the module listenes to.+        moduleCmds      :: !(ModuleT st LB [Cmd.Command (ModuleT st LB)]),++        -- | Initialize the module. The default implementation does nothing.+        moduleInit      :: !(ModuleT st LB ()),++        -- | Finalize the module. The default implementation does nothing.+        moduleExit      :: !(ModuleT st LB ()),++        -- | Process contextual input. A plugin that implements 'contextual'+        -- is able to respond to text not part of a normal command.+        contextual+            :: !(String                           --  the text+             -> Cmd.Cmd (ModuleT st LB) ())       -- ^ the action+    }++------------------------------------------------------------------------++newModule :: Module st+newModule = Module+    { contextual         = \_ -> return ()+    , moduleCmds         = return []+    , moduleExit         = return ()+    , moduleInit         = return ()+    , moduleSticky       = False+    , moduleSerialize    = Nothing+    , moduleDefState     = return $ error "state not initialized"+    }++--+-- | 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)++instance MonadLogging m => MonadLogging (ModuleT st m) where+    getCurrentLogger = do+        parent <- lift getCurrentLogger+        self   <- getModuleName+        return (parent ++ ["Plugin", self])+    logM a b c = lift (logM a b c)++instance MonadBase b m => MonadBase b (ModuleT st m) where+    liftBase = lift . liftBase++instance MonadTransControl (ModuleT st) where+    newtype StT (ModuleT st) a = StModule {unStModule :: a}+    liftWith f = do+        r <- ModuleT ask+        lift $ f $ \t -> liftM StModule (runReaderT (runModuleT t) r)+    restoreT = lift . liftM unStModule+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}++instance MonadBaseControl b m => MonadBaseControl b (ModuleT st m) where+    newtype StM (ModuleT st m) a = StMModule {unStMModule :: ComposeSt (ModuleT st) m a}+    liftBaseWith = defaultLiftBaseWith StMModule+    restoreM     = defaultRestoreM     unStMModule+    {-# 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

@@ -0,0 +1,283 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+module Lambdabot.Monad+    ( IRCRState+    , initRoState+    , reportInitDone+    , waitForInit+    , waitForQuit+    +    , Callback+    , ModuleRef(..)+    , CommandRef(..)+    , IRCRWState(..)+    , initRwState+    +    , LB(..)+    , MonadLB(..)+    , evalLB+    +    , addServer+    , remServer+    , send+    , received+    +    , getConfig+    +    , withModule+    , withCommand+    , withAllModules+    ) where++import           Lambdabot.ChanName+import           Lambdabot.Command+import           Lambdabot.Config+import           Lambdabot.Config.Core+import           Lambdabot.IRC+import           Lambdabot.Logging+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.Reader+import Control.Monad.State+import Control.Monad.Trans.Control+import qualified Data.Dependent.Map as D+import Data.IORef+import qualified Data.Map as M+import qualified Data.Set as S+import System.Console.Haskeline.MonadException (MonadException)++------------------------------------------------------------------------+--+-- Lambdabot state+--++-- | Global read-only state.+data IRCRState = IRCRState+    { ircInitDoneMVar   :: MVar ()+    , ircQuitMVar       :: MVar ()+    , ircConfig         :: D.DMap Config+    }++-- | Default ro state+initRoState :: [D.DSum Config] -> IO IRCRState+initRoState configuration = do+    quitMVar     <- newEmptyMVar+    initDoneMVar <- newEmptyMVar+    +    return IRCRState +        { ircQuitMVar       = quitMVar+        , ircInitDoneMVar   = initDoneMVar+        , ircConfig         = D.fromListWithKey (flip . mergeConfig) configuration+        }++reportInitDone :: MonadIO m => IRCRState -> m ()+reportInitDone = io . flip putMVar () . ircInitDoneMVar++askLB :: MonadLB m => (IRCRState -> a) -> m a+askLB f  = lb . LB $ asks (f . fst)++waitForInit :: MonadLB m => m ()+waitForInit = readMVar =<< askLB ircInitDoneMVar++waitForQuit :: MonadLB m => m ()+waitForQuit = readMVar =<< askLB ircQuitMVar++type Callback = IrcMessage -> LB ()++data ModuleRef = forall st.+    ModuleRef (Module st) (MVar st) String++data CommandRef = forall st.+    CommandRef (Module st) (MVar st) String (Command (ModuleT st LB))++-- | Global read\/write state.+data IRCRWState = IRCRWState+    { ircServerMap       :: M.Map String (String, IrcMessage -> LB ())+    , ircPrivilegedUsers :: S.Set Nick+    , ircIgnoredUsers    :: S.Set Nick+    +    , ircChannels        :: M.Map ChanName String+    -- ^ maps channel names to topics+    +    , ircModules         :: M.Map String ModuleRef+    , ircCallbacks       :: M.Map String [(String,Callback)]+    , ircOutputFilters   :: [(String, OutputFilter LB)]+    -- ^ Output filters, invoked from right to left+    +    , ircCommands        :: M.Map String CommandRef+    , ircStayConnected   :: !Bool+    }++-- | Default rw state+initRwState :: IRCRWState+initRwState = IRCRWState+    { ircPrivilegedUsers = S.singleton (Nick "offlinerc" "null")+    , ircIgnoredUsers    = S.empty+    , ircChannels        = M.empty+    , ircModules         = M.empty+    , ircServerMap       = M.empty+    , ircCallbacks       = M.empty+    , ircOutputFilters   = +        [ ([],cleanOutput)+        , ([],lineify)+        , ([],cleanOutput)+        ]+    , 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+--++-- | The IRC Monad. The reader transformer holds information about the+--   connection to the IRC server.+--+-- instances Monad, Functor, MonadIO, MonadState, MonadError+++newtype LB a = LB { runLB :: ReaderT (IRCRState,IORef IRCRWState) IO a }+    deriving (Functor, Applicative, Monad, MonadIO, MonadException)++instance MonadBase IO LB where+    liftBase = LB . liftBase++instance MonadBaseControl IO LB where+    newtype StM LB a = StLB { unStLB :: StM (ReaderT (IRCRState,IORef IRCRWState) IO) a }+    liftBaseWith action = LB (liftBaseWith (\run -> action (fmap StLB . run . runLB)))+    restoreM = LB . restoreM . unStLB++class (MonadIO m, MonadBaseControl IO m, MonadConfig m, MonadLogging m, Applicative m) => MonadLB m where+    lb :: LB a -> m a++instance MonadLB LB where lb = id+instance MonadLB m => MonadLB (ModuleT st m) where lb = lift . lb+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+        ref <- asks snd+        lift $ writeIORef ref x++instance MonadConfig LB where+    getConfig k = liftM (maybe (getConfigDefault k) id . 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)++------------------------------------------------------------------------+-- 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++withCommand :: String+            -> LB a+            -> (forall st. Module 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++-- | Interpret a function in the context of all modules+withAllModules :: (forall st. Module 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)

@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+#if __GLASGOW_HASKELL__ > 706+{-# LANGUAGE RoleAnnotations #-}+#endif+module Lambdabot.Monad where++import Control.Applicative++#if __GLASGOW_HASKELL__ > 706+type role LB nominal+#endif+data LB a+instance Applicative LB+instance Functor LB+instance Monad LB

@@ -0,0 +1,46 @@+module Lambdabot.Nick+    ( Nick(..)+    , fmtNick+    , parseNick+    ) where++import Lambdabot.Util++import Data.Char++-- | The type of nicknames isolated from a message.+data Nick = Nick +    { nTag  :: !String -- ^ The tag of the server this nick is on+    , nName :: !String -- ^ The server-specific nickname of this nick+    }++-- This definition of canonicalizeName breaks strict RFC rules, but so does+-- freenode+-- TODO: server-specific rules should have server-specific implementations+canonicalizeName :: String -> String+canonicalizeName = strip isSpace . map toUpper++instance Eq Nick where+  (Nick tag name) == (Nick tag2 name2) =+     (canonicalizeName name == canonicalizeName name2) && (tag == tag2)++instance Ord Nick where+  (Nick tag name) <= (Nick tag2 name2) =+     (tag, canonicalizeName name) <= (tag2, canonicalizeName name2)++-- | Format a nickname for display.  This will automatically omit the server+-- field if it is the same as the server of the provided message.+fmtNick :: String -> Nick -> String+fmtNick svr nck+    | nTag nck == svr = nName nck+    | otherwise       = nTag nck ++ ':' : nName nck++-- | Parse a nickname received in a message.  If the server field is not+-- provided, it defaults to the same as that of the message.+parseNick :: String -> String -> Nick+parseNick def str+    | null ac   = Nick def str+    | otherwise = Nick bc ac+    where +        (bc, ac') = break (==':') str+        ac = drop 1 ac'

@@ -0,0 +1,48 @@+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

@@ -0,0 +1,69 @@+--+-- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)+--+-- Syntactic sugar for developing plugins.+-- Simplifies import lists, and abstracts over common patterns+--+module Lambdabot.Plugin+    ( Module(..)+    , ModuleT+    , newModule+    +    , getModuleName+    , bindModule0+    , bindModule1+    , bindModule2+    +    , LB+    , MonadLB(..)+    , lim80+    , ios80+    +    , ChanName+    , mkCN+    , getCN+    +    , Nick(..)+    , ircPrivmsg+    +    , module Lambdabot.Config+    , module Lambdabot.Config.Core+    , module Lambdabot.Command+    , module Lambdabot.State+    , module Lambdabot.File+    , module Lambdabot.Util.Serial+    ) where++import Lambdabot.Bot+import Lambdabot.ChanName+import Lambdabot.Config+import Lambdabot.Config.Core+import Lambdabot.Command hiding (runCommand, execCmd)+import Lambdabot.File+import Lambdabot.Module+import Lambdabot.Monad+import Lambdabot.Nick+import Lambdabot.State+import Lambdabot.Util+import Lambdabot.Util.Serial++import Codec.Binary.UTF8.String+import Control.Monad+import Control.Monad.Trans+import Data.Char++lim80 :: Monad m => m String -> Cmd m ()+lim80 action = do+    to <- getTarget+    let lim = case nName to of+                  ('#':_) -> take 3 . map (limitStr 80) -- message to channel: be nice+                  _       -> id          -- private message: get everything+        spaceOut = unlines . lim . map (' ':) . lines+        removeControl = filter (\x -> isSpace x || not (isControl x))+    (say =<<) . lift $ liftM (encodeString . spaceOut . removeControl . decodeString) action++-- | convenience, similar to ios but also cut output to channel to 80 characters+-- usage:  @process _ _ to _ s = ios80 to (plugs s)@+ios80 :: MonadIO m => IO String -> Cmd m ()+ios80 = lim80 . io

@@ -0,0 +1,24 @@+module Lambdabot.Plugin.Core+    ( basePlugin+    , systemPlugin+    , offlineRCPlugin+    , composePlugin+    , helpPlugin+    , morePlugin+    , versionPlugin+    +    , corePlugins+    , module Lambdabot.Config.Core+    ) where++import Lambdabot.Config.Core+import Lambdabot.Plugin.Core.Base+import Lambdabot.Plugin.Core.Compose+import Lambdabot.Plugin.Core.Help+import Lambdabot.Plugin.Core.More+import Lambdabot.Plugin.Core.OfflineRC+import Lambdabot.Plugin.Core.System+import Lambdabot.Plugin.Core.Version++corePlugins :: [String]+corePlugins = ["base", "system", "offlineRC", "compose", "help", "more", "version"]

@@ -0,0 +1,341 @@+{-# LANGUAGE PatternGuards #-}+-- | Lambdabot base module. Controls message send and receive+module Lambdabot.Plugin.Core.Base (basePlugin) where++import Lambdabot.Bot+import Lambdabot.Command+import Lambdabot.Config.Core+import Lambdabot.IRC+import Lambdabot.Logging+import Lambdabot.Message+import Lambdabot.Monad+import Lambdabot.Nick+import Lambdabot.Plugin+import Lambdabot.Util++import Control.Applicative+import Control.Exception.Lifted as E+import Control.Monad+import Control.Monad.State+import Data.List+import Data.List.Split+import qualified Data.Map as M+import Text.EditDistance+import Text.Regex.TDFA++type BaseState = GlobalPrivate () ()+type Base = ModuleT BaseState LB++basePlugin :: Module (GlobalPrivate () ())+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 -}+    }++doIGNORE :: Callback+doIGNORE = debugM . show++doPING :: Callback+doPING = noticeM . showPingMsg+    where showPingMsg msg = "PING! <" ++ ircMsgServer msg ++ (':' : ircMsgPrefix msg) +++            "> [" ++ ircMsgCommand msg ++ "] " ++ show (ircMsgParams msg)++-- If this is a "TIME" then we need to pass it over to the localtime plugin+-- otherwise, dump it to stdout+doNOTICE :: IrcMessage -> Base ()+doNOTICE msg+    | isCTCPTimeReply   = doPRIVMSG (timeReply msg)+        -- TODO: need to say which module to run the privmsg in+    | otherwise         = noticeM (show body)+    where+        body = ircMsgParams msg+        isCTCPTimeReply = ":\SOHTIME" `isPrefixOf` (last body)++doJOIN :: Callback+doJOIN msg +    | lambdabotName msg /= nick msg = doIGNORE msg+    | otherwise                     = do+        let msgArg  = concat (take 1 (ircMsgParams msg))+            chan    = case dropWhile (/= ':') msgArg of+                []      -> msgArg+                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+   where ++doPART :: Callback+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) })++doKICK :: IrcMessage -> Base ()+doKICK msg+   = do let body = ircMsgParams msg+            loc = Nick (server msg) (body !! 0)+            who = Nick (server msg) (body !! 1)+        when (lambdabotName msg == who) $ do+            noticeM $ fmtNick "" (nick msg) ++ " KICK " ++ fmtNick (server msg) loc ++ " " ++ show (drop 2 body)+            lift $ modify $ \s ->+                s { ircChannels = M.delete (mkCN loc) (ircChannels s) }++doNICK :: Callback+doNICK msg+  = doIGNORE msg++doMODE :: Callback+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)})++doRPL_WELCOME :: Callback+doRPL_WELCOME = doIGNORE++doQUIT :: Callback+doQUIT msg = doIGNORE msg++doRPL_BOUNCE :: Callback+doRPL_BOUNCE _msg = debugM "BOUNCE!"++doRPL_TOPIC :: Callback+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) })++doPRIVMSG :: IrcMessage -> Base ()+doPRIVMSG msg = do+    ignored     <- lift $ checkIgnore msg+    commands    <- getConfig commandPrefixes+    +    if ignored+        then lift $ doIGNORE msg+        else mapM_ (doPRIVMSG' commands (lambdabotName msg) msg) targets+    where+        alltargets = head (ircMsgParams msg)+        targets = map (parseNick (ircMsgServer msg)) $ splitOn "," alltargets++--+-- | What does the bot respond to?+--+doPRIVMSG' :: [String] -> Nick -> IrcMessage -> Nick -> Base ()+doPRIVMSG' commands myname msg target+    | myname == target+    = let (cmd, params) = splitFirstWord text+      in doPersonalMsg commands msg target text cmd params+    +    | flip any ":," $ \c -> (fmtNick (ircMsgServer msg) myname ++ [c]) `isPrefixOf` text+    = let Just wholeCmd = maybeCommand (fmtNick (ircMsgServer msg) myname) text+          (cmd, params) = splitFirstWord wholeCmd+      in doPublicMsg commands msg target cmd params+    +    | (commands `arePrefixesOf` text)+    && length text > 1+    && (text !! 1 /= ' ') -- elem of prefixes+    && (not (commands `arePrefixesOf` [text !! 1]) ||+      (length text > 2 && text !! 2 == ' ')) -- ignore @@ prefix, but not the @@ command itself+    = let (cmd, params) = splitFirstWord (dropWhile (==' ') text)+      in doPublicMsg commands msg target cmd params+    +    | otherwise =  doContextualMsg msg target target text+    +    where+        text = tail (head (tail (ircMsgParams msg)))++doPersonalMsg :: [String] -> IrcMessage -> Nick -> String -> String -> String -> Base ()+doPersonalMsg commands msg target text s r+    | commands `arePrefixesOf` s  = doMsg msg (tail s) r who+    | otherwise                   = doContextualMsg msg target who text+    where+      who = nick msg++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)++--+-- normal commands.+--+-- check privledges, do any spell correction, dispatch, handling+-- possible timeouts.+--+-- todo, refactor+--+doMsg :: IrcMessage -> String -> String -> Nick -> Base ()+doMsg msg cmd rest towhere = do+    let ircmsg = ircPrivmsg towhere+    allcmds <- lift (gets (M.keys . ircCommands))+    let ms      = filter (isPrefixOf cmd) allcmds+    e <- getConfig editDistanceLimit+    case ms of+        [s] -> docmd msg towhere rest s                  -- a unique prefix+        _ | cmd `elem` ms -> docmd msg towhere rest cmd  -- correct command (usual case)+        _ | otherwise     -> case closests cmd allcmds of+          (n,[s]) | n < e ,  ms == [] -> docmd msg towhere rest s -- unique edit match+          (n,ss)  | n < e || ms /= []            -- some possibilities+              -> lift . ircmsg $ "Maybe you meant: "++showClean(nub(ms++ss))+          _   -> docmd msg towhere rest cmd         -- no prefix, edit distance too far++docmd :: IrcMessage -> Nick -> [Char] -> String -> Base ()+docmd msg towhere rest cmd' = withPS towhere $ \_ _ -> do+    withCommand cmd'   -- Important.+        (ircPrivmsg towhere "Unknown command, try @list")+        (\_ theCmd -> do+            name'   <- getModuleName++            hasPrivs <- lb (checkPrivs msg)+            +            -- TODO: handle disabled commands earlier+            -- users should probably see no difference between a+            -- command that is disabled and one that doesn't exist.+            disabled <- elem cmd' <$> getConfig disabledCommands+            let ok = not disabled && (not (privileged theCmd) || hasPrivs)++            response <- if not ok+                then return ["Not enough privileges"]+                else runCommand theCmd msg towhere cmd' rest+                    `E.catch` \exc@SomeException{} ->+                        return ["Plugin `" ++ name' ++ "' failed with: " ++ show exc]+            +            -- send off our response strings+            -- TODO: expandTab here should probably be an OutputFilter+            lift $ mapM_ (ircPrivmsg towhere . expandTab 8) response+        )++--+-- contextual messages are all input that isn't an explicit command.+-- they're passed to all modules (todo, sounds inefficient) for+-- scanning, and any that implement 'contextual' will reply.+--+-- we try to run the contextual functions from all modules, on every+-- non-command. better hope this is efficient.+--+-- Note how we catch any plugin errors here, rather than letting+-- 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)++------------------------------------------------------------------------++closests :: String -> [String] -> (Int,[String])+closests pat ss = M.findMin m+    where+        m = M.fromListWith (++) ls+        ls = [ (levenshteinDistance defaultEditCosts pat s, [s]) | s <- ss ]++maybeCommand :: String -> String -> Maybe String+maybeCommand nm text = mrAfter <$> matchM re text+    where+        re :: Regex+        re = makeRegex (nm ++ "[.:,]*[[:space:]]*")++--+-- And stuff we don't care about+--++{-+doRPL_YOURHOST :: Callback+doRPL_YOURHOST _msg = return ()++doRPL_CREATED :: Callback+doRPL_CREATED _msg = return ()++doRPL_MYINFO :: Callback+doRPL_MYINFO _msg = return ()++doRPL_STATSCONN :: Callback+doRPL_STATSCONN _msg = return ()++doRPL_LUSERCLIENT :: Callback+doRPL_LUSERCLIENT _msg = return ()++doRPL_LUSEROP :: Callback+doRPL_LUSEROP _msg = return ()++doRPL_LUSERUNKNOWN :: Callback+doRPL_LUSERUNKNOWN _msg = return ()++doRPL_LUSERCHANNELS :: Callback+doRPL_LUSERCHANNELS _msg = return ()++doRPL_LUSERME :: Callback+doRPL_LUSERME _msg = return ()++doRPL_LOCALUSERS :: Callback+doRPL_LOCALUSERS _msg = return ()++doRPL_GLOBALUSERS :: Callback+doRPL_GLOBALUSERS _msg = return ()++doUNKNOWN :: Callback+doUNKNOWN msg+    = debugM $ "UNKNOWN> <" ++ msgPrefix msg +++      "> [" ++ msgCommand msg ++ "] " ++ show (body msg)++doRPL_NAMREPLY :: Callback+doRPL_NAMREPLY _msg = return ()++doRPL_ENDOFNAMES :: Callback+doRPL_ENDOFNAMES _msg = return ()++doRPL_MOTD :: Callback+doRPL_MOTD _msg = return ()++doRPL_MOTDSTART :: Callback+doRPL_MOTDSTART _msg = return ()++doRPL_ENDOFMOTD :: Callback+doRPL_ENDOFMOTD _msg = return ()+-}

@@ -0,0 +1,159 @@+{-# LANGUAGE PatternGuards #-}+-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- Another progressive plugin. Compose two (for now) plugins transparently+-- A sort of mini interpreter. Could do with some more thinking.+module Lambdabot.Plugin.Core.Compose (composePlugin) where++import Lambdabot.Command+import Lambdabot.Monad+import Lambdabot.Plugin++import Control.Arrow (first)+import Control.Monad+import Control.Monad.Trans+import Data.Char+import Data.List+import Data.List.Split++type Compose = ModuleT () LB++composePlugin :: Module ()+composePlugin = newModule+    { moduleCmds = return+        [ (command "@")+            { aliases = ["?"]+            , help = do+                c <- getCmdName+                let cc = c++c+                mapM_ say+                    [ cc++" [args]."+                    , cc++" executes plugin invocations in its arguments, parentheses can be used."+                    , " The commands are right associative."+                    , " For example:    "++cc++" "++c++"pl "++c++"undo code"+                    , " is the same as: "++cc++" ("++c++"pl ("++c++"undo code))"+                    ]+            , process = evalBracket+            }+        , (command ".")+            { aliases = ["compose"]+            , help = mapM_ say+                [ ". <cmd1> <cmd2> [args]."+                , ". [or compose] is the composition of two plugins"+                , " The following semantics are used: . f g xs == g xs >>= f"+                ]+            , process = \args -> case splitOn " " args of+                (f:g:xs) -> do+                    f' <- lookupP f+                    g' <- lookupP g+                    lb (compose f' g' (concat $ intersperse " " xs)) >>= mapM_ say+                _ -> say "Not enough arguments to @."+            }+        ]+    }++-- | Compose two plugin functions+compose :: (String -> LB [String]) -> (String -> LB [String]) -> (String -> LB [String])+compose f g xs = g xs >>= f . unlines++------------------------------------------------------------------------+-- | Lookup the `process' method we're after, and apply it to the dummy args+--+lookupP :: String -> Cmd Compose (String -> LB [String])+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))+++------------------------------------------------------------------------++-- | More interesting composition/evaluation+-- @@ @f x y (@g y z)+evalBracket :: String -> Cmd Compose ()+evalBracket args = do+    cmdPrefixes <- getConfig commandPrefixes++    let conf = cmdPrefixes+    xs <- mapM evalExpr (fst (parseBracket 0 True args conf))+    mapM_ (say . addSpace) (concat' xs)+ where concat' ([x]:[y]:xs) = concat' ([x++y]:xs)+       concat' xs           = concat xs++       addSpace :: String -> String+       addSpace (' ':xs) = ' ':xs+       addSpace xs       = ' ':xs++evalExpr :: Expr -> Cmd Compose [String]+evalExpr (Arg s) = return [s]+evalExpr (Cmd c args) = do+     args' <- mapM evalExpr args+     let arg = concat $ concat $ map (intersperse " ") args'+     cmd <- lookupP c+     lift (lift (cmd arg))++------------------------------------------------------------------------++data Expr = Cmd String [Expr]+          | Arg String+    deriving Show++-- TODO: rewrite this using parsec or something+-- | Parse a command invocation that can contain parentheses+--   The Int indicates how many brackets must be closed to end the current argument, or 0+--   The Bool indicates if this is a valid location for a character constant+parseBracket :: Int -> Bool -> String -> [String] -> ([Expr],String)+parseBracket 0 _ [] _       = ([],[])+parseBracket _ _ [] _       = error "Missing ')' in nested command"+parseBracket 1 _ (')':xs) _ = ([],xs)+parseBracket n _ (')':xs) c | n > 0+                            = first (addArg ")") $ parseBracket (n-1) True xs c+parseBracket n _ ('(':xs) c | Just ys <- isCommand xs c     -- (@cmd arg arg)+                            = parseCommand n ys c+parseBracket n _ ('(':xs) c | n > 0+                            = first (addArg "(") $ parseBracket (n+1) True xs c+parseBracket n _ xs c       | Just ('(':ys) <- isCommand xs c -- @(cmd arg arg)+                            = parseCommand n ys c+parseBracket n _ xs c       | Just ys <- isCommand xs c       -- @cmd arg arg+                            = parseInlineCommand n ys c+parseBracket n c (x:xs) cfg | x `elem` "\"'" && (c || x /= '\'')+                            = let (str, ys) = parseString x xs+                                  (rest,zs) = parseBracket n True ys cfg+                              in  (addArg (x:str) rest, zs)+parseBracket n c (x:xs) cfg = first (addArg [x])+                            $ parseBracket n (not (isAlphaNum x) && (c || x /= '\'')) xs cfg++parseCommand, parseInlineCommand :: Int -> String -> [String] -> ([Expr],String)+parseCommand n xs conf = (Cmd cmd args:rest, ws)+    where+        (cmd, ys) = break (`elem` " )") xs+        (args,zs) = parseBracket 1 True (dropWhile (==' ') ys) conf+        (rest,ws) = parseBracket n True zs conf++parseInlineCommand n xs conf = (Cmd cmd rest:[], zs)+  where+    (cmd, ys) = break (`elem` " )") xs+    (rest,zs) = parseBracket n True (dropWhile (==' ') ys) conf++parseString :: Char -> String -> (String, String)+parseString _     []          = ([],[])+parseString delim ('\\':x:xs) = first (\ys -> '\\':x:ys) (parseString delim xs)+parseString delim (x:xs)+  | delim == x                = ([x],xs)+  | otherwise                 = first (x:) (parseString delim xs)+++-- | Does xs start with a command prefix?+isCommand :: String -> [String] -> Maybe String+isCommand xs = msum . map dropPrefix+ where dropPrefix p+          | p `isPrefixOf` xs = Just $ drop (length p) xs+          | otherwise         = Nothing++addArg :: String -> [Expr] -> [Expr]+addArg s (Arg a:es) = Arg (s++a):es+addArg s es         = Arg s     :es

@@ -0,0 +1,47 @@+-- | Provide help for plugins+module Lambdabot.Plugin.Core.Help (helpPlugin) where++import Lambdabot.Command+import Lambdabot.Message (Message)+import Lambdabot.Monad+import Lambdabot.Plugin+import Lambdabot.Util++helpPlugin :: Module ()+helpPlugin = newModule+    { moduleCmds = return+        [ (command "help")+            { help = say "help <command>. Ask for help for <command>. Try 'list' for all commands"+            , process = \args -> withMsg $ \msg -> do+                tgt <- getTarget+                lb (doHelp msg tgt args) >>= mapM_ say+            }+        ]+    }++moduleHelp :: (Monad m, Message a) =>+              Command m -> a -> Nick -> String -> m [String]+moduleHelp theCmd msg tgt cmd =+    execCmd (help theCmd) msg tgt cmd++--+-- If a target is a command, find the associated help, otherwise if it's+-- a module, return a list of commands that module implements.+--+doHelp :: Message t => t -> Nick -> [Char] -> LB [[Char]]+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+            (doHelp msg tgt "help")             -- else give up+            (\md -> do -- its a module+                cmds <- moduleCmds md+                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)++    where (arg:_) = words rest

@@ -0,0 +1,46 @@+-- | Support for more(1) buffering+module Lambdabot.Plugin.Core.More (morePlugin) where++import Lambdabot.Plugin+import Lambdabot.Bot++import Control.Monad.Trans++type MoreState = GlobalPrivate () [String]+type More = ModuleT MoreState LB++-- the @more state is handled centrally+morePlugin :: Module (GlobalPrivate () [String])+morePlugin = newModule+    { moduleDefState = return $ mkGlobalPrivate 20 ()+    , moduleInit+        =   bindModule2 moreFilter+        >>= ircInstallOutputFilter++    , moduleCmds = return+        [ (command "more")+            { help = say "@more. Return more output from the bot buffer."+            , process = \_ -> do+                target <- getTarget+                morestate <- readPS target+                -- TODO: test theory that we can just "say" morestate;+                --       it should end up going through the moreFilter as needed+                case morestate of+                    Nothing -> return ()+                    Just ls -> lift (moreFilter target ls)+                        >>= mapM_ (lb . ircPrivmsg' target)+            }+        ]+    }++moreFilter :: Nick -> [String] -> More [String]+moreFilter target msglines = do+    let (morelines, thislines) = case drop (maxLines+2) msglines of+          [] -> ([],msglines)+          _  -> (drop maxLines msglines, take maxLines msglines)+    writePS target $ if null morelines then Nothing else Just morelines+    return $ thislines ++ if null morelines+                          then []+                          else ['[':shows (length morelines) " @more lines]"]++    where maxLines = 5 -- arbitrary, really

@@ -0,0 +1,105 @@+-- | Offline mode / RC file / -e support module.  Handles spooling lists+-- of commands (from haskeline, files, or the command line) into the vchat+-- layer.+module Lambdabot.Plugin.Core.OfflineRC ( offlineRCPlugin ) where++import Lambdabot.Config.Core+import Lambdabot.IRC+import Lambdabot.Monad+import Lambdabot.Plugin+import Lambdabot.Util++import Control.Concurrent.Lifted+import Control.Exception.Lifted ( evaluate, finally )+import Control.Monad( void, when )+import Control.Monad.State( gets )+import Control.Monad.Trans( lift, liftIO )+import Data.Char+import System.Console.Haskeline (InputT, Settings(..), runInputT, defaultSettings, getInputLine)+import System.IO+import System.Timeout.Lifted++-- 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+-- being used.+type OfflineRCState = Integer+type OfflineRC = ModuleT OfflineRCState LB++offlineRCPlugin :: Module OfflineRCState+offlineRCPlugin = newModule+    { moduleDefState = return 0+    , moduleInit = do+        void . fork $ do+            waitForInit+            lockRC+            cmds <- getConfig onStartupCmds+            mapM_ feed cmds `finally` unlockRC++    , moduleCmds = return+        [ (command "offline")+            { privileged = True+            , help = say "offline. Start a repl"+            , process = const . lift $ do+                lockRC+                histFile <- lb $ findOrCreateLBFile "offlinerc"+                let settings = defaultSettings { historyFile = Just histFile }+                _ <- fork (runInputT settings replLoop `finally` unlockRC)+                return ()+            }+        , (command "rc")+            { privileged = True+            , help = say "rc name. Read a file of commands (asynchonously). TODO: better name."+            , process = \fn -> lift $ do+                txt <- io $ readFile fn+                io $ evaluate $ foldr seq () txt+                lockRC+                _ <- fork (mapM_ feed (lines txt) `finally` unlockRC)+                return ()+            }+        ]+    }++feed :: String -> OfflineRC ()+feed msg = do+    cmdPrefix <- fmap head (getConfig commandPrefixes)+    let msg' = case msg of+            '>':xs -> cmdPrefix ++ "run " ++ xs+            '!':xs -> xs+            _      -> cmdPrefix ++ dropWhile (== ' ') msg+    lift . (>> return ()) . timeout (15 * 1000 * 1000) . received $+              IrcMessage { ircMsgServer = "offlinerc"+                         , ircMsgLBName = "offline"+                         , ircMsgPrefix = "null!n=user@null"+                         , ircMsgCommand = "PRIVMSG"+                         , ircMsgParams = ["offline", ":" ++ msg' ] }++handleMsg :: IrcMessage -> LB ()+handleMsg msg = liftIO $ do+    let str = case (tail . ircMsgParams) msg of+            []    -> []+            (x:_) -> tail x+    hPutStrLn stdout str+    hFlush stdout++replLoop :: InputT OfflineRC ()+replLoop = do+    line <- getInputLine "lambdabot> "+    case line of+        Nothing -> return ()+        Just x -> do+            let s' = dropWhile isSpace x+            when (not $ null s') $ do+                lift $ feed s'+            continue <- lift (lift (gets ircStayConnected))+            when continue replLoop++lockRC :: OfflineRC ()+lockRC = do+    withMS $ \ cur writ -> do+        when (cur == 0) (addServer "offlinerc" handleMsg)+        writ (cur + 1)++unlockRC :: OfflineRC ()+unlockRC = withMS $ \ cur writ -> do+    when (cur == 1) $ lb $ remServer "offlinerc"+    writ (cur - 1)

@@ -0,0 +1,190 @@+-- | System module : IRC control functions+module Lambdabot.Plugin.Core.System (systemPlugin) where++import Lambdabot.Bot+import Lambdabot.Compat.AltTime+import Lambdabot.Compat.FreenodeNick+import Lambdabot.IRC+import Lambdabot.Monad+import Lambdabot.Plugin+import Lambdabot.Util++import Control.Monad.State (gets, modify)+import Control.Monad.Trans+import qualified Data.Map as M+import qualified Data.Set as S++type SystemState = (ClockTime, TimeDiff)+type System = ModuleT SystemState LB++systemPlugin :: Module SystemState+systemPlugin = newModule+    { moduleDefState = flip (,) noTimeDiff `fmap` io getClockTime+    , moduleSerialize  = Just stdSerial++    , moduleInit = do+        (_, d) <- readMS+        t      <- io getClockTime+        writeMS (t, d)+    , moduleExit = do+        (initial, d) <- readMS+        now          <- liftIO getClockTime+        writeMS (initial, max d (diffClockTimes now initial))+    +    , moduleCmds = return $+        [ (command "listchans")+            { help = say "Show channels bot has joined"+            , process = \_ -> listKeys (M.mapKeysMonotonic (FreenodeNick . getCN) . ircChannels)+            }+        , (command "listmodules")+            { help = say "listmodules. Show available plugins"+            , process = \_ -> listKeys ircModules+            }+        , (command "listservers")+            { help = say "listservers. Show current servers"+            , process = \_ -> listKeys ircServerMap+            }+        , (command "list")+            { help = say "list [module|command]. Show commands for [module] or the module providing [command]."+            , process = doList+            }+        , (command "echo")+            { help = say "echo <msg>. echo irc protocol string"+            , process = doEcho+            }+        , (command "uptime")+            { help = say "uptime. Show uptime"+            , process = \_ -> do+                (uptime, maxUptime) <- lift getUptime+                say ("uptime: "           ++ timeDiffPretty uptime +++                     ", longest uptime: " ++ timeDiffPretty maxUptime)+            }+        +        , (command "listall")+            { privileged = True+            , help = say "list all commands"+            , process = \_ -> mapM_ doList . M.keys =<< lb (gets ircModules)+            }+        , (command "join")+            { privileged = True+            , help = say "join <channel>"+            , process = \rest -> do+                chan <- readNick rest+                lb $ send (joinChannel chan)+            }+        , (command "part")+            { privileged = True+            , help = say "part <channel>"+            , aliases = ["leave"]+            , process = \rest -> do+                chan <- readNick rest+                lb $ send (partChannel chan)+            }+        , (command "msg")+            { privileged = True+            , help = say "msg <nick or channel> <msg>"+            , process = \rest -> do+                -- writes to another location:+                let (tgt, txt) = splitFirstWord rest+                tgtNick <- readNick tgt+                lb $ ircPrivmsg tgtNick txt+            }+        , (command "codepage")+            { privileged = True+            , help = say "codepage <server> <CP-name>"+            , process = \rest -> do+                let (server, cp) = splitFirstWord rest+                lb $ ircCodepage server cp+            }+        , (command "quit")+            { privileged = True+            , help = say "quit [msg], have the bot exit with msg"+            , process = \rest -> do+                server <- getServer+                lb (ircQuit server $ if null rest then "requested" else rest)+            }+        , (command "flush")+            { privileged = True+            , help = say "flush. flush state to disk"+            , process = \_ -> lb flushModuleState+            }+        , (command "admin")+            { privileged = True+            , help = say "admin [+|-] nick. change a user's admin status."+            , process = doAdmin+            }+        , (command "ignore")+            { privileged = True+            , help = say "ignore [+|-] nick. change a user's ignore status."+            , process = doIgnore+            }+        , (command "reconnect")+            { privileged = True+            , help = say "reconnect to server"+            , process = \rest -> do+                server <- getServer+                lb (ircReconnect server $ if null rest then "requested" else rest)+            }+        ]+    }++------------------------------------------------------------------------++doList :: String -> Cmd System ()+doList "" = say "What module?  Try @listmodules for some ideas."+doList m  = say =<< lb (listModule m)++doEcho :: String -> Cmd System ()+doEcho rest = do+    rawMsg <- withMsg (return . show)+    target <- showNick =<< getTarget+    say (concat ["echo; msg:", rawMsg, " target:" , target, " rest:", show rest])++doAdmin :: String -> Cmd System ()+doAdmin = toggleNick $ \op nck s -> s { ircPrivilegedUsers = op nck (ircPrivilegedUsers s) }++doIgnore :: String -> Cmd System ()+doIgnore = toggleNick $ \op nck s -> s { ircIgnoredUsers = op nck (ircIgnoredUsers s) }++------------------------------------------------------------------------++--  | Print map keys+listKeys :: Show k => (IRCRWState -> M.Map k v) -> Cmd System ()+listKeys f = say . showClean . M.keys =<< lb (gets f)++getUptime :: System (TimeDiff, TimeDiff)+getUptime = do+    (loaded, m) <- readMS+    now         <- io getClockTime+    let diff = now `diffClockTimes` loaded+    return (diff, max diff m)++toggleNick :: (Ord a, MonadLB m) =>+    ((a -> S.Set a -> S.Set a) -> Nick -> IRCRWState -> IRCRWState)+    -> String -> Cmd m ()+toggleNick edit rest = do+    let (op, tgt) = splitAt 2 rest+    +    f <- case op of+        "+ " -> return S.insert+        "- " -> return S.delete+        _    -> fail "invalid usage"+    +    nck <- readNick tgt+    lb . modify $ edit f nck++listModule :: String -> LB String+listModule s = withModule s fromCommand printProvides+  where+    fromCommand = withCommand s+        (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+        let cmds' = filter (not . privileged) cmds+        name' <- getModuleName+        return . concat $ if null cmds'+                          then [name', " has no visible commands"]+                          else [name', " provides: ", showClean (concatMap cmdNames cmds')]

@@ -0,0 +1,23 @@+-- Copyright (c) 2005-6 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | Lambdabot version information+module Lambdabot.Plugin.Core.Version (versionPlugin) where++import Lambdabot.Plugin+import Paths_lambdabot_core (version)+import Data.Version (showVersion)++versionPlugin :: Module ()+versionPlugin = newModule+    { moduleCmds = return+        [ (command "version")+            { help = say $+                "version/source. Report the version " +++                "and git repo of this bot"+            , process = const $ do+                say $ "lambdabot " ++ showVersion version+                say "git clone git://github.com/lambdabot/lambdabot.git"+            }+        ]+    }

@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- | Support for the LB (LambdaBot) monad+module Lambdabot.State+    ( -- ** Functions to access the module's state+      MonadLBState(..)+    , readMS+    , writeMS+    , modifyMS+    +    -- ** Utility functions for modules that need state for each target.+    , GlobalPrivate -- (global)+    , mkGlobalPrivate+    +    , withPS+    , readPS+    , writePS+    +    , withGS+    , readGS+    , writeGS+    +    -- ** Handling global state+    , flushModuleState+    , readGlobalState+    , writeGlobalState+  ) where++import Lambdabot.File+import Lambdabot.Logging+import Lambdabot.Monad+import Lambdabot.Module+import Lambdabot.Nick+import Lambdabot.Command+import Lambdabot.Util+import Lambdabot.Util.Serial++import Control.Concurrent.Lifted+import Control.Exception.Lifted as E+import Control.Monad.Trans+import Control.Monad.Trans.Control+import qualified Data.ByteString.Char8 as P+import Data.IORef.Lifted++-- | Thread-safe modification of an MVar.+withMWriter :: MonadBaseControl IO m => MVar a -> (a -> (a -> m ()) -> m b) -> m b+withMWriter mvar f = bracket+  (do x <- takeMVar mvar; ref <- newIORef x; return (x,ref))+  (\(_,ref) -> tryPutMVar mvar =<< readIORef ref)+  (\(x,ref) -> f x $ writeIORef ref)++class MonadLB m => MonadLBState m where+    type LBState m+    +    -- | Update the module's private state.+    -- This is the preferred way of changing the state. The state will be locked+    -- until the body returns. The function is exception-safe, i.e. even if+    -- an error occurs or the thread is killed (e.g. because it deadlocked and+    -- therefore exceeded its time limit), the state from the last write operation+    -- will be restored. If the writer escapes, calling it will have no observable+    -- effect.+    -- @withMS@ is not composable, in the sense that a readMS from within the body+    -- will cause a dead-lock. However, all other possibilies to access the state+    -- that came to my mind had even more serious deficiencies such as being prone+    -- to race conditions or semantic obscurities.+    withMS :: (LBState m -> (LBState m -> m ()) -> m a) -> m a++instance MonadLB m => MonadLBState (ModuleT st m) where+    type LBState (ModuleT st m) = st+    withMS f = do+        ref <- getRef+        withMWriter ref f++instance MonadLBState m => MonadLBState (Cmd m) where+    type LBState (Cmd m) = LBState m+    withMS f = do+        x <- liftWith $ \run -> +            withMS $ \st wr -> +                run (f st (lift . wr))+        restoreT (return x)++-- | Read the module's private state.+readMS :: MonadLBState m => m (LBState m)+readMS = withMS (\st _ -> return st)++-- | Modify the module's private state.+modifyMS :: MonadLBState m => (LBState m -> LBState m) -> m ()+modifyMS f = withMS $ \st wr -> wr (f st)++-- | Write the module's private state. Try to use withMS instead.+writeMS :: MonadLBState m => LBState m -> m ()+writeMS = modifyMS . const++-- | This datatype allows modules to conviently maintain both global+--   (i.e. for all clients they're interacting with) and private state.+--   It is implemented on top of readMS\/withMS.+--+-- This simple implementation is linear in the number of private states used.+data GlobalPrivate g p = GP {+  global :: !g,+  private :: ![(Nick,MVar (Maybe p))],+  maxSize :: Int+}++-- | Creates a @GlobalPrivate@ given the value of the global state. No private+--   state for clients will be created.+mkGlobalPrivate :: Int -> g -> GlobalPrivate g p+mkGlobalPrivate ms g = GP {+  global = g,+  private = [],+  maxSize = ms+}++-- Needs a better interface. The with-functions are hardly useful.+-- | Writes private state. For now, it locks everything.+withPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => Nick  -- ^ The target+  -> (Maybe p -> (Maybe p -> LB ()) -> LB a)+    -- ^ @Just x@ writes x in the user's private state, @Nothing@ removes it.+  -> m a+withPS who f = do+  mvar <- accessPS return id who+  lb $ withMWriter mvar f++-- | Reads private state.+readPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => Nick -> m (Maybe p)+readPS = accessPS (liftIO . readMVar) (\_ -> return Nothing)++-- | Reads private state, executes one of the actions success and failure+-- which take an MVar and an action producing a @Nothing@ MVar, respectively.+accessPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => (MVar (Maybe p) -> m a) -> (m (MVar (Maybe p)) -> m a)+  -> Nick+  -> m a+accessPS success failure who = withMS $ \state writer ->+  case lookup who $ private state of+    Just mvar -> do+      let newPrivate = (who,mvar):+            filter ((/=who) . fst) (private state)+      length newPrivate `seq` writer (state { private = newPrivate })+      success mvar+    Nothing -> failure $ do+      mvar <- liftIO $ newMVar Nothing+      let newPrivate = take (maxSize state) $ (who,mvar): private state+      length newPrivate `seq` writer (state { private = newPrivate })+      return mvar++-- | Writes global state. Locks everything+withGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => (g -> (g -> m ()) -> m ()) -> m ()+withGS f = withMS $ \state writer ->+  f (global state) $ \g -> writer $ state { global = g }++-- | Reads global state.+readGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => m g+readGS = fmap global readMS+++-- The old interface, as we don't wanna be too fancy right now.+writePS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => Nick -> Maybe p -> m ()+writePS who x = withPS who (\_ writer -> writer x)++writeGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => g -> m ()+writeGS g = withGS (\_ writer -> writer g)++-- ---------------------------------------------------------------------+--+-- 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+        Nothing  -> return ()+        Just ser -> do+            state' <- readMS+            case serialize ser state' of+                Nothing  -> return ()   -- do not write any state+                Just out -> do+                    stateFile <- lb (findOrCreateLBFile name)+                    io (P.writeFile stateFile out)++-- | Read it in+readGlobalState :: Module st -> String -> LB (Maybe st)+readGlobalState module' name = do+    debugM ("loading state for module " ++ show name)+    case moduleSerialize module' of+        Just ser -> do+            mbStateFile <- findLBFile name+            case mbStateFile of+                Nothing         -> return Nothing+                Just stateFile  -> io $ do+                    state' <- Just `fmap` P.readFile stateFile `E.catch` \SomeException{} -> return Nothing+                    E.catch (evaluate $ maybe Nothing (Just $!) (deserialize ser =<< state')) -- Monad Maybe)+                        (\e -> do+                            errorM $ "Error parsing state file for: "+                                ++ name ++ ": " ++ show (e :: SomeException)+                            errorM $ "Try removing: "++ show stateFile+                            return Nothing) -- proceed regardless+        Nothing -> return Nothing

@@ -0,0 +1,185 @@+-- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | String and other utilities+module Lambdabot.Util (+        strip,+        dropFromEnd,+        splitFirstWord,+        limitStr,+        listToStr,+        showClean,+        expandTab,+        arePrefixesWithSpaceOf,+        arePrefixesOf,+        +        io,+        +        random,+        randomFailureMsg,+        randomSuccessMsg+    ) where++import Control.Monad.Trans+import Data.Char+import Data.List+import Data.Random+import Lambdabot.Config+import Lambdabot.Config.Core++------------------------------------------------------------------------++-- | Break a String into it's first word, and the rest of the string. Example:+--+-- > split_first_word "A fine day" ===> ("A", "fine day)+splitFirstWord :: String -- ^ String to be broken+                 -> (String, String)+splitFirstWord xs = (w, dropWhile isSpace xs')+  where (w, xs') = break isSpace xs++-- | Truncate a string to the specified length, putting ellipses at the+-- end if necessary.+limitStr :: Int -> String -> String+limitStr n s = let (b, t) = splitAt n s in+           if null t then b else take (n-3) b ++ "..."++-- | Form a list of terms using a single conjunction. Example:+--+-- > listToStr "and" ["a", "b", "c"] ===> "a, b and c"+listToStr :: String -> [String] -> String+listToStr _    []           = []+listToStr conj (item:items) =+  let listToStr' [] = []+      listToStr' [y] = concat [" ", conj, " ", y]+      listToStr' (y:ys) = concat [", ", y, listToStr' ys]+  in  item ++ listToStr' items++------------------------------------------------------------------------++-- | Pick a random element of the list.+random :: MonadIO m => [a] -> m a+random = io . sample . randomElement++------------------------------------------------------------------------++-- | 'strip' takes as input a predicate and a list and strips+--   elements matching the predicate from the prefix as well as+--   the suffix of the list. Example:+--+-- > strip isSpace "   abc  " ===> "abc"+strip :: (a -> Bool) -> [a] -> [a]+strip p = let f = reverse . dropWhile p in f . f++-- | Drop elements matching a predicate from the end of a list+dropFromEnd :: (a -> Bool) -> [a] -> [a]+dropFromEnd p = reverse . dropWhile p . reverse++------------------------------------------------------------------------++-- | show a list without heavyweight formatting+-- NB: assumes show instance outputs a quoted 'String'.+-- under that assumption, strips the outer quotes.+showClean :: (Show a) => [a] -> String+showClean = intercalate " " . map (init . tail . show)++-- | untab an string+expandTab :: Int -> String -> String+expandTab w = go 0+  where+    go _ []         = []+    go i ('\t':xs)  = replicate (w - i `mod` w) ' ' ++ go 0 xs+    go i (x:xs)     = x : go (i+1) xs++------------------------------------------------------------------------++-- convenience:+io :: MonadIO m => IO a -> m a+io = liftIO+{-# INLINE io #-}++arePrefixesWithSpaceOf :: [String] -> String -> Bool+arePrefixesWithSpaceOf = arePrefixesOf . map (++ " ")++arePrefixesOf :: [String] -> String -> Bool+arePrefixesOf = flip (any . flip isPrefixOf)++--+-- Amusing insults from OpenBSD sudo+--+insult :: [String]+insult =+   ["Just what do you think you're doing Dave?",+    "It can only be attributed to human error.",+    "That's something I cannot allow to happen.",+    "My mind is going. I can feel it.",+    "Sorry about this, I know it's a bit silly.",+    "Take a stress pill and think things over.",+    "This mission is too important for me to allow you to jeopardize it.",+    "I feel much better now.",++    "Wrong!  You cheating scum!",+    "And you call yourself a Rocket Scientist!",+    "And you call yourself a Rocket Surgeon!",+    "Where did you learn to type?",+    "Are you on drugs?",+    "My pet ferret can type better than you!",+    "You type like i drive.",+    "Do you think like you type?",+    "Your mind just hasn't been the same since the electro-shock, has it?",+    "I don't think I can be your friend on Facebook anymore.",++    "Maybe if you used more than just two fingers...",+    "BOB says:  You seem to have forgotten your passwd, enter another!",+    "stty: unknown mode: doofus",+    "I can't hear you -- I'm using the scrambler.",+    "The more you drive -- the dumber you get.",+    "Listen, broccoli brains, I don't have time to listen to this trash.",+    "I've seen penguins that can type better than that.",+    "Have you considered trying to match wits with a rutabaga?",+    "You speak an infinite deal of nothing.",++    -- other+    "Are you typing with your feet?",+    "Abort, Retry, Panic?",++    -- More haskellish insults+    "You untyped fool!",+    "My brain just exploded"+    ]++--+-- some more friendly replies+--+apology :: [String]+apology =+   ["I am sorry.","Sorry.",+    "Maybe you made a typo?",+    "Just try something else.",+    "There are some things that I just don't know.",+    "Whoa.",+    ":(",":(",+    "","",""+    ]++randomFailureMsg :: (MonadIO m, MonadConfig m) => m String+randomFailureMsg = do+    useInsults <- getConfig enableInsults+    random (if useInsults then insult ++ apology else apology)++--+-- Some more interesting confirmations for @remember and @where+--+confirmation :: [String]+confirmation =+   ["Done.","Done.",+    "Okay.",+    "I will remember.",+    "Good to know.",+    "It is stored.",+    "I will never forget.",+    "It is forever etched in my memory.",+    "Nice!"+   ]++randomSuccessMsg :: MonadIO m => m String+randomSuccessMsg = random confirmation

@@ -0,0 +1,155 @@+{-# LANGUAGE FlexibleInstances #-}++{- Copyright (c) 2004-5 Thomas Jaeger, Don Stewart++This program is free software; you can redistribute it and/or+modify it under the terms of the GNU General Public License as+published by the Free Software Foundation; either version 2 of+the License, or (at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+02111-1307, USA. -}++-- | Serialisation+module Lambdabot.Util.Serial+    ( Serial(..)+    +    , stdSerial+    , mapSerial+    , mapPackedSerial+    , assocListPackedSerial+    , mapListPackedSerial+    , readM+    , Packable(..) {- instances of Packable -}+    , readOnly+    ) where++import Data.Maybe               (mapMaybe)++import Data.Map (Map)+import qualified Data.Map as M++import qualified Data.ByteString.Char8 as P+import Data.ByteString.Char8 (ByteString)++import Data.ByteString.Lazy (fromChunks,toChunks)++import Codec.Compression.GZip++------------------------------------------------------------------------++-- A flexible (moreso than a typeclass) way to define introduction and+-- elimination for persistent state on a per-module basis.+--+data Serial s = Serial {+        serialize   :: s -> Maybe ByteString,+        deserialize :: ByteString -> Maybe s+     }++gzip   :: ByteString -> ByteString+gzip   = P.concat . toChunks . compress . fromChunks . (:[])++gunzip :: ByteString -> ByteString+gunzip = P.concat . toChunks . decompress . fromChunks . (:[])++--+-- read-only serialisation+--+readOnly :: (ByteString -> b) -> Serial b+readOnly f = Serial (const Nothing) (Just . f)++-- | Default `instance' for a Serial+stdSerial :: (Show s, Read s) => Serial s+stdSerial = Serial (Just. P.pack.show) (readM.P.unpack)++-- | Serializes a 'Map' type if both the key and the value are instances+-- of Read and Show. The serialization is done by converting the map to+-- and from lists. Results are saved line-wise, for better editing and+-- revison control.+--+mapSerial :: (Ord k, Show k, Show v, Read k, Read v) => Serial (Map k v)+mapSerial = Serial {+        serialize   = Just . P.pack . unlines . map show . M.toList,+        deserialize = Just . M.fromList . mapMaybe (readM . P.unpack) . P.lines+   }++------------------------------------------------------------------------++-- | 'readM' behaves like read, but catches failure in a monad.+-- this allocates a 20-30 M on startup...+readM :: (Monad m, Read a) => String -> m a+readM s = case [x | (x,t) <- {-# SCC "Serial.readM.reads" #-} reads s    -- bad!+               , ("","")  <- lex t] of+        [x] -> return x+        []  -> fail "Serial.readM: no parse"+        _   -> fail "Serial.readM: ambiguous parse"++class Packable t where+        readPacked :: ByteString -> t+        showPacked :: t -> ByteString++-- | An instance for Map Packed [Packed]+-- uses gzip compression+instance Packable (Map ByteString [ByteString]) where+        readPacked ps = M.fromList (readKV ( P.lines . gunzip $ ps))+             where+                readKV :: [ByteString] -> [(ByteString,[ByteString])]+                readKV []       =  []+                readKV (k:rest) = let (vs, rest') = break (== P.empty) rest+                                  in  (k,vs) : readKV (drop 1 rest')++        showPacked m = gzip+                     . P.unlines+                     . concatMap (\(k,vs) -> k : vs ++ [P.empty]) $ M.toList m++-- assumes single line second strings+instance Packable (Map ByteString ByteString) where+        readPacked ps = M.fromList (readKV (P.lines . gunzip $ ps))+                where+                  readKV :: [ByteString] -> [(ByteString,ByteString)]+                  readKV []         = []+                  readKV (k:v:rest) = (k,v) : readKV rest+                  readKV _      = error "Serial.readPacked: parse failed"++        showPacked m  = gzip. P.unlines . concatMap (\(k,v) -> [k,v]) $ M.toList m++instance Packable ([(ByteString,ByteString)]) where+        readPacked ps = readKV (P.lines . gunzip $ ps)+                where+                  readKV :: [ByteString] -> [(ByteString,ByteString)]+                  readKV []         = []+                  readKV (k:v:rest) = (k,v) : readKV rest+                  readKV _          = error "Serial.readPacked: parse failed"++        showPacked = gzip . P.unlines . concatMap (\(k,v) -> [k,v])++instance Packable (M.Map P.ByteString (Bool, [(String, Int)])) where+    readPacked = M.fromList . readKV . P.lines+        where+          readKV :: [P.ByteString] -> [(P.ByteString,(Bool, [(String, Int)]))]+          readKV []         = []+          readKV (k:v:rest) = (k, (read . P.unpack) v) : readKV rest+          readKV _          = error "Vote.readPacked: parse failed"++    showPacked m = P.unlines . concatMap (\(k,v) -> [k,P.pack . show $ v]) $ M.toList m++-- And for packed string maps+mapPackedSerial :: Serial (Map ByteString ByteString)+mapPackedSerial = Serial (Just . showPacked) (Just . readPacked)++-- And for list of packed string maps+mapListPackedSerial :: Serial (Map ByteString [ByteString])+mapListPackedSerial = Serial (Just . showPacked) (Just . readPacked)++-- And for association list+assocListPackedSerial :: Serial ([(ByteString,ByteString)])+assocListPackedSerial = Serial (Just . showPacked) (Just . readPacked)++------------------------------------------------------------------------

@@ -0,0 +1,131 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}++-- | The signal story.+-- Posix signals are external events that invoke signal handlers in+-- Haskell. The signal handlers in turn throw dynamic exceptions.  Our+-- instance of MonadError for LB maps the dynamic exceptions to+-- SignalCaughts, which can then be caught by a normal catchError++-- Here's where we do that.+module Lambdabot.Util.Signals+    ( Signal+    , SignalException(..)+    , ircSignalMessage+    , withIrcSignalCatch+    ) where++import Data.Typeable+import Control.Exception (Exception)++#ifdef mingw32_HOST_OS++import Control.Monad.Trans.Control++type Signal = String+newtype SignalException = SignalException Signal deriving (Show, Typeable)+instance Exception SignalException++ircSignalMessage :: Signal -> [Char]+ircSignalMessage s = s++withIrcSignalCatch :: MonadBaseControl IO m => m a -> m a+withIrcSignalCatch m = m++#else++import Control.Concurrent.Lifted (myThreadId, newEmptyMVar, putMVar, MVar, ThreadId)+import Control.Exception.Lifted (bracket, throwTo)+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control++import System.IO.Unsafe+import System.Posix.Signals++newtype SignalException = SignalException Signal deriving (Show, Typeable)+instance Exception SignalException++--+-- A bit of sugar for installing a new handler+--+withHandler :: MonadBaseControl IO m => Signal -> Handler -> m a -> m a+withHandler s h m = bracket+    (liftBase (installHandler s h Nothing))+    (liftBase . flip (installHandler s) Nothing)+    (const m)++-- And more sugar for installing a list of handlers+withHandlerList :: MonadBaseControl IO m => [Signal] -> (Signal -> Handler) -> m a -> m a+withHandlerList sl h m = foldr (withHandler `ap` h) m sl++--+-- Signals we care about. They're all fatal.+--+-- Be careful adding signals, some signals can't be caught and+-- installHandler just raises an exception if you try+--+ircSignalsToCatch :: [(Signal, String)]+ircSignalsToCatch = +    [ (busError,              "SIGBUS"  )+    , (segmentationViolation, "SIGSEGV" )+    , (keyboardSignal,        "SIGINT"  )+    , (softwareTermination,   "SIGTERM" )+    , (keyboardTermination,   "SIGQUIT" )+    , (lostConnection,        "SIGHUP"  )+    , (internalAbort,         "SIGABRT" )+    ]++--+-- User friendly names for the signals that we can catch+--+ircSignalMessage :: Signal -> String+ircSignalMessage sig = case lookup sig ircSignalsToCatch of+    Just sigName -> sigName+    Nothing      -> "killed by unknown signal"++--+-- The actual signal handler. It is this function we register for each+-- signal flavour. On receiving a signal, the signal handler maps the+-- signal to a a dynamic exception, and throws it out to the main+-- thread. The LB MonadError instance can then do its trickery to catch+-- it in handler/catchError+--+ircSignalHandler :: ThreadId -> Signal -> Handler+ircSignalHandler threadid s+    = CatchOnce $ do+        putMVar catchLock ()+        releaseSignals+        throwTo threadid $ SignalException s++--+-- | Release all signal handlers+--+releaseSignals :: IO ()+releaseSignals = sequence_ +    [ installHandler sig Default Nothing+    | (sig, _) <- ircSignalsToCatch+    ]++--+-- Mututally exclusive signal handlers+--+-- This is clearly a hack, but I have no idea how to accomplish the same+-- thing correctly. The main problem is that signals are often thrown+-- multiple times, and the threads start killing each other if we allow+-- the SignalException to be thrown more than once.+{-# NOINLINE catchLock #-}+catchLock :: MVar ()+catchLock = unsafePerformIO newEmptyMVar++--+-- | Register signal handlers to catch external signals+--+withIrcSignalCatch :: MonadBaseControl IO m => m a -> m a+withIrcSignalCatch m = do+    _ <- liftBase $ installHandler sigPIPE Ignore Nothing+    _ <- liftBase $ installHandler sigALRM Ignore Nothing+    threadid <- myThreadId+    withHandlerList (map fst ircSignalsToCatch) (ircSignalHandler threadid) m+#endif