lambdabot-reference-plugins (empty) → 5.0

raw patch · 15 files changed

+1124/−0 lines, 15 filesdep +HTTPdep +basedep +bytestringsetup-changed

Dependencies added: HTTP, base, bytestring, containers, lambdabot-core, mtl, network, network-uri, oeis, process, regex-tdfa, split, tagsoup, utf8-string

Files

• LICENSE +22/−0
• Setup.hs +3/−0
• lambdabot-reference-plugins.cabal +75/−0
• src/Lambdabot/Config/Reference.hs +14/−0
• src/Lambdabot/Plugin/Reference.hs +27/−0
• src/Lambdabot/Plugin/Reference/Dict.hs +112/−0
• src/Lambdabot/Plugin/Reference/Dict/DictLookup.hs +99/−0
• src/Lambdabot/Plugin/Reference/Metar.hs +51/−0
• src/Lambdabot/Plugin/Reference/OEIS.hs +18/−0
• src/Lambdabot/Plugin/Reference/Search.hs +129/−0
• src/Lambdabot/Plugin/Reference/Spell.hs +135/−0
• src/Lambdabot/Plugin/Reference/Ticker.hs +134/−0
• src/Lambdabot/Plugin/Reference/Url.hs +149/−0
• src/Lambdabot/Plugin/Reference/Where.hs +74/−0
• src/Lambdabot/Util/Browser.hs +82/−0

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

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

@@ -0,0 +1,75 @@+name:                   lambdabot-reference-plugins+version:                5.0++license:                GPL+license-file:           LICENSE++author:                 Don Stewart+maintainer:             James Cook <mokus@deepbondi.net>++category:               Development, Web+synopsis:               Lambdabot reference plugins.+description:            Lambdabot is an IRC bot written over several years by+                        those on the #haskell IRC channel.+                        .+                        Provided plugins:+                        .+                        [dict] Query various dictionaries.+                        [metar] Look up avian weather reports.+                        [oeis] Look up number sequences on OEIS.+                        [search] Query search engines.+                        [spell] Check spelling of wrods.+                        [ticker] Look up stock quotes.+                        [url] Display titles of URLs on channels.+                        [where] Manage and query a key-URL list.++homepage:               http://haskell.org/haskellwiki/Lambdabot++build-type:             Simple+cabal-version:          >= 1.8+tested-with:            GHC == 7.6.3, GHC == 7.8.3++source-repository head+  type:                 git+  location:             https://github.com/lambdabot/lambdabot.git++flag network-uri+  description: Get Network.URI from the network-uri package+  default: True++library+  hs-source-dirs:       src+  ghc-options:          -Wall+                        -funbox-strict-fields++  exposed-modules:      Lambdabot.Plugin.Reference+                        Lambdabot.Util.Browser+  other-modules:        Lambdabot.Plugin.Reference.Dict+                        Lambdabot.Plugin.Reference.Metar+                        Lambdabot.Plugin.Reference.OEIS+                        Lambdabot.Plugin.Reference.Search+                        Lambdabot.Plugin.Reference.Spell+                        Lambdabot.Plugin.Reference.Ticker+                        Lambdabot.Plugin.Reference.Url+                        Lambdabot.Plugin.Reference.Where++  other-modules:        Lambdabot.Config.Reference+                        Lambdabot.Plugin.Reference.Dict.DictLookup++  build-depends:        base                    >= 4.4 && < 5,+                        bytestring              >= 0.9,+                        containers              >= 0.4,+                        HTTP                    >= 4000,+                        lambdabot-core          >= 5 && < 5.1,+                        mtl                     >= 2,+                        oeis                    >= 0.3.1,+                        process                 >= 1.1,+                        regex-tdfa              >= 1.1,+                        split                   >= 0.2,+                        tagsoup                 >= 0.12,+                        utf8-string             >= 0.3 && < 1++  if flag(network-uri)+    build-depends: network-uri >= 2.6, network >= 2.6+  else+    build-depends: network-uri < 2.6, network < 2.6

@@ -0,0 +1,14 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+module Lambdabot.Config.Reference+    ( proxy+    , aspellBinary+    ) where++import Lambdabot.Config+import Network.HTTP.Proxy++config "proxy"              [t| Proxy                   |] [| NoProxy       |]+config "aspellBinary"       [t| String                  |] [| "aspell"      |]

@@ -0,0 +1,27 @@+module Lambdabot.Plugin.Reference+    ( dictPlugin+    , metarPlugin+    , oeisPlugin+    , searchPlugin+    , spellPlugin+    , tickerPlugin+    , urlPlugin+    , wherePlugin+    +    , referencePlugins+    +    , module Lambdabot.Config.Reference+    ) where++import Lambdabot.Config.Reference+import Lambdabot.Plugin.Reference.Dict+import Lambdabot.Plugin.Reference.Metar+import Lambdabot.Plugin.Reference.OEIS+import Lambdabot.Plugin.Reference.Search+import Lambdabot.Plugin.Reference.Spell+import Lambdabot.Plugin.Reference.Ticker+import Lambdabot.Plugin.Reference.Url+import Lambdabot.Plugin.Reference.Where++referencePlugins :: [String]+referencePlugins = ["dict", "metar", "oeis", "search", "spell", "ticker", "url", "where"]

