lambdabot-core-5.1/0000755000000000000000000000000012722676543012436 5ustar0000000000000000lambdabot-core-5.1/LICENSE0000644000000000000000000000225612722676543013450 0ustar0000000000000000Copyright (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. lambdabot-core-5.1/COMMENTARY.md0000644000000000000000000001241012722676543014434 0ustar0000000000000000COMMENTARY 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 hierarchy ---------------------------------- **outdated**: this section predates the split of lambdabot into several subpackages - 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. lambdabot-core-5.1/README.md0000644000000000000000000000764712722676543013733 0ustar0000000000000000lambdabot ![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 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. lambdabot-core-5.1/lambdabot-core.cabal0000644000000000000000000001041212722676543016273 0ustar0000000000000000name: lambdabot-core version: 5.1 license: GPL license-file: LICENSE author: Don Stewart maintainer: James Cook 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.8.4, GHC == 7.10.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.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.2.*, dependent-sum == 0.3.*, 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 >= 1.0, mtl >= 2, network >= 2.3.0.13, time >= 1.4, parsec >= 3, prim-uniq == 0.1.*, random >= 1, random-fu >= 0.2, random-source >= 0.3, regex-tdfa >= 1.1, SafeSemaphore >= 0.9, split >= 0.2, syb >= 0.3, template-haskell >= 2.7, transformers >= 0.2, transformers-base >= 0.4, utf8-string >= 0.3, zlib >= 0.5 if !os(windows) build-depends: unix >= 2.5 lambdabot-core-5.1/Setup.hs0000644000000000000000000000014212722676543014067 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-core-5.1/AUTHORS.md0000644000000000000000000000562012722676543014110 0ustar0000000000000000AUTHORS ======== The following people have made contributions to the Lambdabot project. There are probably others as well. * Andrew J. Bromage aka Pseudonym on #haskell - the 'bot itself - @free * Shae M. Erisson aka shapr on #haskell - FactModule - FortuneModule - StateModule - SystemModule * Taylor Campbell aka Riastradh on #haskell - KarmaModule * Derek Elkins aka Darius on #haskell - EvalModule * Sven M. Hallberg aka pesco on #haskell - TopicModule * Tom Moertel aka tmoertel on #haskell - DictModule * Mats-Ola Persson aka polli on #haskell - rewrite of the plugin system * Ganesh Sittampalam aka Heffalump on #haskell - Various restructuring to improve bot robustness - Dynamic module loading * Don Stewart 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 aka jlouis on #haskell - Code/Documentation cleanups * Thomas Jäger aka TheHunter on #haskell - PlModule - General hacking/refactoring. * Stefan Wehr 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 - Minor fixed and workarounds - @gsite * David House - Instances, Tell. * Pete Kazmier - Url page title chaser - Contextual messages * Stefan O'Rear aka sorear on #haskell - @nazi-on, @nazi-off, @activity - Non-flat nick namespace - Separation of servers out of base * Spencer Janssen aka sjanssen on #haskell - @undo, @redo * Gwern Branwen aka gwern on #haskell - Packaging of unlambda and brainfuck * James Cook aka mokus on #haskell - Stuff. I dedicate all my contributions to the public domain. * Jan Stolarek aka killy9999 on #haskell - More stuff, mostly code cleanup. lambdabot-core-5.1/src/0000755000000000000000000000000012722676543013225 5ustar0000000000000000lambdabot-core-5.1/src/Lambdabot/0000755000000000000000000000000012722676543015112 5ustar0000000000000000lambdabot-core-5.1/src/Lambdabot/Util.hs0000644000000000000000000001300212722676543016357 0ustar0000000000000000-- 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 confirmationlambdabot-core-5.1/src/Lambdabot/File.hs0000644000000000000000000000644612722676543016337 0ustar0000000000000000-- | Manage lambdabot's state files. There are three relevant directories: -- -- * local: @./State/@ (configurable, see `outputDir`) -- * home: @~/.lambdabot/State/@ -- * data: relative to the data directory of the @lambdabot@ package. -- -- Files are stored locally if the directory exists; otherwise, in the home -- directory. When reading a state file, and the file exists in the data -- directory but nowhere else, then it is picked up from the data directory. module Lambdabot.File ( stateDir , findLBFileForReading , findLBFileForWriting , findOrCreateLBFile , findLBFile -- deprecated , outputDir ) where import Lambdabot.Config import Lambdabot.Config.Core import Lambdabot.Monad import Lambdabot.Util import Control.Applicative import Control.Monad import System.Directory import System.FilePath lambdabot :: FilePath lambdabot = ".lambdabot" -- | Locate state directory. Returns the local directory if it exists, -- and the home directory otherwise. stateDir :: LB FilePath stateDir = do -- look locally output <- getConfig outputDir b <- io $ doesDirectoryExist output if b then return output else homeDir homeDir :: LB FilePath homeDir = do output <- getConfig outputDir home <- io getHomeDirectory return $ home lambdabot output -- | Look for the file in the local, home, and data directories. findLBFileForReading :: FilePath -> LB (Maybe FilePath) findLBFileForReading f = do state <- stateDir home <- homeDir output <- getConfig outputDir rodir <- getConfig dataDir findFirstFile [state f, home f, rodir output f] -- | Return file name for writing state. The file will reside in the -- state directory (`stateDir`), and `findLBFileForWriting` ensures that -- the state directory exists. findLBFileForWriting :: FilePath -> LB FilePath findLBFileForWriting f = do state <- stateDir -- ensure that the directory exists io $ createDirectoryIfMissing True state success <- io $ doesDirectoryExist state when (not success) $ fail $ concat ["Unable to create directory ", state] return $ state f findFirstFile :: [FilePath] -> LB (Maybe FilePath) findFirstFile [] = return Nothing findFirstFile (path:ps) = do b <- io $ doesFileExist path if b then return (Just path) else findFirstFile ps {-# DEPRECATED findLBFile "Use `findLBFileForReading` or `findLBFileForWriting` instead" #-} -- | Try to find a pre-existing file, searching first in the local or home -- directory (but not in the data directory) findLBFile :: FilePath -> LB (Maybe String) findLBFile f = do state <- stateDir home <- homeDir findFirstFile [state f, home f] -- | This returns the same file name as `findLBFileForWriting`. -- If the file does not exist, it is either copied from the data (or home) -- directory, if a copy is found there; otherwise, an empty file is -- created instead. findOrCreateLBFile :: FilePath -> LB String findOrCreateLBFile f = do outFile <- findLBFileForWriting f b <- io $ doesFileExist outFile when (not b) $ do -- the file does not exist; populate it from home or data directory b <- findLBFileForReading f case b of Nothing -> io $ writeFile outFile "" Just roFile -> io $ copyFile roFile outFile return outFile lambdabot-core-5.1/src/Lambdabot/Config.hs0000644000000000000000000000747312722676543016666 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} -- | Extensible configuration system for lambdabot -- -- TODO: there's notthing lambdabot-specific about this, it could be a useful standalone library. module Lambdabot.Config ( Config , getConfigDefault , mergeConfig , MonadConfig(..) , config , configWithMerge ) where 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 Data.Generics (everywhere, mkT) import Language.Haskell.TH data Config t where Config :: (Typeable1 k, GCompare k) => !(k t) -> t -> (t -> t -> t) -> Config t 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) let patchNames :: Name -> Name patchNames (nameBase -> "keyName") = keyName patchNames (nameBase -> "TyName") = tyName patchNames (nameBase -> "ConName") = conName patchNames d = d decs <- everywhere (mkT patchNames) <$> [d| data TyName a = a ~ $(tyQ) => ConName deriving Typeable keyName :: Config $(tyQ) keyName = Config ConName $(defValQ) $(mergeQ) |] concat <$> sequence [ return decs , deriveGEq (head decs) , deriveGCompare (head decs) ] lambdabot-core-5.1/src/Lambdabot/Module.hs0000644000000000000000000001046412722676543016700 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Lambdabot.Module ( Module(..) , newModule , ModuleID , newModuleID , ModuleInfo(..) , ModuleT , runModuleT ) 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(..), asks) import Control.Monad.Trans (MonadTrans(..), MonadIO(..)) import Control.Monad.Trans.Control import Data.Unique.Tag 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" } newtype ModuleID st = ModuleID (Tag RealWorld st) deriving (GEq, GCompare) newModuleID :: IO (ModuleID st) newModuleID = ModuleID <$> newTag -- |Info about a running module. data ModuleInfo st = ModuleInfo { moduleName :: !String , moduleID :: !(ModuleID st) , theModule :: !(Module st) , moduleState :: !(MVar st) } -- | This transformer encodes the additional information a module might -- need to access its name or its state. newtype ModuleT st m a = ModuleT { unModuleT :: ReaderT (ModuleInfo st) m a } deriving (Applicative, Functor, Monad, MonadReader (ModuleInfo st), MonadTrans, MonadIO, MonadException, MonadConfig) runModuleT :: ModuleT st m a -> ModuleInfo st -> m a runModuleT = runReaderT . unModuleT instance MonadLogging m => MonadLogging (ModuleT st m) where getCurrentLogger = do parent <- lift getCurrentLogger self <- asks moduleName 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 type StT (ModuleT st) a = a liftWith f = do r <- ModuleT ask lift $ f $ \t -> runModuleT t r restoreT = lift {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (ModuleT st m) where type StM (ModuleT st m) a = ComposeSt (ModuleT st) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} lambdabot-core-5.1/src/Lambdabot/State.hs0000644000000000000000000001627512722676543016541 0ustar0000000000000000{-# 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 , 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.Reader 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 <- asks moduleState 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 -- -- | Peristence: write the global state out writeGlobalState :: ModuleT st LB () writeGlobalState = do m <- asks theModule mName <- asks moduleName debugM ("saving state for module " ++ show mName) case moduleSerialize m of Nothing -> return () Just ser -> do state' <- readMS case serialize ser state' of Nothing -> return () -- do not write any state Just out -> do stateFile <- lb (findLBFileForWriting mName) 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 <- findLBFileForReading 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 lambdabot-core-5.1/src/Lambdabot/Plugin.hs0000644000000000000000000000335412722676543016711 0ustar0000000000000000-- -- 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 , 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 lambdabot-core-5.1/src/Lambdabot/Bot.hs0000644000000000000000000001132612722676543016175 0ustar0000000000000000{-# 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 , checkPrivs , checkIgnore , ircCodepage , ircGetChannels , ircQuit , ircReconnect , ircPrivmsg , ircPrivmsg' ) where import Lambdabot.ChanName import Lambdabot.Config import Lambdabot.Config.Core import Lambdabot.IRC import Lambdabot.Logging import Lambdabot.Message import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Nick import Lambdabot.State import Control.Concurrent import Control.Exception.Lifted as E 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 :: String -> Module st -> LB () ircLoadModule mName m = do infoM ("Loading module " ++ show mName) savedState <- readGlobalState m mName mState <- maybe (moduleDefState m) return savedState mInfo <- registerModule mName m mState flip runModuleT mInfo (do moduleInit m registerCommands =<< moduleCmds m) `E.catch` \e@SomeException{} -> do errorM ("Module " ++ show mName ++ " failed to load. Exception thrown: " ++ show e) unregisterModule mName fail "Refusing to load due to a broken plugin" -- -- | Unregister a module's entry in the irc state -- ircUnloadModule :: String -> LB () ircUnloadModule mName = do infoM ("Unloading module " ++ show mName) inModuleNamed mName (fail "module not loaded") $ do m <- asks theModule when (moduleSticky m) $ fail "module is sticky" moduleExit m `E.catch` \e@SomeException{} -> errorM ("Module " ++ show mName ++ " threw the following exception in moduleExit: " ++ show e) writeGlobalState unregisterModule mName ------------------------------------------------------------------------ -- | Checks whether the given user has admin permissions checkPrivs :: IrcMessage -> LB Bool checkPrivs msg = gets (S.member (nick msg) . ircPrivilegedUsers) -- | Checks whether the given user is being ignored. -- Privileged users can't be ignored. checkIgnore :: IrcMessage -> LB Bool checkIgnore msg = liftM2 (&&) (liftM not (checkPrivs msg)) (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' { ircPersists = M.delete svr $ ircPersists state' } send $ quit svr msg liftIO $ threadDelay 1000 noticeM "Quitting" ircReconnect :: String -> String -> LB () ircReconnect svr msg = do modify $ \state' -> state' { ircPersists = M.insertWith (flip const) svr False $ ircPersists state' } send $ quit svr msg liftIO $ threadDelay 1000 -- | Send a message to a channel\/user, applying all output filters ircPrivmsg :: Nick -- ^ The channel\/user. -> String -- ^ The message. -> LB () ircPrivmsg who msg = do sendlines <- applyOutputFilters who msg w <- getConfig textWidth mapM_ (\s -> ircPrivmsg' who (take w s)) (take 10 sendlines) -- A raw send version (bypasses output filters) ircPrivmsg' :: Nick -> String -> LB () ircPrivmsg' who "" = ircPrivmsg' who " " ircPrivmsg' who msg = send $ privmsg who msg ------------------------------------------------------------------------ monadRandom [d| instance MonadRandom LB where getRandomWord8 = liftIO getRandomWord8 getRandomWord16 = liftIO getRandomWord16 getRandomWord32 = liftIO getRandomWord32 getRandomWord64 = liftIO getRandomWord64 getRandomDouble = liftIO getRandomDouble getRandomNByteInteger n = liftIO (getRandomNByteInteger n) |] lambdabot-core-5.1/src/Lambdabot/Message.hs0000644000000000000000000000132412722676543017032 0ustar0000000000000000-- -- 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 lambdabot-core-5.1/src/Lambdabot/Nick.hs0000644000000000000000000000266212722676543016340 0ustar0000000000000000module 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' lambdabot-core-5.1/src/Lambdabot/ChanName.hs0000644000000000000000000000054112722676543017120 0ustar0000000000000000module 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 lambdabot-core-5.1/src/Lambdabot/Command.hs0000644000000000000000000001015412722676543017025 0ustar0000000000000000{-# 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 type StT Cmd a = (a, [String]) liftWith f = do r <- Cmd ask lift $ f $ \t -> runWriterT (runReaderT (unCmd t) r) restoreT = Cmd . lift . WriterT {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (Cmd m) where type StM (Cmd m) a = ComposeSt Cmd m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# 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)lambdabot-core-5.1/src/Lambdabot/Logging.hs0000644000000000000000000000313612722676543017037 0ustar0000000000000000module 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 lambdabot-core-5.1/src/Lambdabot/Monad.hs-boot0000644000000000000000000000046312722676543017450 0ustar0000000000000000{-# 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 lambdabot-core-5.1/src/Lambdabot/Monad.hs0000644000000000000000000002766012722676543016517 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Lambdabot.Monad ( IRCRState , initRoState , reportInitDone , waitForInit , waitForQuit , Callback , OutputFilter , Server , IRCRWState(..) , initRwState , LB , runLB , MonadLB(..) , registerModule , registerCommands , registerCallback , registerOutputFilter , unregisterModule , registerServer , unregisterServer , send , received , applyOutputFilters , inModuleNamed , inModuleWithID , withCommand , listModules , 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.Util import Control.Applicative import Control.Concurrent.Lifted import Control.Exception.Lifted as E (catch) import Control.Monad.Base import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Control import qualified Data.Dependent.Map as D import Data.Dependent.Sum import Data.IORef import Data.Some import qualified Data.Map as M import qualified Data.Set as S import System.Console.Haskeline.MonadException (MonadException) ------------------------------------------------------------------------ -- -- Lambdabot state -- -- | Global read-only state. data IRCRState = IRCRState { ircInitDoneMVar :: MVar () , ircQuitMVar :: MVar () , ircConfig :: D.DMap Config Identity } -- | Default ro state initRoState :: [D.DSum Config Identity] -> IO IRCRState initRoState configuration = do quitMVar <- newEmptyMVar initDoneMVar <- newEmptyMVar let mergeConfig' k (Identity x) (Identity y) = Identity (mergeConfig k y x) return IRCRState { ircQuitMVar = quitMVar , ircInitDoneMVar = initDoneMVar , ircConfig = D.fromListWithKey mergeConfig' configuration } reportInitDone :: LB () reportInitDone = do mvar <- LB (asks (ircInitDoneMVar . fst)) io $ putMVar mvar () askLB :: MonadLB m => (IRCRState -> a) -> m a askLB f = lb . LB $ asks (f . fst) waitForInit :: MonadLB m => m () waitForInit = readMVar =<< askLB ircInitDoneMVar waitForQuit :: MonadLB m => m () waitForQuit = readMVar =<< askLB ircQuitMVar type Callback st = IrcMessage -> ModuleT st LB () type OutputFilter st = Nick -> [String] -> ModuleT st LB [String] type Server st = IrcMessage -> ModuleT st LB () newtype CallbackRef st = CallbackRef (Callback st) newtype CommandRef st = CommandRef (Command (ModuleT st LB)) newtype OutputFilterRef st = OutputFilterRef (OutputFilter st) newtype ServerRef st = ServerRef (Server st) -- | Global read\/write state. data IRCRWState = IRCRWState { ircServerMap :: M.Map String (DSum ModuleID ServerRef) , ircPrivilegedUsers :: S.Set Nick , ircIgnoredUsers :: S.Set Nick , ircChannels :: M.Map ChanName String -- ^ maps channel names to topics , ircPersists :: M.Map String Bool -- ^ lists servers to which to reconnect on failure (one-time or always) , ircModulesByName :: M.Map String (Some ModuleInfo) , ircModulesByID :: D.DMap ModuleID ModuleInfo , ircCallbacks :: M.Map String (D.DMap ModuleID CallbackRef) , ircOutputFilters :: [DSum ModuleID OutputFilterRef] -- ^ Output filters, invoked from right to left , ircCommands :: M.Map String (DSum ModuleID CommandRef) } -- | Default rw state initRwState :: IRCRWState initRwState = IRCRWState { ircPrivilegedUsers = S.empty , ircIgnoredUsers = S.empty , ircChannels = M.empty , ircPersists = M.empty , ircModulesByName = M.empty , ircModulesByID = D.empty , ircServerMap = M.empty , ircCallbacks = M.empty , ircOutputFilters = [] , ircCommands = M.empty } -- --------------------------------------------------------------------- -- -- 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 { unLB :: ReaderT (IRCRState, IORef IRCRWState) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadException) runLB :: LB a -> (IRCRState, IORef IRCRWState) -> IO a runLB = runReaderT . unLB instance MonadBase IO LB where liftBase = LB . liftBase instance MonadBaseControl IO LB where type StM LB a = StM (ReaderT (IRCRState,IORef IRCRWState) IO) a liftBaseWith action = LB (liftBaseWith (\run -> action (run . unLB))) restoreM = LB . restoreM 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 state f = LB $ do ref <- asks snd lift . atomicModifyIORef ref $ \s -> let (s', x) = f s in seq s' (x, s') instance MonadConfig LB where getConfig k = liftM (maybe (getConfigDefault k) runIdentity . D.lookup k) (lb (askLB ircConfig)) instance MonadLogging LB where getCurrentLogger = getConfig lbRootLoggerPath logM a b c = io (logM a b c) --------------- -- state management (registering/unregistering various things) registerModule :: String -> Module st -> st -> LB (ModuleInfo st) registerModule mName m mState = do mTag <- io newModuleID mInfo <- ModuleInfo mName mTag m <$> newMVar mState modify $ \s -> s { ircModulesByName = M.insert mName (This mInfo) (ircModulesByName s) , ircModulesByID = D.insert mTag mInfo (ircModulesByID s) } return mInfo registerCommands :: [Command (ModuleT st LB)] -> ModuleT st LB () registerCommands cmds = do mTag <- asks moduleID let taggedCmds = [ (cName, mTag :=> CommandRef cmd) | cmd <- cmds , cName <- cmdNames cmd ] lift $ modify $ \s -> s { ircCommands = M.union (M.fromList taggedCmds) (ircCommands s) } registerCallback :: String -> Callback st -> ModuleT st LB () registerCallback str f = do mTag <- asks moduleID lift . modify $ \s -> s { ircCallbacks = M.insertWith D.union str (D.singleton mTag (CallbackRef f)) (ircCallbacks s) } registerOutputFilter :: OutputFilter st -> ModuleT st LB () registerOutputFilter f = do mTag <- asks moduleID lift . modify $ \s -> s { ircOutputFilters = (mTag :=> OutputFilterRef f) : ircOutputFilters s } unregisterModule :: String -> LB () unregisterModule mName = maybe (return ()) warningM <=< state $ \s -> case M.lookup mName (ircModulesByName s) of Nothing -> (Just $ "Tried to unregister module that wasn't registered: " ++ show mName, s) Just (This modInfo) -> let mTag = moduleID modInfo notThisTag :: DSum ModuleID f -> Bool notThisTag (tag :=> _) = This tag /= This mTag s' = s { ircModulesByName = M.delete mName (ircModulesByName s) , ircModulesByID = D.delete mTag (ircModulesByID s) , ircCommands = M.filter notThisTag (ircCommands s) , ircCallbacks = M.map (D.delete mTag) (ircCallbacks s) , ircServerMap = M.filter notThisTag (ircServerMap s) , ircOutputFilters = filter notThisTag (ircOutputFilters s) } in (Nothing, s') -- The virtual chat system. -- -- The virtual chat system sits between the chat drivers and the rest of -- Lambdabot. It provides a mapping between the String server "tags" and -- functions which are able to handle sending messages. -- -- When a message is recieved, the chat module is expected to call -- `Lambdabot.Main.received'. This is not ideal. registerServer :: String -> Server st -> ModuleT st LB () registerServer sName sendf = do mTag <- asks moduleID maybe (return ()) fail <=< lb . state $ \s -> case M.lookup sName (ircServerMap s) of Just _ -> (Just $ "attempted to create two servers named " ++ sName, s) Nothing -> let s' = s { ircServerMap = M.insert sName (mTag :=> ServerRef sendf) (ircServerMap s)} in (Nothing, s') -- TODO: fix race condition unregisterServer :: String -> ModuleT mod LB () unregisterServer tag = lb $ do s <- get let svrs = ircServerMap s case M.lookup tag svrs of Just _ -> do let svrs' = M.delete tag svrs put (s { ircServerMap = svrs' }) when (M.null svrs') $ do quitMVar <- askLB ircQuitMVar io $ putMVar quitMVar () Nothing -> fail $ "attempted to delete nonexistent servers named " ++ tag withUEHandler :: LB () -> LB () withUEHandler f = do handler <- getConfig uncaughtExceptionHandler E.catch f (io . handler) send :: IrcMessage -> LB () send msg = do s <- gets ircServerMap let bogus = warningM $ "sending message to bogus server: " ++ show msg case M.lookup (Msg.server msg) s of Just (mTag :=> ServerRef sendf) -> withUEHandler (inModuleWithID mTag bogus (sendf msg)) Nothing -> bogus received :: IrcMessage -> LB () received msg = do s <- get case M.lookup (ircMsgCommand msg) (ircCallbacks s) of Just cbs -> forM_ (D.toList cbs) $ \(tag :=> CallbackRef cb) -> withUEHandler (inModuleWithID tag (return ()) (cb msg)) _ -> return () applyOutputFilter :: Nick -> DSum ModuleID OutputFilterRef -> [String] -> LB [String] applyOutputFilter who (mTag :=> OutputFilterRef f) msg = inModuleWithID mTag (return msg) (f who msg) applyOutputFilters :: Nick -> String -> LB [String] applyOutputFilters who msg = do filters <- gets ircOutputFilters foldr (\a x -> applyOutputFilter who a =<< x) ((return . lines) msg) filters ------------------------------------------------------------------------ -- Module handling -- | Interpret an expression in the context of a module. inModuleNamed :: String -> LB a -> (forall st. ModuleT st LB a) -> LB a inModuleNamed name nothing just = do mbMod <- gets (M.lookup name . ircModulesByName) case mbMod of Nothing -> nothing Just (This modInfo) -> runModuleT just modInfo inModuleWithID :: ModuleID st -> LB a -> (ModuleT st LB a) -> LB a inModuleWithID tag nothing just = do mbMod <- gets (D.lookup tag . ircModulesByID ) case mbMod of Nothing -> nothing Just modInfo -> runModuleT just modInfo withCommand :: String -> LB a -> (forall st. Command (ModuleT st LB) -> ModuleT st LB a) -> LB a withCommand cmdname def f = do mbCmd <- gets (M.lookup cmdname . ircCommands) case mbCmd of Just (tag :=> CommandRef cmd) -> inModuleWithID tag def (f cmd) _ -> def listModules :: LB [String] listModules = gets (M.keys . ircModulesByName) -- | Interpret a function in the context of all modules withAllModules :: (forall st. ModuleT st LB a) -> LB () withAllModules f = do mods <- gets $ M.elems . ircModulesByName forM_ mods $ \(This modInfo) -> runModuleT f modInfo lambdabot-core-5.1/src/Lambdabot/Main.hs0000644000000000000000000000637212722676543016342 0ustar0000000000000000{-# 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.Util import Lambdabot.Util.Signals import Control.Exception.Lifted as E import Control.Monad.Identity import Data.Dependent.Sum import Data.List import Data.IORef import Data.Some import Data.Version import Language.Haskell.TH import Paths_lambdabot_core (version) 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 :: Modules -> [DSum Config Identity] -> IO ExitCode lambdabotMain initialise cfg = withSocketsDo . withIrcSignalCatch $ do rost <- initRoState cfg rwst <- newIORef initRwState runLB (lambdabotRun initialise) (rost, rwst) `E.catch` \e -> do -- clean up and go home case fromException e of Just code -> return code Nothing -> do errorM (show e) return (ExitFailure 1) lambdabotRun :: Modules -> LB ExitCode lambdabotRun ms = do setupLogging infoM "Initialising plugins" withModules ms $ do infoM "Done loading plugins" reportInitDone waitForQuit `E.catch` (\e@SomeException{} -> errorM (show e)) -- catch anything, print informative message, and clean up -- clean up any dynamically loaded modules mapM_ ircUnloadModule =<< listModules return ExitSuccess ------------------------------------------------------------------------ type Modules = [(String, Some Module)] modules :: [String] -> Q Exp modules xs = [| $(listE $ map instalify (nub xs)) |] where instalify x = let module' = varE $ mkName (x ++ "Plugin") in [| (x, This $module') |] withModules :: Modules -> LB a -> LB a withModules [] = id withModules ((n, This m):ms) = withModule n m . withModules ms withModule :: String -> Module st -> LB a -> LB a withModule name m = bracket_ (ircLoadModule name m) (ircUnloadModule name) lambdabot-core-5.1/src/Lambdabot/IRC.hs0000644000000000000000000001014512722676543016064 0ustar0000000000000000-- -- | 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. -- -- Note that the strings here are treated as lists of bytes! 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!" } 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_] lambdabot-core-5.1/src/Lambdabot/Compat/0000755000000000000000000000000012722676543016335 5ustar0000000000000000lambdabot-core-5.1/src/Lambdabot/Compat/PackedNick.hs0000644000000000000000000000143112722676543020664 0ustar0000000000000000module 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 lambdabot-core-5.1/src/Lambdabot/Compat/FreenodeNick.hs0000644000000000000000000000225712722676543021233 0ustar0000000000000000-- | 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) lambdabot-core-5.1/src/Lambdabot/Compat/AltTime.hs0000644000000000000000000001414712722676543020237 0ustar0000000000000000-- | 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) lambdabot-core-5.1/src/Lambdabot/Util/0000755000000000000000000000000012722676543016027 5ustar0000000000000000lambdabot-core-5.1/src/Lambdabot/Util/Signals.hs0000644000000000000000000000766412722676543020000 0ustar0000000000000000{-# 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 lambdabot-core-5.1/src/Lambdabot/Util/Serial.hs0000644000000000000000000001312512722676543017604 0ustar0000000000000000{-# 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) ------------------------------------------------------------------------ lambdabot-core-5.1/src/Lambdabot/Plugin/0000755000000000000000000000000012722676543016350 5ustar0000000000000000lambdabot-core-5.1/src/Lambdabot/Plugin/Core.hs0000644000000000000000000000115512722676543017576 0ustar0000000000000000module 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"] lambdabot-core-5.1/src/Lambdabot/Plugin/Core/0000755000000000000000000000000012722676543017240 5ustar0000000000000000lambdabot-core-5.1/src/Lambdabot/Plugin/Core/System.hs0000644000000000000000000001556212722676543021071 0ustar0000000000000000-- | 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.Module import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util import Control.Monad.Reader import Control.Monad.State (gets, modify) 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 = \_ -> say . showClean =<< lb listModules } , (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 . 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 =<< lb listModules } , (command "join") { privileged = True , help = say "join " , process = \rest -> do chan <- readNick rest lb $ send (joinChannel chan) } , (command "part") { privileged = True , help = say "part " , aliases = ["leave"] , process = \rest -> do chan <- readNick rest lb $ send (partChannel chan) } , (command "msg") { privileged = True , help = say "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 " , 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 "disconnect") { privileged = True , help = say "disconnect [msg], disconnect from a server with msg" , process = \rest -> do let (server, msg) = splitFirstWord rest lb (ircQuit server $ if null msg then "requested" else msg) } , (command "flush") { privileged = True , help = say "flush. flush state to disk" , process = \_ -> lb (withAllModules writeGlobalState) } , (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 "reconnect 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 = inModuleNamed s fromCommand printProvides where fromCommand = withCommand s (return $ "No module \""++s++"\" loaded") (const printProvides) printProvides :: ModuleT st LB String printProvides = do cmds <- moduleCmds =<< asks theModule let cmds' = filter (not . privileged) cmds name' <- asks moduleName return . concat $ if null cmds' then [name', " has no visible commands"] else [name', " provides: ", showClean (concatMap cmdNames cmds')] lambdabot-core-5.1/src/Lambdabot/Plugin/Core/More.hs0000644000000000000000000000334412722676543020502 0ustar0000000000000000-- | Support for more(1) buffering module Lambdabot.Plugin.Core.More (morePlugin) where import Lambdabot.Bot import Lambdabot.Monad import Lambdabot.Plugin 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 = registerOutputFilter moreFilter -- TODO: improve output filter system... -- currently, @more output will bypass any filters in the -- chain after 'moreFilter' , 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 lambdabot-core-5.1/src/Lambdabot/Plugin/Core/Help.hs0000644000000000000000000000324512722676543020470 0ustar0000000000000000-- | Provide help for plugins module Lambdabot.Plugin.Core.Help (helpPlugin) where import Lambdabot.Command import Lambdabot.Message (Message) import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util import Control.Monad.Reader helpPlugin :: Module () helpPlugin = newModule { moduleCmds = return [ (command "help") { help = say "help . Ask for help for . 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 (inModuleNamed arg -- else maybe it's a module name (doHelp msg tgt "help") -- else give up (do -- its a module cmds <- moduleCmds =<< asks theModule let ss = cmds >>= cmdNames let s | null ss = arg ++ " is a module." | otherwise = arg ++ " provides: " ++ showClean ss return [s])) -- so it's a valid command, try to find its help (\theCmd -> moduleHelp theCmd msg tgt arg) where (arg:_) = words rest lambdabot-core-5.1/src/Lambdabot/Plugin/Core/OfflineRC.hs0000644000000000000000000001005312722676543021402 0ustar0000000000000000-- | 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, modify ) import Control.Monad.Trans( lift, liftIO ) import Data.Char import qualified Data.Map as M import qualified Data.Set as S import System.Console.Haskeline (InputT, Settings(..), runInputT, defaultSettings, getInputLine) import System.IO import System.Timeout.Lifted import Codec.Binary.UTF8.String -- We need to track the number of active sourcings so that we can -- unregister the server (-> allow the bot to quit) when it is not -- being used. type OfflineRCState = Integer type OfflineRC = ModuleT OfflineRCState LB offlineRCPlugin :: Module OfflineRCState offlineRCPlugin = newModule { moduleDefState = return 0 , moduleInit = do lb . modify $ \s -> s { ircPrivilegedUsers = S.insert (Nick "offlinerc" "null") (ircPrivilegedUsers s) } 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 $ findLBFileForWriting "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 -- note that `msg'` is unicode, but lambdabot wants utf-8 lists of bytes lb . void . timeout (15 * 1000 * 1000) . received $ IrcMessage { ircMsgServer = "offlinerc" , ircMsgLBName = "offline" , ircMsgPrefix = "null!n=user@null" , ircMsgCommand = "PRIVMSG" , ircMsgParams = ["offline", ":" ++ encodeString msg' ] } handleMsg :: IrcMessage -> OfflineRC () handleMsg msg = liftIO $ do let str = case (tail . ircMsgParams) msg of [] -> [] (x:_) -> tail x -- str contains utf-8 list of bytes; convert to unicode hPutStrLn stdout (decodeString 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 (M.member "offlinerc" . ircPersists) when continue replLoop lockRC :: OfflineRC () lockRC = do withMS $ \ cur writ -> do when (cur == 0) $ do registerServer "offlinerc" handleMsg lift $ modify $ \state' -> state' { ircPersists = M.insert "offlinerc" True $ ircPersists state' } writ (cur + 1) unlockRC :: OfflineRC () unlockRC = withMS $ \ cur writ -> do when (cur == 1) $ unregisterServer "offlinerc" writ (cur - 1) lambdabot-core-5.1/src/Lambdabot/Plugin/Core/Version.hs0000644000000000000000000000137412722676543021226 0ustar0000000000000000-- 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 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 ver <- getConfig lbVersion say $ "lambdabot " ++ showVersion ver say "git clone https://github.com/lambdabot/lambdabot" } ] } lambdabot-core-5.1/src/Lambdabot/Plugin/Core/Base.hs0000644000000000000000000003324412722676543020454 0ustar0000000000000000{-# LANGUAGE PatternGuards, FlexibleContexts #-} -- | 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.Module 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.Reader import Control.Monad.State import Data.Char 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 registerOutputFilter cleanOutput registerOutputFilter lineify registerOutputFilter cleanOutput registerCallback "PING" doPING registerCallback "NOTICE" doNOTICE registerCallback "PART" doPART registerCallback "KICK" doKICK registerCallback "JOIN" doJOIN registerCallback "NICK" doNICK registerCallback "MODE" doMODE registerCallback "TOPIC" doTOPIC registerCallback "QUIT" doQUIT registerCallback "PRIVMSG" doPRIVMSG registerCallback "001" doRPL_WELCOME -- registerCallback "002" doRPL_YOURHOST -- registerCallback "003" doRPL_CREATED -- registerCallback "004" doRPL_MYINFO registerCallback "005" doRPL_BOUNCE -- registerCallback "250" doRPL_STATSCONN -- registerCallback "251" doRPL_LUSERCLIENT -- registerCallback "252" doRPL_LUSEROP -- registerCallback "253" doRPL_LUSERUNKNOWN -- registerCallback "254" doRPL_LUSERCHANNELS -- registerCallback "255" doRPL_LUSERME -- registerCallback "265" doRPL_LOCALUSERS -- registerCallback "266" doRPL_GLOBALUSERS registerCallback "332" doRPL_TOPIC -- registerCallback "353" doRPL_NAMRELY -- registerCallback "366" doRPL_ENDOFNAMES -- registerCallback "372" doRPL_MOTD -- registerCallback "375" doRPL_MOTDSTART -- registerCallback "376" doRPL_ENDOFMOTD } doIGNORE :: IrcMessage -> Base () doIGNORE = debugM . show doPING :: IrcMessage -> Base () 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 :: IrcMessage -> Base () 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) -- the empty topic causes problems -- TODO: find out what they are and fix them properly lb . modify $ \s -> s { ircChannels = M.insert (mkCN loc) "[currently unknown]" (ircChannels s)} lb . send $ getTopic loc -- initialize topic where doPART :: IrcMessage -> Base () doPART msg = when (lambdabotName msg == nick msg) $ do let body = ircMsgParams msg loc = Nick (server msg) (head body) lb . modify $ \s -> 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 :: IrcMessage -> Base () doNICK msg = doIGNORE msg doMODE :: IrcMessage -> Base () doMODE msg = doIGNORE msg doTOPIC :: IrcMessage -> Base () doTOPIC msg = lb . modify $ \s -> s { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ ircMsgParams msg) (ircChannels s) } where loc = Nick (server msg) (head (ircMsgParams msg)) doRPL_WELCOME :: IrcMessage -> Base () doRPL_WELCOME msg = lb $ do modify $ \state' -> let persists = if M.findWithDefault True (server msg) (ircPersists state') then ircPersists state' else M.delete (server msg) $ ircPersists state' in state' { ircPersists = persists } chans <- gets ircChannels forM_ (M.keys chans) $ \chan -> do let cn = getCN chan when (nTag cn == server msg) $ do modify $ \state' -> state' { ircChannels = M.delete chan $ ircChannels state' } lb $ send $ joinChannel cn doQUIT :: IrcMessage -> Base () doQUIT msg = doIGNORE msg doRPL_BOUNCE :: IrcMessage -> Base () doRPL_BOUNCE _msg = debugM "BOUNCE!" doRPL_TOPIC :: IrcMessage -> Base () doRPL_TOPIC msg -- nearly the same as doTOPIC but has our nick on the front of body = do let body = ircMsgParams msg loc = Nick (server msg) (body !! 1) lb . modify $ \s -> 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 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 = 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' <- asks moduleName 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 = lb (withAllModules (withHandler invokeContextual)) where withHandler x = E.catch x $ \e@SomeException{} -> do mName <- asks moduleName debugM ("Module " ++ show mName ++ " failed in contextual handler: " ++ show e) invokeContextual = do m <- asks theModule reply <- execCmd (contextual m r) msg target "contextual" lb $ mapM_ (ircPrivmsg towhere) reply ------------------------------------------------------------------------ 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 :: IrcMessage -> LB () doRPL_YOURHOST _msg = return () doRPL_CREATED :: IrcMessage -> LB () doRPL_CREATED _msg = return () doRPL_MYINFO :: IrcMessage -> LB () doRPL_MYINFO _msg = return () doRPL_STATSCONN :: IrcMessage -> LB () doRPL_STATSCONN _msg = return () doRPL_LUSERCLIENT :: IrcMessage -> LB () doRPL_LUSERCLIENT _msg = return () doRPL_LUSEROP :: IrcMessage -> LB () doRPL_LUSEROP _msg = return () doRPL_LUSERUNKNOWN :: IrcMessage -> LB () doRPL_LUSERUNKNOWN _msg = return () doRPL_LUSERCHANNELS :: IrcMessage -> LB () doRPL_LUSERCHANNELS _msg = return () doRPL_LUSERME :: IrcMessage -> LB () doRPL_LUSERME _msg = return () doRPL_LOCALUSERS :: IrcMessage -> LB () doRPL_LOCALUSERS _msg = return () doRPL_GLOBALUSERS :: IrcMessage -> LB () doRPL_GLOBALUSERS _msg = return () doUNKNOWN :: IrcMessage -> Base () doUNKNOWN msg = debugM $ "UNKNOWN> <" ++ msgPrefix msg ++ "> [" ++ msgCommand msg ++ "] " ++ show (body msg) doRPL_NAMREPLY :: IrcMessage -> LB () doRPL_NAMREPLY _msg = return () doRPL_ENDOFNAMES :: IrcMessage -> LB () doRPL_ENDOFNAMES _msg = return () doRPL_MOTD :: IrcMessage -> LB () doRPL_MOTD _msg = return () doRPL_MOTDSTART :: IrcMessage -> LB () doRPL_MOTDSTART _msg = return () doRPL_ENDOFMOTD :: IrcMessage -> LB () doRPL_ENDOFMOTD _msg = return () -} -- Initial output filters -- | For now, this just checks for duplicate empty lines. cleanOutput :: Monad m => a -> [String] -> m [String] cleanOutput _ msg = return $ remDups True msg' where remDups True ([]:xs) = remDups True xs remDups False ([]:xs) = []:remDups True xs remDups _ (x: xs) = x: remDups False xs remDups _ [] = [] msg' = map (dropFromEnd isSpace) msg -- | wrap long lines. lineify :: MonadConfig m => a -> [String] -> m [String] lineify _ msg = do w <- getConfig textWidth return (lines (unlines msg) >>= mbreak w) where -- | break into lines mbreak w xs | null bs = [as] | otherwise = (as++cs) : filter (not . null) (mbreak w ds) where (as,bs) = splitAt (w-n) xs breaks = filter (not . isAlphaNum . last . fst) $ drop 1 $ take n $ zip (inits bs) (tails bs) (cs,ds) = last $ (take n bs, drop n bs): breaks n = 10 lambdabot-core-5.1/src/Lambdabot/Plugin/Core/Compose.hs0000644000000000000000000001416512722676543021210 0ustar0000000000000000{-# 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.Module import Lambdabot.Monad import Lambdabot.Plugin import Control.Arrow (first) import Control.Monad import Control.Monad.Reader 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 [ ". [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 (fail $ "Unknown command: " ++ show cmd) (\theCmd -> do when (privileged theCmd) $ fail "Privileged commands cannot be composed" mTag <- asks moduleID return (inModuleWithID mTag (return []) . runCommand theCmd a b cmd)) ------------------------------------------------------------------------ -- | 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 lambdabot-core-5.1/src/Lambdabot/Config/0000755000000000000000000000000012722676543016317 5ustar0000000000000000lambdabot-core-5.1/src/Lambdabot/Config/Core.hs0000644000000000000000000000452412722676543017550 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} module Lambdabot.Config.Core ( commandPrefixes , disabledCommands , editDistanceLimit , enableInsults , onStartupCmds , outputDir , dataDir , lbVersion , textWidth , uncaughtExceptionHandler , replaceRootLogger , lbRootLoggerPath , consoleLogHandle , consoleLogLevel , consoleLogFormat ) where import Lambdabot.Config import Lambdabot.Logging import Control.Exception import System.IO import Data.Version ------------------------------------- -- 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/" |] -- the dataDir variable will be filled by lambdabot's executable config "dataDir" [t| FilePath |] [| "." |] -- ditto for lbVersion config "lbVersion" [t| Version |] [| Version [] [] |] -- IRC maximum msg length, minus a bit for safety. config "textWidth" [t| Int |] [| 200 :: Int |] -- basic logging. for more complex setups, configure directly using System.Log.Logger config "replaceRootLogger" [t| Bool |] [| True |] 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 |]