lambdabot-reference-plugins-5.1/0000755000000000000000000000000012722676543015123 5ustar0000000000000000lambdabot-reference-plugins-5.1/LICENSE0000644000000000000000000000225612722676543016135 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-reference-plugins-5.1/lambdabot-reference-plugins.cabal0000644000000000000000000000624212722676543023453 0ustar0000000000000000name: lambdabot-reference-plugins version: 5.1 license: GPL license-file: LICENSE author: Don Stewart maintainer: James Cook 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.8.4, GHC == 7.10.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.1 && < 5.2, mtl >= 2, oeis >= 0.3.1, process >= 1.1, regex-tdfa >= 1.1, split >= 0.2, tagsoup >= 0.12, utf8-string >= 0.3 if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else build-depends: network-uri < 2.6, network < 2.6 lambdabot-reference-plugins-5.1/Setup.hs0000644000000000000000000000014212722676543016554 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-reference-plugins-5.1/src/0000755000000000000000000000000012722676543015712 5ustar0000000000000000lambdabot-reference-plugins-5.1/src/Lambdabot/0000755000000000000000000000000012722676543017577 5ustar0000000000000000lambdabot-reference-plugins-5.1/src/Lambdabot/Util/0000755000000000000000000000000012722676543020514 5ustar0000000000000000lambdabot-reference-plugins-5.1/src/Lambdabot/Util/Browser.hs0000644000000000000000000000623512722676543022501 0ustar0000000000000000{-# 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 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) lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/0000755000000000000000000000000012722676543021035 5ustar0000000000000000lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference.hs0000644000000000000000000000133612722676543023272 0ustar0000000000000000module 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"] lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/0000755000000000000000000000000012722676543022733 5ustar0000000000000000lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Dict.hs0000644000000000000000000001006412722676543024153 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | DICT (RFC 2229) Lookup Module for lambdabot IRC robot. -- Tom Moertel 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] -> doLookup s >>= sayResult _ -> say "Sorry, look up one word at a time please." } | (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" lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/OEIS.hs0000644000000000000000000000104012722676543024021 0ustar0000000000000000-- | 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 . Look up a sequence in the Online Encyclopedia of Integer Sequences" , process = ios80 . fmap concat . lookupOEIS } ] } lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Metar.hs0000644000000000000000000000310612722676543024337 0ustar0000000000000000-- | Look up METAR weather records. -- -- Copyright (c) 2014 Bertram Felgenhauer -- 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 \n\ \Look up METAR weather data for given airport." , process = doMetar } ] } addsUri :: String addsUri = "http://www.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." lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Where.hs0000644000000000000000000000511412722676543024342 0ustar0000000000000000-- | -- 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 . Return element associated with key" , process = doCmd "where" } , (command "url") { help = say "url . Return element associated with key" , process = doCmd "url" } , (command "what") { help = say "what . Return element associated with key" , process = doCmd "what" } , (command "where+") { help = say "where+ . Define an association" , process = doCmd "where+" } ] } doCmd :: String -> String -> Cmd Where () doCmd cmd rest = (say =<<) . withMS $ \factFM writer -> case words rest of [] -> return "@where , 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 lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Url.hs0000644000000000000000000001241412722676543024033 0ustar0000000000000000{-# 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 . Fetch the page title." , process = maybe (say "Url not valid.") (mbSay <=< fetchTitle) . containsUrl } , (command "tiny-url") { help = say "tiny-url . Shorten ." , 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) lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Ticker.hs0000644000000000000000000001167212722676543024517 0ustar0000000000000000-- | 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 lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Spell.hs0000644000000000000000000001004612722676543024347 0ustar0000000000000000{-# 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 . 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 ::= & : , , ... -- None ::= # -- 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 lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Search.hs0000644000000000000000000001271112722676543024476 0ustar0000000000000000{-# 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 . Search google and show url of first hit" -- "wikipedia" -> "wikipedia . Search wikipedia and show url of first hit" "gsite" -> "gsite . Search for using google" "gwiki" -> "gwiki . Search (new) haskell.org wiki for 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, let txt = take 80 $ strip isSpace $ drop 1 $ dropWhile (/= '=') $ extractText section, not (null txt)] extractText :: [Tag String] -> String extractText (TagText t : ts) = t ++ extractText ts extractText (TagOpen "sup" _ : TagText t : TagClose "sup" : ts) = "^" ++ t ++ extractText ts extractText (TagClose "h2" : _) = "" extractText (_ : ts) = extractText ts extractText _ = "" lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Dict/0000755000000000000000000000000012722676543023616 5ustar0000000000000000lambdabot-reference-plugins-5.1/src/Lambdabot/Plugin/Reference/Dict/DictLookup.hs0000644000000000000000000000643712722676543026241 0ustar0000000000000000-- -- | DICT (RFC 2229) Lookup -- Tom Moertel -- --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 | Right 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") lambdabot-reference-plugins-5.1/src/Lambdabot/Config/0000755000000000000000000000000012722676543021004 5ustar0000000000000000lambdabot-reference-plugins-5.1/src/Lambdabot/Config/Reference.hs0000644000000000000000000000065612722676543023245 0ustar0000000000000000{-# 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" |]