@@ -0,0 +1,112 @@+{-# LANGUAGE PatternGuards #-}+-- | DICT (RFC 2229) Lookup Module for lambdabot IRC robot.+-- Tom Moertel <tom@moertel.com>+module Lambdabot.Plugin.Reference.Dict (dictPlugin) where++import Lambdabot.Plugin+import qualified Lambdabot.Plugin.Reference.Dict.DictLookup as Dict+import Lambdabot.Util++import Control.Monad+import Data.List++type Dict = ModuleT () LB++dictPlugin :: Module ()+dictPlugin = newModule+    { moduleCmds = return $+        [ (command "dict-help")+            { help = getHelp []+            , process = getHelp . words+            }+        ] +++        [ (command name)+            { help = getHelp [name]+            , process = \args -> case parseTerms args of+                [] -> getHelp [name]+                s  -> mapM_ (doLookup >=> sayResult) s+            }+        | (name, (srv, db, _)) <- dictTable+        , let doLookup  = io . Dict.simpleDictLookup srv db+              sayResult = say . either ("Error: " ++) id+        ]+    }++-- | Configuration.++dictTable :: [(String, (Dict.QueryConfig, String, String))]+dictTable =+    -- @command     (server  , database,       description)+    [ ("all-dicts", (dict_org, "*"       ,     "Query all databases on dict.org"))+    , ("bouvier"  , (dict_org, "bouvier",      "Bouvier's Law Dictionary"))+    , ("cide"     , (dict_org, "gcide",        "The Collaborative International Dictionary of English"))+    , ("devils"   , (dict_org, "devil",        "The Devil's Dictionary"))+    , ("easton"   , (dict_org, "easton",       "Easton's 1897 Bible Dictionary"))+    , ("elements" , (dict_org, "elements",     "Elements database"))+    , ("foldoc"   , (dict_org, "foldoc",       "The Free On-line Dictionary of Computing"))+    , ("gazetteer", (dict_org, "gaz2k-places", "U.S. Gazetteer (2000)"))+    , ("hitchcock", (dict_org, "hitchcock",    "Hitchcock's Bible Names Dictionary (late 1800's)"))+    , ("jargon"   , (dict_org, "jargon",       "Jargon File"))+    , ("thesaurus", (dict_org, "moby-thes",    "Moby Thesaurus II"))+    , ("vera"     , (dict_org, "vera",         "V.E.R.A.: Virtual Entity of Relevant Acronyms"))+    , ("wn"       , (dict_org, "wn",           "WordNet (r) 1.7"))+    , ("world02"  , (dict_org, "world02",      "CIA World Factbook 2002"))+    ]+    where+    dict_org    = Dict.QC "dict.org" 2628++dictNames :: [String]+dictNames = sort (map fst dictTable)+++-- | Print out help.++getHelp :: [String] -> Cmd Dict ()+getHelp []    = do+    say ("I perform dictionary lookups via the following "+          ++ show (length dictNames) ++ " commands:\n")+    getHelp dictNames++getHelp dicts = mapM_ (say . gH) dicts+    where+    gH dict | Just (_, _, descr) <- lookup dict dictTable+            = pad dict ++ " " ++ descr++            | otherwise+            = "There is no dictionary database '" ++ dict ++ "'."++    pad xs = take padWidth (xs ++ " " ++ repeat '.')+    padWidth = maximum (map length dictNames) + 4+++-- | Break a string into dictionary-query terms, handling quoting and+-- escaping along the way.  (This is ugly, and I don't particularly+-- like it.)  Given a string like the following, we want to do the+-- right thing, which is to break it into five query strings:+--+--     firefly "c'est la vie" 'pound cake' 'rock n\' roll' et\ al+--+--     (1) firefly+--     (2) "c'est la vie"+--     (3) 'pound cake'+--     (4) 'rock n\' roll'+--     (5) et\ al++parseTerms :: String -> [String]+parseTerms = pW . words+    where+    pW []  = []+    pW (w@(f:_):ws)+        | f `elem` "'\"" = intercalate " " qws : pW ws'+        | last w == '\\' = let (w':rest) = pW ws in intercalate " " [w, w'] : rest+        | otherwise      = w : pW ws+        where+        (qws, ws') = case break isCloseQuotedWord (w:ws) of+            (qws', [])    -> (init qws' ++ [last qws' ++ [f]], [])+            (qw, w':rest) -> (qw ++ [w'], rest)+        isCloseQuotedWord xs = case reverse xs of+            x:y:_ -> f == x && y /= '\\' -- quote doesn't count if escaped+            x:_   -> f == x+            _     -> False+    pW _ = error "DictModule: parseTerms: can't parse"+

@@ -0,0 +1,99 @@+--+-- | DICT (RFC 2229) Lookup +-- Tom Moertel <tom@moertel.com>+-- +--Here's how you might write a program to query the Jargon database for+--the definition of "hacker" and then print the result:+--+-- >  main = doJargonLookup "hacker" >>= putStr+-- >+-- >  doJargonLookup :: String -> IO String+-- >  doJargonLookup query = do+-- >      result <- simpleDictLookup (QC "dict.org" 2628) "jargon" query +-- >      return $ case result of+-- >          Left errorResult -> "ERROR: " ++ errorResult+-- >          Right dictResult -> dictResult+-- >+--+module Lambdabot.Plugin.Reference.Dict.DictLookup ( simpleDictLookup, QueryConfig(..), LookupResult) where++import Data.List+import System.IO+import Control.Exception (SomeException, handle)+import Network++data QueryConfig    = QC { host :: String, port :: Int }+type DictConnection = Handle+data DictCommand    = Quit | Define DictName String+type DictName       = String -- dict-db name | "!" 1st match | "*" all matches+type LookupResult   = Either String String -- Left <error> | Right <result>++simpleDictLookup :: QueryConfig -> DictName -> String -> IO LookupResult+simpleDictLookup config dictnm query =+    handle (\e -> (return $ Left (show (e :: SomeException)))) $ do+        conn <- openDictConnection config+        result <- queryDict conn dictnm query+        closeDictConnection conn+        return result++openDictConnection :: QueryConfig -> IO DictConnection+openDictConnection config = do+    hDictServer <- connectTo (host config) (mkPortNumber $ port config)+    hSetBuffering hDictServer LineBuffering+    _ <- readResponseLine hDictServer -- ignore response+    return hDictServer+    where+    mkPortNumber = PortNumber . fromIntegral++closeDictConnection :: DictConnection -> IO ()+closeDictConnection conn = do+    sendCommand conn Quit+    _ <- readResponseLine conn -- ignore response+    hClose conn++{-+queryAllDicts :: DictConnection -> String -> IO LookupResult+queryAllDicts = flip queryDict "*"+-}++queryDict :: DictConnection -> DictName -> String -> IO LookupResult+queryDict conn dictnm query = do+    sendCommand conn (Define dictnm query)+    response <- readResponseLine conn+    case response of+        '1':'5':_     -> readDefinition >>= return . formatDefinition+        '5':'5':'2':_ -> return $ Right ("No match for \"" ++ query ++ "\".\n")+        '5':_         -> return $ Left response -- error response+        _             -> return $ Left ("Bogus response: " ++ response)+            +    where++    readDefinition = do+        line <- readResponseLine conn+        case line of+            '2':'5':'0':_ -> return []+            _             -> readDefinition >>= return . (line:)++    formatDefinition = Right . unlines . concatMap formater++    formater ('1':'5':'1':rest) = ["", "***" ++ rest]+    formater "."                = []+    formater line               = [line]+++readResponseLine :: DictConnection -> IO String+readResponseLine conn = do+    line <- hGetLine conn+    return (filter (/='\r') line)++sendCommand :: DictConnection -> DictCommand -> IO ()+sendCommand conn cmd =+    hSendLine conn $ case cmd of+        Quit -> "QUIT"+        Define db target -> join " " ["DEFINE", db, target]++join :: [a] -> [[a]] -> [a]+join = (concat.) . intersperse++hSendLine :: Handle -> String -> IO ()+hSendLine h line = hPutStr h (line ++ "\r\n")

@@ -0,0 +1,51 @@+-- | Look up METAR weather records.+--+-- Copyright (c) 2014 Bertram Felgenhauer <int-e@gmx.de>+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++module Lambdabot.Plugin.Reference.Metar (metarPlugin) where++import Lambdabot.Plugin+import Lambdabot.Util.Browser (browseLB)++import Network.Browser (request)+import Network.HTTP (getRequest, rspCode, rspBody)+import Data.Char (isAlpha, toUpper)++metarPlugin :: Module ()+metarPlugin = newModule+    { moduleCmds = return+        [ (command "metar")+            { help = say "metar <ICAO airport code>\n\+                         \Look up METAR weather data for given airport."+            , process = doMetar+            }+        ]+    }++addsUri :: String+addsUri =+    "http://aviationweather.gov/adds/dataserver_current/httpparam"++addsSrc :: String -> String+addsSrc code = addsUri +++    "?dataSource=metars&requestType=retrieve&format=csv&hoursBeforeNow=2\+    \&mostRecentForEachStation=true&stationString=" ++ code++doMetar :: MonadLB m => String -> Cmd m ()+doMetar code | length code == 4 && all isAlpha code = do+    msg <- browseLB $ do+        let src = addsSrc (map toUpper code)+        (uri, resp) <- request $ getRequest src+        case rspCode resp of+            (2,_,_) -> return $ extractMetar (rspBody resp)+            _ -> return $ "Request failed."+    say msg+doMetar _ = return ()++extractMetar :: String -> String+extractMetar body = case lines body of+    ls@("No errors" : _) -> case takeWhile (/= ',') (last ls) of+        "raw_text" -> "No result."+        l          -> l+    _ -> "Request failed."

@@ -0,0 +1,18 @@+-- | Look up sequences in the Online Encyclopedia of Integer Sequences+--   Based on the Math.OEIS library+module Lambdabot.Plugin.Reference.OEIS (oeisPlugin) where++import Lambdabot.Plugin++import Math.OEIS++oeisPlugin :: Module ()+oeisPlugin = newModule+    { moduleCmds = return+        [ (command "oeis")+            { aliases = ["sequence"]+            , help = say "oeis <sequence>. Look up a sequence in the Online Encyclopedia of Integer Sequences"+            , process = ios80 . fmap concat . lookupOEIS+            }+        ]+    }

@@ -0,0 +1,129 @@+{-# LANGUAGE ViewPatterns #-}+-- | Search various things, Wikipedia and google for now.+--+-- (c) 2005 Samuel Bronson+-- (c) 2006 Don Stewart++-- Joel Koerwer 11-01-2005 generalized query for different methods+--   and added extractConversion to make things like @google 1+2 work+module Lambdabot.Plugin.Reference.Search (searchPlugin) where++import Lambdabot.Config.Reference+import Lambdabot.Plugin+import Lambdabot.Util+import Lambdabot.Util.Browser++import Data.Char+import Data.Maybe+import Network.HTTP+import Network.HTTP.Proxy+import Network.URI hiding (path, query)+import Text.HTML.TagSoup+import Text.HTML.TagSoup.Match (anyAttr, tagOpen)++engines :: [(String, (URI, String -> String, [Header]))]+engines =+   [("google", (googleUri, (\s -> "?hl=en&q="++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders)),+    -- ("wikipedia", (wikipediaUri, ("?search="++), [])), -- this has changed and Wikipedia requires a User-Agent string+    ("gsite", (googleUri, (\s -> "?hl=en&q=site%3A"++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders)),+    ("gwiki", (googleUri, (\s -> "?hl=en&q=site%3Ahaskell.org/haskellwiki+" ++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders))+   ]++googleHeaders :: [Header]+googleHeaders = [mkHeader HdrReferer "http://www.google.com/"]++normalizeOptions :: MonadLB m => m (NormalizeRequestOptions a)+normalizeOptions = do+    proxy' <- getConfig proxy+    let hasProxy = case proxy' of+            NoProxy -> False+            _       -> True+    return defaultNormalizeRequestOptions+        { normDoClose = True+        , normForProxy = hasProxy+        , normUserAgent = Nothing+        } -- there is a default user agent, perhaps we want it?++makeUri :: String -> String -> URI+makeUri regName path = nullURI {+    uriScheme = "http:",+    uriAuthority = Just (URIAuth { uriUserInfo = "", uriRegName = regName, uriPort = "" }),+    uriPath = path }++googleUri :: URI+googleUri = makeUri "www.google.com" "/search"+-- wikipediaUri = makeUri "en.wikipedia.org" "/wiki/Special:Search"++searchPlugin :: Module ()+searchPlugin = newModule+    { moduleCmds = return+        [ (command name)+            { help = say (moduleHelp name)+            , process = \e -> do+                s <- getCmdName+                lb (searchCmd s (strip isSpace e)) >>= mapM_ say+            }+        | name <- map fst engines+        ]+    }++moduleHelp :: String -> String+moduleHelp s = case s of+    "google"    -> "google <expr>. Search google and show url of first hit"+    -- "wikipedia" -> "wikipedia <expr>. Search wikipedia and show url of first hit"+    "gsite"     -> "gsite <site> <expr>. Search <site> for <expr> using google"+    "gwiki"     -> "gwiki <expr>. Search (new) haskell.org wiki for <expr> using google."+    _           -> "Search Plugin does not have command \"" ++ s ++ "\""++------------------------------------------------------------------------++searchCmd :: String -> String -> LB [String]+searchCmd _          []   = return ["Empty search."]+searchCmd engineName (urlEncode -> query)+    | engineName == "google" = do -- for Google we do both to get conversions, e.g. for '3 lbs in kg'+        request <- request'+        doHTTP request $ \response ->+            case response of+                Response { rspCode = (3,0,2), rspHeaders = (lookupHeader HdrLocation -> Just url) } ->+                    doGoogle >>=  handleUrl url+                _ -> fmap (\extra -> if null extra then ["No Result Found."] else extra) doGoogle+    | otherwise = do+        request <- request'+        doHTTP request $ \response ->+            case response of+                Response { rspCode = (3,0,2), rspHeaders = (lookupHeader HdrLocation -> Just url) } ->+                    handleUrl url []+                _ -> return ["No Result Found."]+  where handleUrl url extra = do+            title <- browseLB (urlPageTitle url)+            return $ extra ++ maybe [url] (\t -> [url, "Title: " ++ t]) title+        Just (uri, makeQuery, headers) = lookup engineName engines+        request' = do+            opts <- normalizeOptions+            return $ normalizeRequest opts $ Request+                { rqURI = uri { uriQuery = makeQuery query }+                , rqMethod = HEAD+                , rqHeaders = headers+                , rqBody = ""+                }+        doGoogle = do+            request <- request'+            doHTTP (request { rqMethod = GET, rqURI = uri { uriQuery = "?hl=en&q=" ++ query } }) $ \response ->+                case response of+                    Response { rspCode = (2,_,_), rspBody = (extractConversion -> Just result) } ->+                        return [result]+                    _ -> return []++doHTTP :: HStream a => Request a -> (Response a -> LB [String]) -> LB [String]+doHTTP request handler = do+    result <- io $ simpleHTTP request+    case result of+        Left connError -> return ["Connection error: "++show connError]+        Right response -> handler response++-- This is clearly fragile.+extractConversion :: String -> Maybe String+extractConversion (parseTags -> tags) = listToMaybe [txt |+    section <- sections (tagOpen ("h2"==) (anyAttr (\(name, value) -> name == "class" && value == "r"))) tags,+    txt <- [strip isSpace $ drop 1 $ dropWhile (/= '=') t | TagText t <- section],+    not (null txt)]

@@ -0,0 +1,135 @@+{-# LANGUAGE PatternGuards #-}+-- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)+--+-- | Interface to /aspell/, an open source spelling checker, from a+-- suggestion by Kai Engelhardt. Requires you to install aspell.+module Lambdabot.Plugin.Reference.Spell (spellPlugin) where++import Lambdabot.Config.Reference+import Lambdabot.Plugin+import Lambdabot.Util++import Control.Monad.Trans+import Data.Char+import Data.List.Split+import Data.Maybe+import System.Process+import Text.Regex.TDFA+++type Spell = ModuleT Bool LB++spellPlugin :: Module Bool+spellPlugin = newModule+    { moduleCmds = return+        [ (command "spell")+            { help = say helpStr+            , process = doSpell+            }+        , (command "spell-all")+            { help = say helpStr+            , process = spellAll+            }+        , (command "nazi-on")+            { privileged = True+            , help = say helpStr+            , process = const (nazi True)+            }+        , (command "nazi-off")+            { privileged = True+            , help = say helpStr+            , process = const (nazi False)+            }+        ]+    , moduleDefState = return False++    , contextual = \txt -> do+        alive <- readMS+        binary <- getConfig aspellBinary+        if alive then io (spellingNazi binary txt) >>= mapM_ say+                 else return ()+    }++helpStr :: String+helpStr = "spell <word>. Show spelling of word"++doSpell :: [Char] -> Cmd Spell ()+doSpell [] = say "No word to spell."+doSpell s  = do+    binary <- getConfig aspellBinary+    (say . showClean . take 5) =<< (io (spell binary s))++spellAll :: [Char] -> Cmd Spell ()+spellAll [] = say "No phrase to spell."+spellAll s  = do+    binary <- getConfig aspellBinary+    liftIO (spellingNazi binary s) >>= mapM_ say++nazi :: Bool -> Cmd (ModuleT Bool LB) ()+nazi True  = lift on  >> say "Spelling nazi engaged."+nazi False = lift off >> say "Spelling nazi disengaged."++on :: Spell ()+on  = writeMS True++off :: Spell ()+off = writeMS False++args :: [String]+args = ["pipe"]++--+-- | Find the first misspelled word in the input line, and return plausible+-- output.+--+spellingNazi :: String -> String -> IO [String]+spellingNazi binary lin = fmap (take 1 . concat) (mapM correct (words lin))+    where correct word = do+            var <- take 5 `fmap` spell binary word+            return $ if null var || any (equating' (map toLower) word) var+                then []+                else ["Did you mean " ++ listToStr "or" var ++ "?"]+          equating' f x y = f x == f y+--+-- | Return a list of possible spellings for a word+-- 'String' is a word to check the spelling of.+--+spell :: String -> String -> IO [String]+spell binary word = spellWithArgs binary word []++spellWithArgs :: String -> String -> [String] -> IO [String]+spellWithArgs binary word ex = do+    (_,out,err) <- readProcessWithExitCode binary (args++ex) word+    let o = fromMaybe [word] ((clean_ . lines) out)+        e = fromMaybe e      ((clean_ . lines) err)+    return $ case () of {_+        | null o && null e -> []+        | null o           -> e+        | otherwise        -> o+    }++--+-- Parse the output of aspell (would probably work for ispell too)+--+clean_ :: [String] -> Maybe [String]+clean_ (('@':'(':'#':')':_):rest) = clean' rest -- drop header+clean_ s = clean' s                             -- no header for some reason++--+-- Parse rest of aspell output.+--+-- Grammar is:+--      OK          ::=  *+--      Suggestions ::= & <original> <count> <offset>: <miss>, <miss>, ...+--      None        ::= # <original> <offset>+--+clean' :: [String] -> Maybe [String]+clean' (('*':_):_)    = Nothing                          -- correct spelling+clean' (('#':_):_)    = Just []                          -- no match+clean' (('&':rest):_) = Just $ splitOn ", " (clean'' rest) -- suggestions+clean' _              = Just []                          -- not sure++clean'' :: String -> String+clean'' s = maybe s mrAfter (s =~~ pat)+    where pat  = "[^:]*: "    -- drop header

@@ -0,0 +1,134 @@+-- | Pull quotes down from yahoo.+module Lambdabot.Plugin.Reference.Ticker (tickerPlugin) where++import Lambdabot.Plugin+import Lambdabot.Util.Browser++import Control.Applicative+import Data.List+import Network.Browser (request)+import Network.HTTP+import Text.Printf++type Ticker = ModuleT () LB++tickerPlugin :: Module ()+tickerPlugin = newModule+    { moduleCmds = return+        [ (command "ticker")+            { help = say "ticker symbols.  Look up quotes for symbols"+            , process = tickerCmd+            }+        , (command "bid")+            { help = say "bid symbols.  Sum up the bid and ask prices for symbols."+            , process = bidsCmd+            }+        ]+    }++------------------------------------------------------------------------++-- Fetch several ticker quotes and report them.+tickerCmd :: String -> Cmd Ticker ()+tickerCmd []        = say "Empty ticker."+tickerCmd tickers = do+    quotes <- getPage $ tickerUrl $ words tickers+    case [x | Just x <- map extractQuote quotes] of+      []       -> say "No Result Found."+      xs       -> mapM_ say xs++-- fetch: s symbol, l1 price, c change with percent, d1 date, t1 time.+tickerUrl :: [String] -> String+tickerUrl tickers =  "http://download.finance.yahoo.com/d/quotes.csv?f=sl1cd1t1&e=.csv&s=" ++ ts+    where ts = intercalate "+" $ map urlEncode tickers++-- $ curl "http://download.finance.yahoo.com/d/quotes.csv?f=sl1cd1t1&e=.csv&s=C"+-- "C",23.19,"-0.45 - -1.90%","5/13/2008","1:32pm"+-- "GBPUSD=X",1.9478,"N/A - N/A","5/13/2008","1:52pm"+extractQuote :: String -> Maybe String+extractQuote = getQuote . csv+    where+        getQuote [sym, price, change, date, time] =+            Just $ printf "%s: %s %s@ %s %s" sym price change' date time+            where change' = case words change of+                              ("N/A":_)    -> ""+                              [ch, _, pch] -> ch ++ " (" ++ pch ++ ") "+                              _            -> ""+        getQuote _ = Nothing++-- Fetch quotes for tickers and sum their bid/ask prices.+bidsCmd :: String -> Cmd Ticker ()+bidsCmd tickers =+    case words tickers of+        [] -> say (printf "Invalid argument '%s'" tickers)+        xs -> calcBids xs >>= say++-- fetch: b bid, a ask+bidsUrl :: [String] -> String+bidsUrl tickers = "http://download.finance.yahoo.com/d/quotes.csv?f=ba&e=.csv&s=" ++ ts+    where ts = intercalate "+" $ map urlEncode tickers++getBidAsks :: MonadLB m => [String] -> m [Maybe (Float, Float)]+getBidAsks tickers = do+    xs <- getPage $ bidsUrl tickers+    return $ map (extractPrice.csv) xs+    where+        extractPrice :: [String] -> Maybe (Float, Float)+        extractPrice [bid,ask] = liftA2 (,) (readMaybe bid) (readMaybe ask)+        extractPrice _         = Nothing++type AccumVal = Either String (Float, Float)++-- If we have a new bid/ask pair, accumulate it (normally add, but+-- if the ticker starts with '-' then subtract).  If there is no+-- value, make a note that it is an error.+accumOption :: AccumVal -> (String, Maybe (Float, Float)) -> AccumVal+accumOption err@(Left _) _ = err+accumOption (Right _) (ticker, Nothing) = Left $ printf "Can't find '%s'" ticker+accumOption (Right (a,b)) (('-':_), Just (a',b')) = Right (a-b', b-a')+accumOption (Right (a,b)) (_, Just (a',b')) = Right (a+a', b+b')++-- Take a list of tickers which are optionally prefixed with '+' or '-'+-- and add up (or subtract) the bid/ask prices on the based on the prefix.+calcBids :: MonadLB m => [String] -> m String+calcBids ticks = do+    xs <- getBidAsks $ map noPrefix ticks+    return $ case foldl accumOption (Right (0,0)) (zip ticks xs) of+        (Left err)        -> err+        (Right (bid,ask)) -> printf "%s: bid $%.02f, ask $%.02f" s bid ask+    where+        s = unwords ticks+        noPrefix ('+':xs) = xs+        noPrefix ('-':xs) = xs+        noPrefix xs = xs++-- | Fetch a page via HTTP and return its body as a list of lines.+getPage :: MonadLB m => String -> m [String]+getPage url = do+    let cleanup = (map (filter (/= '\r'))) . lines+    +    browseLB $ do+        (_, result) <- request (getRequest url)+        case rspCode result of+          (2,0,0) -> return (cleanup (rspBody result))+          (x,y,z) -> return ["Connection error: " ++ ([x,y,z] >>= show) ++ show (rspReason result)]++-- | Return a list of comma-separated values.+-- Quotes allowed in CSV if it's the first character of a field.+csv :: String -> [String]+csv ('"':xs) = case span (/= '"') xs of+                  (word, '"':',':rest) -> word : csv rest+                  (word, '"':[])       -> word : []+                  _                    -> error "invalid CSV"+csv xs = case span (/= ',') xs of+             (word, ',':rest) -> word : csv rest+             ([], [])         -> []+             (word, [])       -> [word]+             _                -> error "shouldn't happen"++-- | Read a value from a string.+readMaybe :: Read a => String -> Maybe a+readMaybe x = case readsPrec 0 x of+                [(y,"")] -> Just y+                _        -> Nothing+

@@ -0,0 +1,149 @@+{-# LANGUAGE PatternGuards #-}+-- | Fetch URL page titles of HTML links.+module Lambdabot.Plugin.Reference.Url (urlPlugin) where++import Lambdabot.Plugin+import Lambdabot.Util.Browser++import Control.Monad+import Control.Monad.Trans+import Data.List+import Data.Maybe+import Network.Browser+import Network.HTTP+import Text.Regex.TDFA++urlPlugin :: Module Bool+urlPlugin = newModule+    { moduleCmds = return+        [ (command "url-title")+            { help = say "url-title <url>. Fetch the page title."+            , process =+                  maybe (say "Url not valid.") (mbSay <=< fetchTitle)+                . containsUrl+            }+        , (command "tiny-url")+            { help = say "tiny-url <url>. Shorten <url>."+            , process =+                  maybe (say "Url not valid.") (mbSay <=< fetchTiny)+                . containsUrl+            }+        , (command "url-on")+            { privileged = True+            , help = say "url-on: enable automatic URL summaries"+            , process = const $ do+                writeMS True+                say "Url enabled"+            }+        , (command "url-off")+            { privileged = True+            , help = say "url-off: disable automatic URL summaries"+            , process = const $ do+                writeMS False+                say "Url disabled"+            }+        ]+    , moduleDefState              = return True -- url on+    , moduleSerialize             = Just stdSerial++    , contextual = \text -> do+      alive <- lift readMS+      if alive && (not $ areSubstringsOf ignoredStrings text)+        then case containsUrl text of+               Nothing  -> return ()+               Just url+                 | length url > 60 -> do+                     title <- fetchTitle url+                     tiny  <- fetchTiny  url+                     say (intercalate ", " (catMaybes [title, tiny]))+                 | otherwise -> mbSay =<< fetchTitle url+        else return ()+    }++mbSay :: Maybe String -> Cmd (ModuleT Bool LB) ()+mbSay = maybe (return ()) say++------------------------------------------------------------------------++-- | The string that I prepend to the quoted page title.+urlTitlePrompt :: String+urlTitlePrompt = "Title: "++-- | Fetch the title of the specified URL.+fetchTitle :: MonadLB m => String -> m (Maybe String)+fetchTitle url = fmap (fmap (urlTitlePrompt ++)) (browseLB (urlPageTitle url))++-- | base url for fetching tiny urls+tinyurl :: String+tinyurl = "http://tinyurl.com/api-create.php?url="++-- | Fetch the title of the specified URL.+fetchTiny :: MonadLB m => String -> m (Maybe String)+fetchTiny url = do+    (_, response) <- browseLB (request (getRequest (tinyurl ++ url)))+    case rspCode response of+      (2,0,0) -> return $ findTiny (rspBody response)+      _       -> return Nothing++-- | Tries to find the start of a tinyurl+findTiny :: String -> Maybe String+findTiny text = do+    mr <- matchM begreg text+    let kind = mrMatch mr+        rest = mrAfter mr+        url = takeWhile (/=' ') rest+    return $ stripSuffixes ignoredUrlSuffixes $ kind ++ url+    where+        begreg :: Regex+        begreg = makeRegexOpts opts defaultExecOpt "http://tinyurl.com/"+        opts = defaultCompOpt {caseSensitive = False}++-- | List of strings that, if present in a contextual message, will+-- prevent the looking up of titles.  This list can be used to stop+-- responses to lisppaste for example.  Another important use is to+-- another lambdabot looking up a url title that contains another+-- url in it (infinite loop).  Ideally, this list could be added to+-- by an admin via a privileged command (TODO).+ignoredStrings :: [String]+ignoredStrings =+    ["paste",                -- Ignore lisppaste, rafb.net+     "cpp.sourcforge.net",   -- C++ paste bin+     "HaskellIrcPastePage",  -- Ignore paste page+     "title of that page",   -- Ignore others like the old me+     urlTitlePrompt]         -- Ignore others like me++-- | Suffixes that should be stripped off when identifying URLs in+-- contextual messages.  These strings may be punctuation in the+-- current sentence vs part of a URL.  Included here is the NUL+-- character as well.+ignoredUrlSuffixes :: [String]+ignoredUrlSuffixes = [".", ",", ";", ")", "\"", "\1", "\n"]++-- | Searches a string for an embeddded URL and returns it.+containsUrl :: String -> Maybe String+containsUrl text = do+    mr <- matchM begreg text+    let kind = mrMatch mr+        rest = mrAfter mr+        url = takeWhile (`notElem` " \n\t\v") rest+    return $ stripSuffixes ignoredUrlSuffixes $ kind ++ url+    where+        begreg = makeRegexOpts opts defaultExecOpt "https?://"+        opts = defaultCompOpt { caseSensitive = False }++-- | Utility function to remove potential suffixes from a string.+-- Note, once a suffix is found, it is stripped and returned, no other+-- suffixes are searched for at that point.+stripSuffixes :: [String] -> String -> String+stripSuffixes []   str   = str+stripSuffixes (s:ss) str+    | isSuffixOf s str   = take (length str - length s) $ str+    | otherwise          = stripSuffixes ss str+++-- | Utility function to check of any of the Strings in the specified+-- list are substrings of the String.+areSubstringsOf :: [String] -> String -> Bool+areSubstringsOf = flip (any . flip isSubstringOf)+    where+      isSubstringOf s str = any (isPrefixOf s) (tails str)

@@ -0,0 +1,74 @@+-- |+-- Module    : Where+-- Copyright : 2003 Shae Erisson+--+-- License:     lGPL+--+-- Slightly specialised version of Where for associating projects with their urls.+-- Code almost all copied.+module Lambdabot.Plugin.Reference.Where (wherePlugin) where++import Lambdabot.Plugin+import Lambdabot.Util+import qualified Data.ByteString.Char8 as P+import Data.Char+import qualified Data.Map as M++type WhereState         = M.Map P.ByteString P.ByteString+type WhereWriter        = WhereState -> Cmd Where ()+type Where              = ModuleT WhereState LB++wherePlugin :: Module (M.Map P.ByteString P.ByteString)+wherePlugin = newModule+    { moduleDefState  = return M.empty+    , moduleSerialize = Just mapPackedSerial++    , moduleCmds = return+        [ (command "where")+            { help = say "where <key>. Return element associated with key"+            , process = doCmd "where"+            }+        , (command "url")+            { help = say "url <key>. Return element associated with key"+            , process = doCmd "url"+            }+        , (command "what")+            { help = say "what <key>. Return element associated with key"+            , process = doCmd "what"+            }+        , (command "where+")+            { help = say "where+ <key> <elem>. Define an association"+            , process = doCmd "where+"+            }+        ]+    }++doCmd :: String -> String -> Cmd Where ()+doCmd cmd rest = (say =<<) . withMS $ \factFM writer ->+    case words rest of+        []         -> return "@where <key>, return element associated with key"+        (fact:dat) -> processCommand factFM writer+                            (map toLower fact) cmd (unwords dat)++------------------------------------------------------------------------++processCommand :: WhereState -> WhereWriter+               -> String -> String -> String -> Cmd Where String++processCommand factFM writer fact cmd dat = case cmd of+        "where"     -> return $ getWhere factFM fact+        "what"      -> return $ getWhere factFM fact -- an alias+        "url"       -> return $ getWhere factFM fact -- an alias+        "where+"    -> updateWhere True factFM writer fact dat+        _           -> return "Unknown command."++getWhere :: WhereState -> String -> String+getWhere fm fact =+    case M.lookup (P.pack fact) fm of+        Nothing -> "I know nothing about " ++ fact ++ "."+        Just x  -> P.unpack x++updateWhere :: Bool -> WhereState -> WhereWriter -> String -> String -> Cmd Where String+updateWhere _guard factFM writer fact dat = do+        writer $ M.insert (P.pack fact) (P.pack dat) factFM+        randomSuccessMsg

@@ -0,0 +1,82 @@+{-# LANGUAGE PatternGuards #-}++-- | URL Utility Functions++module Lambdabot.Util.Browser+    ( urlPageTitle+    , browseLB+    ) where++import Codec.Binary.UTF8.String+import Control.Applicative+import Control.Monad.Trans+import Lambdabot.Config.Reference+import Lambdabot.Monad+import Lambdabot.Util (limitStr)+import Network.Browser+import Network.HTTP+import Network.URI+import Text.HTML.TagSoup+import Text.HTML.TagSoup.Match+import Data.Char (toLower)+import Data.List (isPrefixOf)++-- | Run a browser action with some standardized settings+browseLB :: MonadLB m => BrowserAction conn a -> m a+browseLB act = lb $ do+    proxy' <- getConfig proxy+    liftIO . browse $ do+        setOutHandler (const (return ()))+        setErrHandler (const (return ()))+        +        setAllowRedirects True+        setMaxRedirects (Just 5)+        setProxy proxy'+        act++-- | Limit the maximum title length to prevent jokers from spamming+-- the channel with specially crafted HTML pages.+maxTitleLength :: Int+maxTitleLength = 80++-- | Fetches a page title suitable for display.  Ideally, other+-- plugins should make use of this function if the result is to be+-- displayed in an IRC channel because it ensures that a consistent+-- look is used (and also lets the URL plugin effectively ignore+-- contextual URLs that might be generated by another instance of+-- lambdabot; the URL plugin matches on 'urlTitlePrompt').+urlPageTitle :: String -> BrowserAction (HandleStream String) (Maybe String)+urlPageTitle = fmap (fmap (limitStr maxTitleLength)) . rawPageTitle++-- | Fetches a page title for the specified URL.  This function should+-- only be used by other plugins if and only if the result is not to+-- be displayed in an IRC channel.  Instead, use 'urlPageTitle'.+rawPageTitle :: String -> BrowserAction (HandleStream String) (Maybe String)+rawPageTitle url = checkHTTPS $ do+    (_, result) <- request (getRequest (takeWhile (/='#') url))+    case rspCode result of+        (2,0,0)   -> do+            case takeWhile (/= ';') <$> lookupHeader HdrContentType (rspHeaders result) of+                Just "text/html"       -> return $ extractTitle (rspBody result)+                Just "application/pdf" -> rawPageTitle (googleCacheURL url)+                _                      -> return $ Nothing+        _         -> return Nothing+    +    where googleCacheURL = (gURL++) . escapeURIString (const False)+          gURL = "http://www.google.com/search?hl=en&q=cache:"+          checkHTTPS act | "https:" `isPrefixOf` map toLower url = return Nothing+                         | otherwise = act++-- | Given a server response (list of Strings), return the text in+-- between the title HTML element, only if it is text/html content.+-- Now supports all(?) HTML entities thanks to TagSoup.+extractTitle :: String -> Maybe String+extractTitle = content . tags . decodeString where+    tags = closing . opening . canonicalizeTags . parseTags+    opening = dropWhile (not . tagOpenLit "title" (const True))+    closing = takeWhile (not . tagCloseLit "title")++    content = maybeText . format . innerText+    format = unwords . words+    maybeText [] = Nothing+    maybeText t  = Just (encodeString t)