diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/lambdabot-reference-plugins.cabal b/lambdabot-reference-plugins.cabal new file mode 100644 --- /dev/null +++ b/lambdabot-reference-plugins.cabal @@ -0,0 +1,75 @@ +name: lambdabot-reference-plugins +version: 5.0 + +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.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 diff --git a/src/Lambdabot/Config/Reference.hs b/src/Lambdabot/Config/Reference.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Config/Reference.hs @@ -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" |] diff --git a/src/Lambdabot/Plugin/Reference.hs b/src/Lambdabot/Plugin/Reference.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference.hs @@ -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"] diff --git a/src/Lambdabot/Plugin/Reference/Dict.hs b/src/Lambdabot/Plugin/Reference/Dict.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/Dict.hs @@ -0,0 +1,112 @@ +{-# 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 -> 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" + diff --git a/src/Lambdabot/Plugin/Reference/Dict/DictLookup.hs b/src/Lambdabot/Plugin/Reference/Dict/DictLookup.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/Dict/DictLookup.hs @@ -0,0 +1,99 @@ +-- +-- | 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") diff --git a/src/Lambdabot/Plugin/Reference/Metar.hs b/src/Lambdabot/Plugin/Reference/Metar.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/Metar.hs @@ -0,0 +1,51 @@ +-- | 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://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." diff --git a/src/Lambdabot/Plugin/Reference/OEIS.hs b/src/Lambdabot/Plugin/Reference/OEIS.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/OEIS.hs @@ -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 . Look up a sequence in the Online Encyclopedia of Integer Sequences" + , process = ios80 . fmap concat . lookupOEIS + } + ] + } diff --git a/src/Lambdabot/Plugin/Reference/Search.hs b/src/Lambdabot/Plugin/Reference/Search.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/Search.hs @@ -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 . 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, + txt <- [strip isSpace $ drop 1 $ dropWhile (/= '=') t | TagText t <- section], + not (null txt)] diff --git a/src/Lambdabot/Plugin/Reference/Spell.hs b/src/Lambdabot/Plugin/Reference/Spell.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/Spell.hs @@ -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 . 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 diff --git a/src/Lambdabot/Plugin/Reference/Ticker.hs b/src/Lambdabot/Plugin/Reference/Ticker.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/Ticker.hs @@ -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 + diff --git a/src/Lambdabot/Plugin/Reference/Url.hs b/src/Lambdabot/Plugin/Reference/Url.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/Url.hs @@ -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 . 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) diff --git a/src/Lambdabot/Plugin/Reference/Where.hs b/src/Lambdabot/Plugin/Reference/Where.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Reference/Where.hs @@ -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 . 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 diff --git a/src/Lambdabot/Util/Browser.hs b/src/Lambdabot/Util/Browser.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Util/Browser.hs @@ -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)