lambdabot-core-5.0.3/0000755000000000000000000000000012554503453012566 5ustar0000000000000000lambdabot-core-5.0.3/LICENSE0000644000000000000000000000225612554503453013600 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.0.3/COMMENTARY.md0000644000000000000000000001222712554503453014572 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 heirarchy ---------------------------------- - src/ -- Lambdabot.Compat.* Modules supporting backward-compatibility with older versions of lambdabot (mostly functions to read old serialization formats) -- Lambdabot.Config.* Currently only "Core", this module defines the configuration keys for the lambdabot core system. Packages providing additional plugins are encouraged to use this namespace (or the module in which they are used, if they prefer) for additional configuration key definitions. The configuration system is described above. -- Lambdabot.Plugin.* As the name suggests, all lambdabot plugins are defined in modules under this namespace. -- Lambdabot.Util.* Utility functions for use by lambdabot plugins. This is not considered a stable public interface; I am actively working on eliminating them in favor of external libraries that provide equivalent functionality. -- Lambdabot, Lambdabot.* The core lambdabot system. Like the Util namespace, these are not especially stable right now. - main/ Defines the main lambdabot executable, usable either as-is or as a template for a customized executable. lambdabot-core-5.0.3/README.md0000644000000000000000000000764712554503453014063 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.0.3/lambdabot-core.cabal0000644000000000000000000001031012554503453016420 0ustar0000000000000000name: lambdabot-core version: 5.0.3 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.6.3, GHC == 7.8.3 extra-source-files: AUTHORS.md COMMENTARY.md README.md source-repository head type: git location: https://github.com/lambdabot/lambdabot.git library hs-source-dirs: src ghc-options: -Wall -funbox-strict-fields exposed-modules: Lambdabot.Bot Lambdabot.ChanName Lambdabot.Command Lambdabot.Compat.AltTime Lambdabot.Compat.FreenodeNick Lambdabot.Compat.PackedNick Lambdabot.Config Lambdabot.File Lambdabot.IRC Lambdabot.Logging Lambdabot.Main Lambdabot.Message Lambdabot.Module Lambdabot.Monad Lambdabot.Nick Lambdabot.OutputFilter Lambdabot.Plugin Lambdabot.Plugin.Core Lambdabot.State Lambdabot.Util other-modules: Paths_lambdabot_core Lambdabot.Config.Core Lambdabot.Plugin.Core.Base Lambdabot.Plugin.Core.Compose Lambdabot.Plugin.Core.Help Lambdabot.Plugin.Core.More Lambdabot.Plugin.Core.OfflineRC Lambdabot.Plugin.Core.System Lambdabot.Plugin.Core.Version Lambdabot.Util.Serial Lambdabot.Util.Signals build-depends: base >= 4.4 && < 5, binary >= 0.5, bytestring >= 0.9, containers >= 0.4, dependent-map == 0.1.*, dependent-sum == 0.2.*, dependent-sum-template >= 0.0.0.1, directory >= 1.1, edit-distance >= 0.2, filepath >= 1.3, haskeline >= 0.7, hslogger >= 1.2.1, HTTP >= 4000, lifted-base >= 0.2, monad-control >= 1.0, mtl >= 2, network >= 2.3.0.13, time >= 1.4, parsec >= 3, random >= 1, random-fu >= 0.2, random-source >= 0.3, regex-tdfa >= 1.1, SafeSemaphore >= 0.9, split >= 0.2, template-haskell >= 2.7, transformers >= 0.2, transformers-base >= 0.4, utf8-string >= 0.3, zlib >= 0.5 if !os(windows) build-depends: unix >= 2.5 lambdabot-core-5.0.3/Setup.hs0000644000000000000000000000014212554503453014217 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-core-5.0.3/AUTHORS.md0000644000000000000000000000562012554503453014240 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.0.3/src/0000755000000000000000000000000012554503453013355 5ustar0000000000000000lambdabot-core-5.0.3/src/Lambdabot/0000755000000000000000000000000012554503453015242 5ustar0000000000000000lambdabot-core-5.0.3/src/Lambdabot/Util.hs0000644000000000000000000001300212554503453016507 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.0.3/src/Lambdabot/File.hs0000644000000000000000000000641612554503453016464 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.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.0.3/src/Lambdabot/Config.hs0000644000000000000000000000770112554503453017010 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} -- | Extensible configuration system for lambdabot -- -- TODO: there's notthing lambdabot-specific about this, it could be a useful standalone library. module Lambdabot.Config ( Config , getConfigDefault , mergeConfig , MonadConfig(..) , config , configWithMerge ) where import Control.Applicative import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.State import Data.Char import Data.GADT.Compare import Data.GADT.Compare.TH import Data.Maybe import Data.Typeable import Language.Haskell.TH data Config t where Config :: (Typeable1 k, GCompare k) => !(k t) -> t -> (t -> t -> t) -> Config t cast1 :: (Typeable1 f, Typeable1 g) => f a -> Maybe (g a) cast1 = fmap runIdentity . gcast1 . Identity instance GEq Config where geq (Config k1 _ _) (Config k2 _ _) = do k2' <- cast1 k2 geq k1 k2' instance GCompare Config where gcompare (Config k1 _ _) (Config k2 _ _) = case compare t1 t2 of LT -> GLT EQ -> fromMaybe typeErr $ do k2' <- cast1 k2 return (gcompare k1 k2') GT -> GGT where t1 = typeOf1 k1 t2 = typeOf1 k2 typeErr = error "TypeReps claim to be equal but cast failed" getConfigDefault :: Config t -> t getConfigDefault (Config _ def _) = def mergeConfig :: Config t -> t -> t -> t mergeConfig (Config _ _ f) = f class Monad m => MonadConfig m where getConfig :: Config a -> m a instance MonadConfig m => MonadConfig (ReaderT r m) where getConfig = lift . getConfig instance (MonadConfig m, Monoid w) => MonadConfig (WriterT w m) where getConfig = lift . getConfig instance MonadConfig m => MonadConfig (StateT s m) where getConfig = lift . getConfig -- |Define a new configuration key with the specified name, type and -- default value -- -- You should probably also provide an explicit export list for any -- module that defines config keys, because the definition introduces -- a few extra types that will clutter up the export list otherwise. config :: String -> TypeQ -> ExpQ -> Q [Dec] config = configWithMerge [| flip const |] -- |Like 'config', but also allowing you to specify a \"merge rule\" -- that will be used to combine multiple bindings of the same key. -- -- For example, in "Lambdabot.Config.Core", 'onStartupCmds' is -- defined as a list of commands to execute on startup. Its default -- value is ["offlinerc"], so if a user invokes the default lambdabot -- executable without arguments, they will get a REPL. Each instance -- of "-e" on the command-line adds a binding of the form: -- -- > onStartupCmds :=> [command] -- -- So if they give one "-e", it replaces the default (note that it -- is _not_ merged with the default - the default is discarded), and -- if they give more than one they are merged using the specified -- operation (in this case, `(++)`). configWithMerge :: ExpQ -> String -> TypeQ -> ExpQ -> Q [Dec] configWithMerge mergeQ nameStr tyQ defValQ = do let keyName = mkName nameStr tyName <- newName (map toUpper nameStr) conName <- newName (map toUpper nameStr) tyVarName <- newName "a'" ty <- tyQ defVal <- defValQ mergeExpr <- mergeQ let tyDec = DataD [] tyName [PlainTV tyVarName] [ForallC [] [mkEqualP (VarT tyVarName) ty] (NormalC conName [])] [''Typeable] keyDecs = [ SigD keyName (AppT (ConT ''Config) ty) , ValD (VarP keyName) (NormalB (ConE 'Config `AppE` ConE conName `AppE` defVal `AppE` mergeExpr)) [] ] concat <$> sequence [ return [tyDec] , return keyDecs , deriveGEq tyDec , deriveGCompare tyDec ] mkEqualP :: Type -> Type -> Pred #if __GLASGOW_HASKELL__ > 708 mkEqualP t1 t2 = EqualityT `AppT` t1 `AppT` t2 #else mkEqualP = EqualP #endif lambdabot-core-5.0.3/src/Lambdabot/Module.hs0000644000000000000000000001124212554503453017023 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Lambdabot.Module ( Module(..) , newModule , ModuleT(..) , getRef , getModuleName , bindModule0 , bindModule1 , bindModule2 ) where import qualified Lambdabot.Command as Cmd import Lambdabot.Config import Lambdabot.Logging import {-# SOURCE #-} Lambdabot.Monad import Lambdabot.Util.Serial import Control.Applicative import Control.Concurrent (MVar) import Control.Monad import Control.Monad.Base import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import Control.Monad.Trans (MonadTrans(..), MonadIO(..)) import Control.Monad.Trans.Control import System.Console.Haskeline.MonadException (MonadException) ------------------------------------------------------------------------ -- | The Module type class. data Module st = Module { -- | If the module wants its state to be saved, this function should -- return a Serial. -- -- The default implementation returns Nothing. moduleSerialize :: !(Maybe (Serial st)), -- | If the module maintains state, this method specifies the default state -- (for example in case the state can't be read from a state). -- -- The default implementation returns an error and assumes the state is -- never accessed. moduleDefState :: !(LB st), -- | Is the module sticky? Sticky modules (as well as static ones) can't be -- unloaded. By default, modules are not sticky. moduleSticky :: !Bool, -- | The commands the module listenes to. moduleCmds :: !(ModuleT st LB [Cmd.Command (ModuleT st LB)]), -- | Initialize the module. The default implementation does nothing. moduleInit :: !(ModuleT st LB ()), -- | Finalize the module. The default implementation does nothing. moduleExit :: !(ModuleT st LB ()), -- | Process contextual input. A plugin that implements 'contextual' -- is able to respond to text not part of a normal command. contextual :: !(String -- the text -> Cmd.Cmd (ModuleT st LB) ()) -- ^ the action } ------------------------------------------------------------------------ newModule :: Module st newModule = Module { contextual = \_ -> return () , moduleCmds = return [] , moduleExit = return () , moduleInit = return () , moduleSticky = False , moduleSerialize = Nothing , moduleDefState = return $ error "state not initialized" } -- -- | This transformer encodes the additional information a module might -- need to access its name or its state. -- newtype ModuleT st m a = ModuleT { runModuleT :: ReaderT (MVar st, String) m a } deriving (Applicative, Functor, Monad, MonadTrans, MonadIO, MonadException, MonadConfig) instance MonadLogging m => MonadLogging (ModuleT st m) where getCurrentLogger = do parent <- lift getCurrentLogger self <- getModuleName return (parent ++ ["Plugin", self]) logM a b c = lift (logM a b c) instance MonadBase b m => MonadBase b (ModuleT st m) where liftBase = lift . liftBase instance MonadTransControl (ModuleT st) where type StT (ModuleT st) a = a liftWith f = do r <- ModuleT ask lift $ f $ \t -> runReaderT (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 #-} getRef :: Monad m => ModuleT st m (MVar st) getRef = ModuleT $ ask >>= return . fst getModuleName :: Monad m => ModuleT mod m String getModuleName = ModuleT $ ask >>= return . snd -- | bind an action to the current module so it can be run from the plain -- `LB' monad. bindModule0 :: ModuleT mod LB a -> ModuleT mod LB (LB a) bindModule0 act = bindModule1 (const act) >>= return . ($ ()) -- | variant of `bindModule0' for monad actions with one argument bindModule1 :: (a -> ModuleT mod LB b) -> ModuleT mod LB (a -> LB b) bindModule1 act = ModuleT $ ask >>= \st -> return (\val -> runReaderT (runModuleT $ act val) st) -- | variant of `bindModule0' for monad actions with two arguments bindModule2 :: (a -> b -> ModuleT mod LB c) -> ModuleT mod LB (a -> b -> LB c) bindModule2 act = bindModule1 (uncurry act) >>= return . curry lambdabot-core-5.0.3/src/Lambdabot/State.hs0000644000000000000000000001647112554503453016667 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 , flushModuleState , readGlobalState , writeGlobalState ) where import Lambdabot.File import Lambdabot.Logging import Lambdabot.Monad import Lambdabot.Module import Lambdabot.Nick import Lambdabot.Command import Lambdabot.Util import Lambdabot.Util.Serial import Control.Concurrent.Lifted import Control.Exception.Lifted as E import Control.Monad.Trans import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as P import Data.IORef.Lifted -- | Thread-safe modification of an MVar. withMWriter :: MonadBaseControl IO m => MVar a -> (a -> (a -> m ()) -> m b) -> m b withMWriter mvar f = bracket (do x <- takeMVar mvar; ref <- newIORef x; return (x,ref)) (\(_,ref) -> tryPutMVar mvar =<< readIORef ref) (\(x,ref) -> f x $ writeIORef ref) class MonadLB m => MonadLBState m where type LBState m -- | Update the module's private state. -- This is the preferred way of changing the state. The state will be locked -- until the body returns. The function is exception-safe, i.e. even if -- an error occurs or the thread is killed (e.g. because it deadlocked and -- therefore exceeded its time limit), the state from the last write operation -- will be restored. If the writer escapes, calling it will have no observable -- effect. -- @withMS@ is not composable, in the sense that a readMS from within the body -- will cause a dead-lock. However, all other possibilies to access the state -- that came to my mind had even more serious deficiencies such as being prone -- to race conditions or semantic obscurities. withMS :: (LBState m -> (LBState m -> m ()) -> m a) -> m a instance MonadLB m => MonadLBState (ModuleT st m) where type LBState (ModuleT st m) = st withMS f = do ref <- getRef withMWriter ref f instance MonadLBState m => MonadLBState (Cmd m) where type LBState (Cmd m) = LBState m withMS f = do x <- liftWith $ \run -> withMS $ \st wr -> run (f st (lift . wr)) restoreT (return x) -- | Read the module's private state. readMS :: MonadLBState m => m (LBState m) readMS = withMS (\st _ -> return st) -- | Modify the module's private state. modifyMS :: MonadLBState m => (LBState m -> LBState m) -> m () modifyMS f = withMS $ \st wr -> wr (f st) -- | Write the module's private state. Try to use withMS instead. writeMS :: MonadLBState m => LBState m -> m () writeMS = modifyMS . const -- | This datatype allows modules to conviently maintain both global -- (i.e. for all clients they're interacting with) and private state. -- It is implemented on top of readMS\/withMS. -- -- This simple implementation is linear in the number of private states used. data GlobalPrivate g p = GP { global :: !g, private :: ![(Nick,MVar (Maybe p))], maxSize :: Int } -- | Creates a @GlobalPrivate@ given the value of the global state. No private -- state for clients will be created. mkGlobalPrivate :: Int -> g -> GlobalPrivate g p mkGlobalPrivate ms g = GP { global = g, private = [], maxSize = ms } -- Needs a better interface. The with-functions are hardly useful. -- | Writes private state. For now, it locks everything. withPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p) => Nick -- ^ The target -> (Maybe p -> (Maybe p -> LB ()) -> LB a) -- ^ @Just x@ writes x in the user's private state, @Nothing@ removes it. -> m a withPS who f = do mvar <- accessPS return id who lb $ withMWriter mvar f -- | Reads private state. readPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p) => Nick -> m (Maybe p) readPS = accessPS (liftIO . readMVar) (\_ -> return Nothing) -- | Reads private state, executes one of the actions success and failure -- which take an MVar and an action producing a @Nothing@ MVar, respectively. accessPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p) => (MVar (Maybe p) -> m a) -> (m (MVar (Maybe p)) -> m a) -> Nick -> m a accessPS success failure who = withMS $ \state writer -> case lookup who $ private state of Just mvar -> do let newPrivate = (who,mvar): filter ((/=who) . fst) (private state) length newPrivate `seq` writer (state { private = newPrivate }) success mvar Nothing -> failure $ do mvar <- liftIO $ newMVar Nothing let newPrivate = take (maxSize state) $ (who,mvar): private state length newPrivate `seq` writer (state { private = newPrivate }) return mvar -- | Writes global state. Locks everything withGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p) => (g -> (g -> m ()) -> m ()) -> m () withGS f = withMS $ \state writer -> f (global state) $ \g -> writer $ state { global = g } -- | Reads global state. readGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p) => m g readGS = fmap global readMS -- The old interface, as we don't wanna be too fancy right now. writePS :: (MonadLBState m, LBState m ~ GlobalPrivate g p) => Nick -> Maybe p -> m () writePS who x = withPS who (\_ writer -> writer x) writeGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p) => g -> m () writeGS g = withGS (\_ writer -> writer g) -- --------------------------------------------------------------------- -- -- Handling global state -- -- | flush state of modules flushModuleState :: LB () flushModuleState = withAllModules (\m -> getModuleName >>= writeGlobalState m) -- | Peristence: write the global state out writeGlobalState :: Module st -> String -> ModuleT st LB () writeGlobalState module' name = do debugM ("saving state for module " ++ show name) case moduleSerialize module' of Nothing -> return () Just ser -> do state' <- readMS case serialize ser state' of Nothing -> return () -- do not write any state Just out -> do stateFile <- lb (findLBFileForWriting name) io (P.writeFile stateFile out) -- | Read it in readGlobalState :: Module st -> String -> LB (Maybe st) readGlobalState module' name = do debugM ("loading state for module " ++ show name) case moduleSerialize module' of Just ser -> do mbStateFile <- 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.0.3/src/Lambdabot/Plugin.hs0000644000000000000000000000347312554503453017043 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 , getModuleName , bindModule0 , bindModule1 , bindModule2 , LB , MonadLB(..) , lim80 , ios80 , ChanName , mkCN , getCN , Nick(..) , ircPrivmsg , module Lambdabot.Config , module Lambdabot.Config.Core , module Lambdabot.Command , module Lambdabot.State , module Lambdabot.File , module Lambdabot.Util.Serial ) where import Lambdabot.Bot import Lambdabot.ChanName import Lambdabot.Config import Lambdabot.Config.Core import Lambdabot.Command hiding (runCommand, execCmd) import Lambdabot.File import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Nick import Lambdabot.State import Lambdabot.Util import Lambdabot.Util.Serial import Codec.Binary.UTF8.String import Control.Monad import Control.Monad.Trans import Data.Char lim80 :: Monad m => m String -> Cmd m () lim80 action = do to <- getTarget let lim = case nName to of ('#':_) -> take 3 . map (limitStr 80) -- message to channel: be nice _ -> id -- private message: get everything spaceOut = unlines . lim . map (' ':) . lines removeControl = filter (\x -> isSpace x || not (isControl x)) (say =<<) . lift $ liftM (encodeString . spaceOut . removeControl . decodeString) action -- | convenience, similar to ios but also cut output to channel to 80 characters -- usage: @process _ _ to _ s = ios80 to (plugs s)@ ios80 :: MonadIO m => IO String -> Cmd m () ios80 = lim80 . io lambdabot-core-5.0.3/src/Lambdabot/Bot.hs0000644000000000000000000001465212554503453016332 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 , ircSignalConnect , ircInstallOutputFilter , checkPrivs , checkIgnore , ircCodepage , ircGetChannels , ircQuit , ircReconnect , ircPrivmsg , ircPrivmsg' ) where import Lambdabot.ChanName import Lambdabot.Command import Lambdabot.IRC import Lambdabot.Logging import Lambdabot.Message import Lambdabot.Module import Lambdabot.Monad import Lambdabot.Nick import Lambdabot.OutputFilter import Lambdabot.State import Lambdabot.Util import Control.Concurrent import Control.Exception.Lifted import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State import qualified Data.Map as M import Data.Random.Source import qualified Data.Set as S ------------------------------------------------------------------------ -- -- | Register a module in the irc state -- ircLoadModule :: Module st -> String -> LB () ircLoadModule m modname = do infoM ("Loading module " ++ show modname) savedState <- readGlobalState m modname state' <- maybe (moduleDefState m) return savedState ref <- io $ newMVar state' let modref = ModuleRef m ref modname cmdref = CommandRef m ref modname mbCmds <- flip runReaderT (ref, modname) . runModuleT $ do initResult <- try (moduleInit m) case initResult of Left e -> return (Left e) Right{} -> try (moduleCmds m) case mbCmds of Left e@SomeException{} -> do errorM ("Module " ++ show modname ++ " failed to load. Exception thrown: " ++ show e) fail "Refusing to load due to a broken plugin" Right cmds -> do s <- get let modmap = ircModules s cmdmap = ircCommands s put s { ircModules = M.insert modname modref modmap, ircCommands = M.union (M.fromList [ (name,cmdref cmd) | cmd <- cmds, name <- cmdNames cmd ]) cmdmap } -- -- | Unregister a module's entry in the irc state -- ircUnloadModule :: String -> LB () ircUnloadModule modname = do infoM ("Unloading module " ++ show modname) withModule modname (error "module not loaded") $ \m -> do when (moduleSticky m) $ fail "module is sticky" exitResult <- try (moduleExit m) case exitResult of Right{} -> return () Left e@SomeException{} -> errorM ("Module " ++ show modname ++ " threw the following exception in moduleExit: " ++ show e) writeGlobalState m modname s <- get let modmap = ircModules s cmdmap = ircCommands s cbs = ircCallbacks s svrs = ircServerMap s ofs = ircOutputFilters s put s { ircCommands = M.filter (\(CommandRef _ _ name _) -> name /= modname) cmdmap , ircModules = M.delete modname modmap , ircCallbacks = filter ((/=modname) . fst) `fmap` cbs , ircServerMap = M.filter ((/=modname) . fst) svrs , ircOutputFilters = filter ((/=modname) . fst) ofs } ------------------------------------------------------------------------ ircSignalConnect :: String -> Callback -> ModuleT mod LB () ircSignalConnect str f = do s <- lift get let cbs = ircCallbacks s name <- getModuleName case M.lookup str cbs of -- TODO: figure out what this TODO is for Nothing -> lift (put s { ircCallbacks = M.insert str [(name,f)] cbs}) Just fs -> lift (put s { ircCallbacks = M.insert str ((name,f):fs) cbs}) ircInstallOutputFilter :: OutputFilter LB -> ModuleT mod LB () ircInstallOutputFilter f = do name <- getModuleName lift . modify $ \s -> s { ircOutputFilters = (name, f): ircOutputFilters s } -- | Checks if the given user has admin permissions and excecute the action -- only in this case. checkPrivs :: IrcMessage -> LB Bool checkPrivs msg = gets (S.member (nick msg) . ircPrivilegedUsers) -- | Checks if the given user is being ignored. -- Privileged users can't be ignored. checkIgnore :: IrcMessage -> LB Bool checkIgnore msg = liftM2 (&&) (liftM not (checkPrivs msg)) (gets (S.member (nick msg) . ircIgnoredUsers)) ------------------------------------------------------------------------ -- Some generic server operations -- Send a CODEPAGE command to set encoding for current session. -- Some IRC networks don't provide UTF-8 ports, but allow -- switching it in runtime ircCodepage :: String -> String -> LB () ircCodepage svr cpage = do send $ codepage svr cpage ircGetChannels :: LB [Nick] ircGetChannels = (map getCN . M.keys) `fmap` gets ircChannels -- Send a quit message, settle and wait for the server to drop our -- handle. At which point the main thread gets a closed handle eof -- exceptoin, we clean up and go home ircQuit :: String -> String -> LB () ircQuit svr msg = do modify $ \state' -> state' { ircStayConnected = False } send $ quit svr msg liftIO $ threadDelay 1000 noticeM "Quitting" ircReconnect :: String -> String -> LB () ircReconnect svr msg = do send $ quit svr msg liftIO $ threadDelay 1000 -- | Send a message to a channel\/user. If the message is too long, the rest -- of it is saved in the (global) more-state. ircPrivmsg :: Nick -- ^ The channel\/user. -> String -- ^ The message. -> LB () ircPrivmsg who msg = do filters <- gets ircOutputFilters sendlines <- foldr (\f -> (=<<) (f who)) ((return . lines) msg) $ map snd filters mapM_ (\s -> ircPrivmsg' who (take textwidth s)) (take 10 sendlines) -- A raw send version ircPrivmsg' :: Nick -> String -> LB () ircPrivmsg' who "" = ircPrivmsg' who " " ircPrivmsg' who msg = send $ privmsg who msg ------------------------------------------------------------------------ monadRandom [d| instance MonadRandom LB where getRandomWord8 = LB (lift getRandomWord8) getRandomWord16 = LB (lift getRandomWord16) getRandomWord32 = LB (lift getRandomWord32) getRandomWord64 = LB (lift getRandomWord64) getRandomDouble = LB (lift getRandomDouble) getRandomNByteInteger n = LB (lift (getRandomNByteInteger n)) |] lambdabot-core-5.0.3/src/Lambdabot/Message.hs0000644000000000000000000000132412554503453017162 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.0.3/src/Lambdabot/Nick.hs0000644000000000000000000000266212554503453016470 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.0.3/src/Lambdabot/ChanName.hs0000644000000000000000000000054112554503453017250 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.0.3/src/Lambdabot/Command.hs0000644000000000000000000001015412554503453017155 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.0.3/src/Lambdabot/OutputFilter.hs0000644000000000000000000000256612554503453020255 0ustar0000000000000000module Lambdabot.OutputFilter ( OutputFilter , textwidth , cleanOutput , lineify ) where import Lambdabot.Nick import Lambdabot.Util import Data.Char import Data.List type OutputFilter m = Nick -> [String] -> m [String] textwidth :: Int textwidth = 200 -- IRC maximum msg length, minus a bit for safety. -- | For now, this just checks for duplicate empty lines. cleanOutput :: Monad m => OutputFilter m cleanOutput _ msg = return $ remDups True msg' where remDups True ([]:xs) = remDups True xs remDups False ([]:xs) = []:remDups True xs remDups _ (x: xs) = x: remDups False xs remDups _ [] = [] msg' = map (dropFromEnd isSpace) msg -- | wrap long lines. lineify :: Monad m => OutputFilter m lineify = const (return . mlines . unlines) -- | break into lines mlines :: String -> [String] mlines = (mbreak =<<) . lines where mbreak :: String -> [String] mbreak xs | null bs = [as] | otherwise = (as++cs) : filter (not . null) (mbreak ds) where (as,bs) = splitAt (w-n) xs breaks = filter (not . isAlphaNum . last . fst) $ drop 1 $ take n $ zip (inits bs) (tails bs) (cs,ds) = last $ (take n bs, drop n bs): breaks w = textwidth n = 10 lambdabot-core-5.0.3/src/Lambdabot/Logging.hs0000644000000000000000000000313612554503453017167 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.0.3/src/Lambdabot/Monad.hs-boot0000644000000000000000000000046312554503453017600 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.0.3/src/Lambdabot/Monad.hs0000644000000000000000000002104312554503453016634 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 , ModuleRef(..) , CommandRef(..) , IRCRWState(..) , initRwState , LB(..) , MonadLB(..) , evalLB , addServer , remServer , send , received , getConfig , withModule , withCommand , withAllModules ) where import Lambdabot.ChanName import Lambdabot.Command import Lambdabot.Config import Lambdabot.Config.Core import Lambdabot.IRC import Lambdabot.Logging import Lambdabot.Module import qualified Lambdabot.Message as Msg import Lambdabot.Nick import Lambdabot.OutputFilter import Lambdabot.Util import Control.Applicative import Control.Concurrent.Lifted import Control.Exception.Lifted as E (catch) import Control.Monad.Base import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Control import qualified Data.Dependent.Map as D import Data.IORef import qualified Data.Map as M import qualified Data.Set as S import System.Console.Haskeline.MonadException (MonadException) ------------------------------------------------------------------------ -- -- Lambdabot state -- -- | Global read-only state. data IRCRState = IRCRState { ircInitDoneMVar :: MVar () , ircQuitMVar :: MVar () , ircConfig :: D.DMap Config } -- | Default ro state initRoState :: [D.DSum Config] -> IO IRCRState initRoState configuration = do quitMVar <- newEmptyMVar initDoneMVar <- newEmptyMVar return IRCRState { ircQuitMVar = quitMVar , ircInitDoneMVar = initDoneMVar , ircConfig = D.fromListWithKey (flip . mergeConfig) configuration } reportInitDone :: MonadIO m => IRCRState -> m () reportInitDone = io . flip putMVar () . ircInitDoneMVar askLB :: MonadLB m => (IRCRState -> a) -> m a askLB f = lb . LB $ asks (f . fst) waitForInit :: MonadLB m => m () waitForInit = readMVar =<< askLB ircInitDoneMVar waitForQuit :: MonadLB m => m () waitForQuit = readMVar =<< askLB ircQuitMVar type Callback = IrcMessage -> LB () data ModuleRef = forall st. ModuleRef (Module st) (MVar st) String data CommandRef = forall st. CommandRef (Module st) (MVar st) String (Command (ModuleT st LB)) -- | Global read\/write state. data IRCRWState = IRCRWState { ircServerMap :: M.Map String (String, IrcMessage -> LB ()) , ircPrivilegedUsers :: S.Set Nick , ircIgnoredUsers :: S.Set Nick , ircChannels :: M.Map ChanName String -- ^ maps channel names to topics , ircModules :: M.Map String ModuleRef , ircCallbacks :: M.Map String [(String,Callback)] , ircOutputFilters :: [(String, OutputFilter LB)] -- ^ Output filters, invoked from right to left , ircCommands :: M.Map String CommandRef , ircStayConnected :: !Bool } -- | Default rw state initRwState :: IRCRWState initRwState = IRCRWState { ircPrivilegedUsers = S.singleton (Nick "offlinerc" "null") , ircIgnoredUsers = S.empty , ircChannels = M.empty , ircModules = M.empty , ircServerMap = M.empty , ircCallbacks = M.empty , ircOutputFilters = [ ([],cleanOutput) , ([],lineify) , ([],cleanOutput) ] , ircCommands = M.empty , ircStayConnected = True } -- The virtual chat system. -- -- The virtual chat system sits between the chat drivers and the rest of -- Lambdabot. It provides a mapping between the String server "tags" and -- functions which are able to handle sending messages. -- -- When a message is recieved, the chat module is expected to call -- `Lambdabot.Main.received'. This is not ideal. addServer :: String -> (IrcMessage -> LB ()) -> ModuleT mod LB () addServer tag sendf = do s <- lift get let svrs = ircServerMap s name <- getModuleName case M.lookup tag svrs of Nothing -> lift (put s { ircServerMap = M.insert tag (name,sendf) svrs}) Just _ -> fail $ "attempted to create two servers named " ++ tag remServer :: String -> LB () remServer tag = do s <- get let svrs = ircServerMap s case M.lookup tag svrs of Just _ -> do let svrs' = M.delete tag svrs put (s { ircServerMap = svrs' }) when (M.null svrs') $ do quitMVar <- askLB ircQuitMVar io $ putMVar quitMVar () Nothing -> fail $ "attempted to delete nonexistent servers named " ++ tag send :: IrcMessage -> LB () send msg = do s <- gets ircServerMap case M.lookup (Msg.server msg) s of Just (_, sendf) -> sendf msg Nothing -> warningM $ "sending message to bogus server: " ++ show msg received :: IrcMessage -> LB () received msg = do s <- get handler <- getConfig uncaughtExceptionHandler case M.lookup (ircMsgCommand msg) (ircCallbacks s) of Just cbs -> mapM_ (\(_, cb) -> cb msg `E.catch` (liftIO . handler)) cbs _ -> return () -- --------------------------------------------------------------------- -- -- The LB (LambdaBot) monad -- -- | The IRC Monad. The reader transformer holds information about the -- connection to the IRC server. -- -- instances Monad, Functor, MonadIO, MonadState, MonadError newtype LB a = LB { runLB :: ReaderT (IRCRState,IORef IRCRWState) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadException) instance MonadBase IO LB where liftBase = LB . liftBase instance MonadBaseControl IO LB where type StM LB a = StM (ReaderT (IRCRState,IORef IRCRWState) IO) a liftBaseWith action = LB (liftBaseWith (\run -> action (run . runLB))) 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 get = LB $ do ref <- asks snd lift $ readIORef ref put x = LB $ do ref <- asks snd lift $ writeIORef ref x instance MonadConfig LB where getConfig k = liftM (maybe (getConfigDefault k) id . D.lookup k) (lb (askLB ircConfig)) instance MonadLogging LB where getCurrentLogger = getConfig lbRootLoggerPath logM a b c = io (logM a b c) -- | run a computation in the LB monad evalLB :: LB a -> IRCRState -> IRCRWState -> IO a evalLB (LB lb') rs rws = do ref <- newIORef rws lb' `runReaderT` (rs,ref) ------------------------------------------------------------------------ -- Module handling -- | Interpret an expression in the context of a module. -- Arguments are which map to use (@ircModules@ and @ircCommands@ are -- the only sensible arguments here), the name of the module\/command, -- action for the case that the lookup fails, action if the lookup -- succeeds. -- withModule :: String -> LB a -> (forall st. Module st -> ModuleT st LB a) -> LB a withModule modname def f = do maybemod <- gets (M.lookup modname . ircModules) case maybemod of -- TODO stick this ref stuff in a monad instead. more portable in -- the long run. Just (ModuleRef m ref name) -> do runReaderT (runModuleT $ f m) (ref, name) _ -> def withCommand :: String -> LB a -> (forall st. Module st -> Command (ModuleT st LB) -> ModuleT st LB a) -> LB a withCommand cmdname def f = do maybecmd <- gets (M.lookup cmdname . ircCommands) case maybecmd of -- TODO stick this ref stuff in a monad instead. more portable in -- the long run. Just (CommandRef m ref name cmd) -> do runReaderT (runModuleT $ f m cmd) (ref, name) _ -> def -- | Interpret a function in the context of all modules withAllModules :: (forall st. Module st -> ModuleT st LB a) -> LB () withAllModules f = do mods <- gets $ M.elems . ircModules :: LB [ModuleRef] (`mapM_` mods) $ \(ModuleRef m ref name) -> do runReaderT (runModuleT $ f m) (ref, name) lambdabot-core-5.0.3/src/Lambdabot/Main.hs0000644000000000000000000000617212554503453016470 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.State import Lambdabot.Util import Lambdabot.Util.Signals import Control.Exception.Lifted as E import Data.Dependent.Sum import Data.List import Data.Typeable import Data.Version import Language.Haskell.TH import Paths_lambdabot_core (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 :: LB () -> [DSum Config] -> IO ExitCode lambdabotMain initialise cfg = withSocketsDo . withIrcSignalCatch $ do rost <- initRoState cfg r <- try $ evalLB (do setupLogging noticeM "Initialising plugins" initialise noticeM "Done loading plugins" reportInitDone rost mainLoop return ExitSuccess) rost initRwState -- clean up and go home case r of Left (SomeException er) -> do case cast er of Just code -> return code Nothing -> do putStrLn "exception:" print er return (ExitFailure 1) Right code -> return code -- Actually, this isn't a loop anymore. TODO: better name. mainLoop :: LB () mainLoop = do waitForQuit `E.catch` (\e@SomeException{} -> errorM (show e)) -- catch anything, print informative message, and clean up withAllModules moduleExit flushModuleState ------------------------------------------------------------------------ type Modules = LB () modules :: [String] -> Q Exp modules xs = [| sequence_ $(listE $ map instalify (nub xs)) |] where instalify x = let module' = varE $ mkName (x ++ "Plugin") in [| ircLoadModule $module' x |] lambdabot-core-5.0.3/src/Lambdabot/IRC.hs0000644000000000000000000001004512554503453016213 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. 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.0.3/src/Lambdabot/Compat/0000755000000000000000000000000012554503453016465 5ustar0000000000000000lambdabot-core-5.0.3/src/Lambdabot/Compat/PackedNick.hs0000644000000000000000000000143112554503453021014 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.0.3/src/Lambdabot/Compat/FreenodeNick.hs0000644000000000000000000000225712554503453021363 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.0.3/src/Lambdabot/Compat/AltTime.hs0000644000000000000000000001414712554503453020367 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.0.3/src/Lambdabot/Util/0000755000000000000000000000000012554503453016157 5ustar0000000000000000lambdabot-core-5.0.3/src/Lambdabot/Util/Signals.hs0000644000000000000000000000766412554503453020130 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.0.3/src/Lambdabot/Util/Serial.hs0000644000000000000000000001312512554503453017734 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.0.3/src/Lambdabot/Plugin/0000755000000000000000000000000012554503453016500 5ustar0000000000000000lambdabot-core-5.0.3/src/Lambdabot/Plugin/Core.hs0000644000000000000000000000115512554503453017726 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.0.3/src/Lambdabot/Plugin/Core/0000755000000000000000000000000012554503453017370 5ustar0000000000000000lambdabot-core-5.0.3/src/Lambdabot/Plugin/Core/System.hs0000644000000000000000000001500512554503453021211 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.Monad import Lambdabot.Plugin import Lambdabot.Util import Control.Monad.State (gets, modify) import Control.Monad.Trans import qualified Data.Map as M import qualified Data.Set as S type SystemState = (ClockTime, TimeDiff) type System = ModuleT SystemState LB systemPlugin :: Module SystemState systemPlugin = newModule { moduleDefState = flip (,) noTimeDiff `fmap` io getClockTime , moduleSerialize = Just stdSerial , moduleInit = do (_, d) <- readMS t <- io getClockTime writeMS (t, d) , moduleExit = do (initial, d) <- readMS now <- liftIO getClockTime writeMS (initial, max d (diffClockTimes now initial)) , moduleCmds = return $ [ (command "listchans") { help = say "Show channels bot has joined" , process = \_ -> listKeys (M.mapKeysMonotonic (FreenodeNick . getCN) . ircChannels) } , (command "listmodules") { help = say "listmodules. Show available plugins" , process = \_ -> listKeys ircModules } , (command "listservers") { help = say "listservers. Show current servers" , process = \_ -> listKeys ircServerMap } , (command "list") { help = say "list [module|command]. Show commands for [module] or the module providing [command]." , process = doList } , (command "echo") { help = say "echo . echo irc protocol string" , process = doEcho } , (command "uptime") { help = say "uptime. Show uptime" , process = \_ -> do (uptime, maxUptime) <- lift getUptime say ("uptime: " ++ timeDiffPretty uptime ++ ", longest uptime: " ++ timeDiffPretty maxUptime) } , (command "listall") { privileged = True , help = say "list all commands" , process = \_ -> mapM_ doList . M.keys =<< lb (gets ircModules) } , (command "join") { privileged = True , help = say "join " , 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 "flush") { privileged = True , help = say "flush. flush state to disk" , process = \_ -> lb flushModuleState } , (command "admin") { privileged = True , help = say "admin [+|-] nick. change a user's admin status." , process = doAdmin } , (command "ignore") { privileged = True , help = say "ignore [+|-] nick. change a user's ignore status." , process = doIgnore } , (command "reconnect") { privileged = True , help = say "reconnect to server" , process = \rest -> do server <- getServer lb (ircReconnect server $ if null rest then "requested" else rest) } ] } ------------------------------------------------------------------------ doList :: String -> Cmd System () doList "" = say "What module? Try @listmodules for some ideas." doList m = say =<< lb (listModule m) doEcho :: String -> Cmd System () doEcho rest = do rawMsg <- withMsg (return . show) target <- showNick =<< getTarget say (concat ["echo; msg:", rawMsg, " target:" , target, " rest:", show rest]) doAdmin :: String -> Cmd System () doAdmin = toggleNick $ \op nck s -> s { ircPrivilegedUsers = op nck (ircPrivilegedUsers s) } doIgnore :: String -> Cmd System () doIgnore = toggleNick $ \op nck s -> s { ircIgnoredUsers = op nck (ircIgnoredUsers s) } ------------------------------------------------------------------------ -- | Print map keys listKeys :: Show k => (IRCRWState -> M.Map k v) -> Cmd System () listKeys f = say . showClean . M.keys =<< lb (gets f) getUptime :: System (TimeDiff, TimeDiff) getUptime = do (loaded, m) <- readMS now <- io getClockTime let diff = now `diffClockTimes` loaded return (diff, max diff m) toggleNick :: (Ord a, MonadLB m) => ((a -> S.Set a -> S.Set a) -> Nick -> IRCRWState -> IRCRWState) -> String -> Cmd m () toggleNick edit rest = do let (op, tgt) = splitAt 2 rest f <- case op of "+ " -> return S.insert "- " -> return S.delete _ -> fail "invalid usage" nck <- readNick tgt lb . modify $ edit f nck listModule :: String -> LB String listModule s = withModule s fromCommand printProvides where fromCommand = withCommand s (return $ "No module \""++s++"\" loaded") (const . printProvides) -- ghc now needs a type annotation here printProvides :: Module st -> ModuleT st LB String printProvides m = do cmds <- moduleCmds m let cmds' = filter (not . privileged) cmds name' <- getModuleName return . concat $ if null cmds' then [name', " has no visible commands"] else [name', " provides: ", showClean (concatMap cmdNames cmds')] lambdabot-core-5.0.3/src/Lambdabot/Plugin/Core/More.hs0000644000000000000000000000313212554503453020625 0ustar0000000000000000-- | Support for more(1) buffering module Lambdabot.Plugin.Core.More (morePlugin) where import Lambdabot.Plugin import Lambdabot.Bot import Control.Monad.Trans type MoreState = GlobalPrivate () [String] type More = ModuleT MoreState LB -- the @more state is handled centrally morePlugin :: Module (GlobalPrivate () [String]) morePlugin = newModule { moduleDefState = return $ mkGlobalPrivate 20 () , moduleInit = bindModule2 moreFilter >>= ircInstallOutputFilter , moduleCmds = return [ (command "more") { help = say "@more. Return more output from the bot buffer." , process = \_ -> do target <- getTarget morestate <- readPS target -- TODO: test theory that we can just "say" morestate; -- it should end up going through the moreFilter as needed case morestate of Nothing -> return () Just ls -> lift (moreFilter target ls) >>= mapM_ (lb . ircPrivmsg' target) } ] } moreFilter :: Nick -> [String] -> More [String] moreFilter target msglines = do let (morelines, thislines) = case drop (maxLines+2) msglines of [] -> ([],msglines) _ -> (drop maxLines msglines, take maxLines msglines) writePS target $ if null morelines then Nothing else Just morelines return $ thislines ++ if null morelines then [] else ['[':shows (length morelines) " @more lines]"] where maxLines = 5 -- arbitrary, really lambdabot-core-5.0.3/src/Lambdabot/Plugin/Core/Help.hs0000644000000000000000000000315312554503453020616 0ustar0000000000000000-- | Provide help for plugins module Lambdabot.Plugin.Core.Help (helpPlugin) where import Lambdabot.Command import Lambdabot.Message (Message) import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util helpPlugin :: Module () helpPlugin = newModule { moduleCmds = return [ (command "help") { help = say "help . 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 (withModule arg -- else maybe it's a module name (doHelp msg tgt "help") -- else give up (\md -> do -- its a module cmds <- moduleCmds md let ss = cmds >>= cmdNames let s | null ss = arg ++ " is a module." | otherwise = arg ++ " provides: " ++ showClean ss return [s])) -- so it's a valid command, try to find its help (\_md theCmd -> moduleHelp theCmd msg tgt arg) where (arg:_) = words rest lambdabot-core-5.0.3/src/Lambdabot/Plugin/Core/OfflineRC.hs0000644000000000000000000000675212554503453021545 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 ) import Control.Monad.Trans( lift, liftIO ) import Data.Char import System.Console.Haskeline (InputT, Settings(..), runInputT, defaultSettings, getInputLine) import System.IO import System.Timeout.Lifted -- We need to track the number of active sourcings so that we can -- unregister the server (-> allow the bot to quit) when it is not -- being used. type OfflineRCState = Integer type OfflineRC = ModuleT OfflineRCState LB offlineRCPlugin :: Module OfflineRCState offlineRCPlugin = newModule { moduleDefState = return 0 , moduleInit = do void . fork $ do waitForInit lockRC cmds <- getConfig onStartupCmds mapM_ feed cmds `finally` unlockRC , moduleCmds = return [ (command "offline") { privileged = True , help = say "offline. Start a repl" , process = const . lift $ do lockRC histFile <- lb $ 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 lift . (>> return ()) . timeout (15 * 1000 * 1000) . received $ IrcMessage { ircMsgServer = "offlinerc" , ircMsgLBName = "offline" , ircMsgPrefix = "null!n=user@null" , ircMsgCommand = "PRIVMSG" , ircMsgParams = ["offline", ":" ++ msg' ] } handleMsg :: IrcMessage -> LB () handleMsg msg = liftIO $ do let str = case (tail . ircMsgParams) msg of [] -> [] (x:_) -> tail x hPutStrLn stdout str hFlush stdout replLoop :: InputT OfflineRC () replLoop = do line <- getInputLine "lambdabot> " case line of Nothing -> return () Just x -> do let s' = dropWhile isSpace x when (not $ null s') $ do lift $ feed s' continue <- lift (lift (gets ircStayConnected)) when continue replLoop lockRC :: OfflineRC () lockRC = do withMS $ \ cur writ -> do when (cur == 0) (addServer "offlinerc" handleMsg) writ (cur + 1) unlockRC :: OfflineRC () unlockRC = withMS $ \ cur writ -> do when (cur == 1) $ lb $ remServer "offlinerc" writ (cur - 1) lambdabot-core-5.0.3/src/Lambdabot/Plugin/Core/Version.hs0000644000000000000000000000137412554503453021356 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.0.3/src/Lambdabot/Plugin/Core/Base.hs0000644000000000000000000002670212554503453020605 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | Lambdabot base module. Controls message send and receive module Lambdabot.Plugin.Core.Base (basePlugin) where import Lambdabot.Bot import Lambdabot.Command import Lambdabot.Config.Core import Lambdabot.IRC import Lambdabot.Logging import Lambdabot.Message import Lambdabot.Monad import Lambdabot.Nick import Lambdabot.Plugin import Lambdabot.Util import Control.Applicative import Control.Exception.Lifted as E import Control.Monad import Control.Monad.State import Data.List import Data.List.Split import qualified Data.Map as M import Text.EditDistance import Text.Regex.TDFA type BaseState = GlobalPrivate () () type Base = ModuleT BaseState LB basePlugin :: Module (GlobalPrivate () ()) basePlugin = newModule { moduleDefState = return $ mkGlobalPrivate 20 () , moduleInit = do ircSignalConnect "PING" doPING bindModule1 doNOTICE >>= ircSignalConnect "NOTICE" ircSignalConnect "PART" doPART bindModule1 doKICK >>= ircSignalConnect "KICK" ircSignalConnect "JOIN" doJOIN ircSignalConnect "NICK" doNICK ircSignalConnect "MODE" doMODE ircSignalConnect "TOPIC" doTOPIC ircSignalConnect "QUIT" doQUIT bindModule1 doPRIVMSG >>= ircSignalConnect "PRIVMSG" ircSignalConnect "001" doRPL_WELCOME {- ircSignalConnect "002" doRPL_YOURHOST ircSignalConnect "003" doRPL_CREATED ircSignalConnect "004" doRPL_MYINFO -} ircSignalConnect "005" doRPL_BOUNCE {- ircSignalConnect "250" doRPL_STATSCONN ircSignalConnect "251" doRPL_LUSERCLIENT ircSignalConnect "252" doRPL_LUSEROP ircSignalConnect "253" doRPL_LUSERUNKNOWN ircSignalConnect "254" doRPL_LUSERCHANNELS ircSignalConnect "255" doRPL_LUSERME ircSignalConnect "265" doRPL_LOCALUSERS ircSignalConnect "266" doRPL_GLOBALUSERS -} ircSignalConnect "332" doRPL_TOPIC {- ircSignalConnect "353" doRPL_NAMRELY ircSignalConnect "366" doRPL_ENDOFNAMES ircSignalConnect "372" doRPL_MOTD ircSignalConnect "375" doRPL_MOTDSTART ircSignalConnect "376" doRPL_ENDOFMOTD -} } doIGNORE :: Callback doIGNORE = debugM . show doPING :: Callback doPING = noticeM . showPingMsg where showPingMsg msg = "PING! <" ++ ircMsgServer msg ++ (':' : ircMsgPrefix msg) ++ "> [" ++ ircMsgCommand msg ++ "] " ++ show (ircMsgParams msg) -- If this is a "TIME" then we need to pass it over to the localtime plugin -- otherwise, dump it to stdout doNOTICE :: IrcMessage -> Base () doNOTICE msg | isCTCPTimeReply = doPRIVMSG (timeReply msg) -- TODO: need to say which module to run the privmsg in | otherwise = noticeM (show body) where body = ircMsgParams msg isCTCPTimeReply = ":\SOHTIME" `isPrefixOf` (last body) doJOIN :: Callback doJOIN msg | lambdabotName msg /= nick msg = doIGNORE msg | otherwise = do let msgArg = concat (take 1 (ircMsgParams msg)) chan = case dropWhile (/= ':') msgArg of [] -> msgArg aloc -> aloc loc = Nick (server msg) (dropWhile (== ':') chan) s <- get put (s { ircChannels = M.insert (mkCN loc) "[currently unknown]" (ircChannels s)}) -- the empty topic causes problems send $ getTopic loc -- initialize topic where doPART :: Callback doPART msg = when (lambdabotName msg == nick msg) $ do let body = ircMsgParams msg loc = Nick (server msg) (head body) s <- get put (s { ircChannels = M.delete (mkCN loc) (ircChannels s) }) doKICK :: IrcMessage -> Base () doKICK msg = do let body = ircMsgParams msg loc = Nick (server msg) (body !! 0) who = Nick (server msg) (body !! 1) when (lambdabotName msg == who) $ do noticeM $ fmtNick "" (nick msg) ++ " KICK " ++ fmtNick (server msg) loc ++ " " ++ show (drop 2 body) lift $ modify $ \s -> s { ircChannels = M.delete (mkCN loc) (ircChannels s) } doNICK :: Callback doNICK msg = doIGNORE msg doMODE :: Callback doMODE msg = doIGNORE msg doTOPIC :: Callback doTOPIC msg = do let loc = Nick (server msg) (head (ircMsgParams msg)) s <- get put (s { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ ircMsgParams msg) (ircChannels s)}) doRPL_WELCOME :: Callback doRPL_WELCOME = doIGNORE doQUIT :: Callback doQUIT msg = doIGNORE msg doRPL_BOUNCE :: Callback doRPL_BOUNCE _msg = debugM "BOUNCE!" doRPL_TOPIC :: Callback doRPL_TOPIC msg -- nearly the same as doTOPIC but has our nick on the front of body = do let body = ircMsgParams msg loc = Nick (server msg) (body !! 1) s <- get put (s { ircChannels = M.insert (mkCN loc) (tail $ last body) (ircChannels s) }) doPRIVMSG :: IrcMessage -> Base () doPRIVMSG msg = do ignored <- lift $ checkIgnore msg commands <- getConfig commandPrefixes if ignored then lift $ doIGNORE msg else mapM_ (doPRIVMSG' commands (lambdabotName msg) msg) targets where alltargets = head (ircMsgParams msg) targets = map (parseNick (ircMsgServer msg)) $ splitOn "," alltargets -- -- | What does the bot respond to? -- doPRIVMSG' :: [String] -> Nick -> IrcMessage -> Nick -> Base () doPRIVMSG' commands myname msg target | myname == target = let (cmd, params) = splitFirstWord text in doPersonalMsg commands msg target text cmd params | flip any ":," $ \c -> (fmtNick (ircMsgServer msg) myname ++ [c]) `isPrefixOf` text = let Just wholeCmd = maybeCommand (fmtNick (ircMsgServer msg) myname) text (cmd, params) = splitFirstWord wholeCmd in doPublicMsg commands msg target cmd params | (commands `arePrefixesOf` text) && length text > 1 && (text !! 1 /= ' ') -- elem of prefixes && (not (commands `arePrefixesOf` [text !! 1]) || (length text > 2 && text !! 2 == ' ')) -- ignore @@ prefix, but not the @@ command itself = let (cmd, params) = splitFirstWord (dropWhile (==' ') text) in doPublicMsg commands msg target cmd params | otherwise = doContextualMsg msg target target text where text = tail (head (tail (ircMsgParams msg))) doPersonalMsg :: [String] -> IrcMessage -> Nick -> String -> String -> String -> Base () doPersonalMsg commands msg target text s r | commands `arePrefixesOf` s = doMsg msg (tail s) r who | otherwise = doContextualMsg msg target who text where who = nick msg doPublicMsg :: [String] -> IrcMessage -> Nick -> String -> String -> Base () doPublicMsg commands msg target s r | commands `arePrefixesOf` s = doMsg msg (tail s) r target | otherwise = (lift $ doIGNORE msg) -- -- normal commands. -- -- check privledges, do any spell correction, dispatch, handling -- possible timeouts. -- -- todo, refactor -- doMsg :: IrcMessage -> String -> String -> Nick -> Base () doMsg msg cmd rest towhere = do let ircmsg = ircPrivmsg towhere allcmds <- lift (gets (M.keys . ircCommands)) let ms = filter (isPrefixOf cmd) allcmds e <- getConfig editDistanceLimit case ms of [s] -> docmd msg towhere rest s -- a unique prefix _ | cmd `elem` ms -> docmd msg towhere rest cmd -- correct command (usual case) _ | otherwise -> case closests cmd allcmds of (n,[s]) | n < e , ms == [] -> docmd msg towhere rest s -- unique edit match (n,ss) | n < e || ms /= [] -- some possibilities -> lift . ircmsg $ "Maybe you meant: "++showClean(nub(ms++ss)) _ -> docmd msg towhere rest cmd -- no prefix, edit distance too far docmd :: IrcMessage -> Nick -> [Char] -> String -> Base () docmd msg towhere rest cmd' = withPS towhere $ \_ _ -> do withCommand cmd' -- Important. (ircPrivmsg towhere "Unknown command, try @list") (\_ theCmd -> do name' <- getModuleName hasPrivs <- lb (checkPrivs msg) -- TODO: handle disabled commands earlier -- users should probably see no difference between a -- command that is disabled and one that doesn't exist. disabled <- elem cmd' <$> getConfig disabledCommands let ok = not disabled && (not (privileged theCmd) || hasPrivs) response <- if not ok then return ["Not enough privileges"] else runCommand theCmd msg towhere cmd' rest `E.catch` \exc@SomeException{} -> return ["Plugin `" ++ name' ++ "' failed with: " ++ show exc] -- send off our response strings -- TODO: expandTab here should probably be an OutputFilter lift $ mapM_ (ircPrivmsg towhere . expandTab 8) response ) -- -- contextual messages are all input that isn't an explicit command. -- they're passed to all modules (todo, sounds inefficient) for -- scanning, and any that implement 'contextual' will reply. -- -- we try to run the contextual functions from all modules, on every -- non-command. better hope this is efficient. -- -- Note how we catch any plugin errors here, rather than letting -- them bubble back up to the mainloop -- doContextualMsg :: IrcMessage -> Nick -> Nick -> [Char] -> Base () doContextualMsg msg target towhere r = lift $ withAllModules $ \m -> do name' <- getModuleName E.catch (lift . mapM_ (ircPrivmsg towhere) =<< execCmd (contextual m r) msg target "contextual") (\e@SomeException{} -> debugM . (name' ++) . (" module failed in contextual handler: " ++) $ show e) ------------------------------------------------------------------------ closests :: String -> [String] -> (Int,[String]) closests pat ss = M.findMin m where m = M.fromListWith (++) ls ls = [ (levenshteinDistance defaultEditCosts pat s, [s]) | s <- ss ] maybeCommand :: String -> String -> Maybe String maybeCommand nm text = mrAfter <$> matchM re text where re :: Regex re = makeRegex (nm ++ "[.:,]*[[:space:]]*") -- -- And stuff we don't care about -- {- doRPL_YOURHOST :: Callback doRPL_YOURHOST _msg = return () doRPL_CREATED :: Callback doRPL_CREATED _msg = return () doRPL_MYINFO :: Callback doRPL_MYINFO _msg = return () doRPL_STATSCONN :: Callback doRPL_STATSCONN _msg = return () doRPL_LUSERCLIENT :: Callback doRPL_LUSERCLIENT _msg = return () doRPL_LUSEROP :: Callback doRPL_LUSEROP _msg = return () doRPL_LUSERUNKNOWN :: Callback doRPL_LUSERUNKNOWN _msg = return () doRPL_LUSERCHANNELS :: Callback doRPL_LUSERCHANNELS _msg = return () doRPL_LUSERME :: Callback doRPL_LUSERME _msg = return () doRPL_LOCALUSERS :: Callback doRPL_LOCALUSERS _msg = return () doRPL_GLOBALUSERS :: Callback doRPL_GLOBALUSERS _msg = return () doUNKNOWN :: Callback doUNKNOWN msg = debugM $ "UNKNOWN> <" ++ msgPrefix msg ++ "> [" ++ msgCommand msg ++ "] " ++ show (body msg) doRPL_NAMREPLY :: Callback doRPL_NAMREPLY _msg = return () doRPL_ENDOFNAMES :: Callback doRPL_ENDOFNAMES _msg = return () doRPL_MOTD :: Callback doRPL_MOTD _msg = return () doRPL_MOTDSTART :: Callback doRPL_MOTDSTART _msg = return () doRPL_ENDOFMOTD :: Callback doRPL_ENDOFMOTD _msg = return () -} lambdabot-core-5.0.3/src/Lambdabot/Plugin/Core/Compose.hs0000644000000000000000000001404312554503453021333 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.Monad import Lambdabot.Plugin import Control.Arrow (first) import Control.Monad import Control.Monad.Trans import Data.Char import Data.List import Data.List.Split type Compose = ModuleT () LB composePlugin :: Module () composePlugin = newModule { moduleCmds = return [ (command "@") { aliases = ["?"] , help = do c <- getCmdName let cc = c++c mapM_ say [ cc++" [args]." , cc++" executes plugin invocations in its arguments, parentheses can be used." , " The commands are right associative." , " For example: "++cc++" "++c++"pl "++c++"undo code" , " is the same as: "++cc++" ("++c++"pl ("++c++"undo code))" ] , process = evalBracket } , (command ".") { aliases = ["compose"] , help = mapM_ say [ ". [args]." , ". [or compose] is the composition of two plugins" , " The following semantics are used: . f g xs == g xs >>= f" ] , process = \args -> case splitOn " " args of (f:g:xs) -> do f' <- lookupP f g' <- lookupP g lb (compose f' g' (concat $ intersperse " " xs)) >>= mapM_ say _ -> say "Not enough arguments to @." } ] } -- | Compose two plugin functions compose :: (String -> LB [String]) -> (String -> LB [String]) -> (String -> LB [String]) compose f g xs = g xs >>= f . unlines ------------------------------------------------------------------------ -- | Lookup the `process' method we're after, and apply it to the dummy args -- lookupP :: String -> Cmd Compose (String -> LB [String]) lookupP cmd = withMsg $ \a -> do b <- getTarget lb $ withCommand cmd (error $ "Unknown command: " ++ show cmd) (\_m theCmd -> do when (privileged theCmd) $ error "Privileged commands cannot be composed" bindModule1 (runCommand theCmd a b cmd)) ------------------------------------------------------------------------ -- | More interesting composition/evaluation -- @@ @f x y (@g y z) evalBracket :: String -> Cmd Compose () evalBracket args = do cmdPrefixes <- getConfig commandPrefixes let conf = cmdPrefixes xs <- mapM evalExpr (fst (parseBracket 0 True args conf)) mapM_ (say . addSpace) (concat' xs) where concat' ([x]:[y]:xs) = concat' ([x++y]:xs) concat' xs = concat xs addSpace :: String -> String addSpace (' ':xs) = ' ':xs addSpace xs = ' ':xs evalExpr :: Expr -> Cmd Compose [String] evalExpr (Arg s) = return [s] evalExpr (Cmd c args) = do args' <- mapM evalExpr args let arg = concat $ concat $ map (intersperse " ") args' cmd <- lookupP c lift (lift (cmd arg)) ------------------------------------------------------------------------ data Expr = Cmd String [Expr] | Arg String deriving Show -- TODO: rewrite this using parsec or something -- | Parse a command invocation that can contain parentheses -- The Int indicates how many brackets must be closed to end the current argument, or 0 -- The Bool indicates if this is a valid location for a character constant parseBracket :: Int -> Bool -> String -> [String] -> ([Expr],String) parseBracket 0 _ [] _ = ([],[]) parseBracket _ _ [] _ = error "Missing ')' in nested command" parseBracket 1 _ (')':xs) _ = ([],xs) parseBracket n _ (')':xs) c | n > 0 = first (addArg ")") $ parseBracket (n-1) True xs c parseBracket n _ ('(':xs) c | Just ys <- isCommand xs c -- (@cmd arg arg) = parseCommand n ys c parseBracket n _ ('(':xs) c | n > 0 = first (addArg "(") $ parseBracket (n+1) True xs c parseBracket n _ xs c | Just ('(':ys) <- isCommand xs c -- @(cmd arg arg) = parseCommand n ys c parseBracket n _ xs c | Just ys <- isCommand xs c -- @cmd arg arg = parseInlineCommand n ys c parseBracket n c (x:xs) cfg | x `elem` "\"'" && (c || x /= '\'') = let (str, ys) = parseString x xs (rest,zs) = parseBracket n True ys cfg in (addArg (x:str) rest, zs) parseBracket n c (x:xs) cfg = first (addArg [x]) $ parseBracket n (not (isAlphaNum x) && (c || x /= '\'')) xs cfg parseCommand, parseInlineCommand :: Int -> String -> [String] -> ([Expr],String) parseCommand n xs conf = (Cmd cmd args:rest, ws) where (cmd, ys) = break (`elem` " )") xs (args,zs) = parseBracket 1 True (dropWhile (==' ') ys) conf (rest,ws) = parseBracket n True zs conf parseInlineCommand n xs conf = (Cmd cmd rest:[], zs) where (cmd, ys) = break (`elem` " )") xs (rest,zs) = parseBracket n True (dropWhile (==' ') ys) conf parseString :: Char -> String -> (String, String) parseString _ [] = ([],[]) parseString delim ('\\':x:xs) = first (\ys -> '\\':x:ys) (parseString delim xs) parseString delim (x:xs) | delim == x = ([x],xs) | otherwise = first (x:) (parseString delim xs) -- | Does xs start with a command prefix? isCommand :: String -> [String] -> Maybe String isCommand xs = msum . map dropPrefix where dropPrefix p | p `isPrefixOf` xs = Just $ drop (length p) xs | otherwise = Nothing addArg :: String -> [Expr] -> [Expr] addArg s (Arg a:es) = Arg (s++a):es addArg s es = Arg s :es lambdabot-core-5.0.3/src/Lambdabot/Config/0000755000000000000000000000000012554503453016447 5ustar0000000000000000lambdabot-core-5.0.3/src/Lambdabot/Config/Core.hs0000644000000000000000000000430112554503453017671 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 , 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 [] [] |] -- 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 |]