{-# 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 :: [(String, (URI, String -> String, [Header]))]
engines =
   [(String
"google", (URI
googleUri, (\String
s -> String
"?hl=en&q="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"&btnI=I'm+Feeling+Lucky"), [Header]
googleHeaders)),
    -- ("wikipedia", (wikipediaUri, ("?search="++), [])), -- this has changed and Wikipedia requires a User-Agent string
    (String
"gsite", (URI
googleUri, (\String
s -> String
"?hl=en&q=site%3A"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"&btnI=I'm+Feeling+Lucky"), [Header]
googleHeaders)),
    (String
"gwiki", (URI
googleUri, (\String
s -> String
"?hl=en&q=site%3Awiki.haskell.org+" String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"&btnI=I'm+Feeling+Lucky"), [Header]
googleHeaders))
   ]

googleHeaders :: [Header]
googleHeaders :: [Header]
googleHeaders = [HeaderName -> String -> Header
mkHeader HeaderName
HdrReferer String
"http://www.google.com/"]

normalizeOptions :: MonadLB m => m (NormalizeRequestOptions a)
normalizeOptions :: m (NormalizeRequestOptions a)
normalizeOptions = do
    Proxy
proxy' <- Config Proxy -> m Proxy
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Proxy
proxy
    let hasProxy :: Bool
hasProxy = case Proxy
proxy' of
            Proxy
NoProxy -> Bool
False
            Proxy
_       -> Bool
True
    NormalizeRequestOptions a -> m (NormalizeRequestOptions a)
forall (m :: * -> *) a. Monad m => a -> m a
return NormalizeRequestOptions a
forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions
        { normDoClose :: Bool
normDoClose = Bool
True
        , normForProxy :: Bool
normForProxy = Bool
hasProxy
        , normUserAgent :: Maybe String
normUserAgent = Maybe String
forall a. Maybe a
Nothing
        } -- there is a default user agent, perhaps we want it?

makeUri :: String -> String -> URI
makeUri :: String -> String -> URI
makeUri String
regName String
path = URI
nullURI {
    uriScheme :: String
uriScheme = String
"http:",
    uriAuthority :: Maybe URIAuth
uriAuthority = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth :: String -> String -> String -> URIAuth
URIAuth { uriUserInfo :: String
uriUserInfo = String
"", uriRegName :: String
uriRegName = String
regName, uriPort :: String
uriPort = String
"" }),
    uriPath :: String
uriPath = String
path }

googleUri :: URI
googleUri :: URI
googleUri = String -> String -> URI
makeUri String
"www.google.com" String
"/search"
-- wikipediaUri = makeUri "en.wikipedia.org" "/wiki/Special:Search"

searchPlugin :: Module ()
searchPlugin :: Module ()
searchPlugin = Module ()
forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = [Command (ModuleT () LB)]
-> ModuleT () LB [Command (ModuleT () LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
name)
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> String
moduleHelp String
name)
            , process :: String -> Cmd (ModuleT () LB) ()
process = \String
e -> do
                String
s <- Cmd (ModuleT () LB) String
forall (m :: * -> *). Monad m => Cmd m String
getCmdName
                LB [String] -> Cmd (ModuleT () LB) [String]
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> String -> LB [String]
searchCmd String
s ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace String
e)) Cmd (ModuleT () LB) [String]
-> ([String] -> Cmd (ModuleT () LB) ()) -> Cmd (ModuleT () LB) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Cmd (ModuleT () LB) ())
-> [String] -> Cmd (ModuleT () LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say
            }
        | String
name <- ((String, (URI, String -> String, [Header])) -> String)
-> [(String, (URI, String -> String, [Header]))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (URI, String -> String, [Header])) -> String
forall a b. (a, b) -> a
fst [(String, (URI, String -> String, [Header]))]
engines
        ]
    }

moduleHelp :: String -> String
moduleHelp :: String -> String
moduleHelp String
s = case String
s of
    String
"google"    -> String
"google <expr>. Search google and show url of first hit"
    -- "wikipedia" -> "wikipedia <expr>. Search wikipedia and show url of first hit"
    String
"gsite"     -> String
"gsite <site> <expr>. Search <site> for <expr> using google"
    String
"gwiki"     -> String
"gwiki <expr>. Search (new) haskell.org wiki for <expr> using google."
    String
_           -> String
"Search Plugin does not have command \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

------------------------------------------------------------------------

searchCmd :: String -> String -> LB [String]
searchCmd :: String -> String -> LB [String]
searchCmd String
_          []   = [String] -> LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Empty search."]
searchCmd String
engineName (String -> String
urlEncode -> String
query)
    | String
engineName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"google" = do -- for Google we do both to get conversions, e.g. for '3 lbs in kg'
        Request String
request <- LB (Request String)
request'
        Request String -> (Response String -> LB [String]) -> LB [String]
forall a.
HStream a =>
Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP Request String
request ((Response String -> LB [String]) -> LB [String])
-> (Response String -> LB [String]) -> LB [String]
forall a b. (a -> b) -> a -> b
$ \Response String
response ->
            case Response String
response of
                Response { rspCode :: forall a. Response a -> ResponseCode
rspCode = (Int
3,Int
0,Int
2), rspHeaders :: forall a. Response a -> [Header]
rspHeaders = (HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrLocation -> Just String
url) } ->
                    LB [String]
doGoogle LB [String] -> ([String] -> LB [String]) -> LB [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  String -> [String] -> LB [String]
forall (m :: * -> *). MonadLB m => String -> [String] -> m [String]
handleUrl String
url
                Response String
_ -> ([String] -> [String]) -> LB [String] -> LB [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[String]
extra -> if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extra then [String
"No Result Found."] else [String]
extra) LB [String]
doGoogle
    | Bool
otherwise = do
        Request String
request <- LB (Request String)
request'
        Request String -> (Response String -> LB [String]) -> LB [String]
forall a.
HStream a =>
Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP Request String
request ((Response String -> LB [String]) -> LB [String])
-> (Response String -> LB [String]) -> LB [String]
forall a b. (a -> b) -> a -> b
$ \Response String
response ->
            case Response String
response of
                Response { rspCode :: forall a. Response a -> ResponseCode
rspCode = (Int
3,Int
0,Int
2), rspHeaders :: forall a. Response a -> [Header]
rspHeaders = (HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrLocation -> Just String
url) } ->
                    String -> [String] -> LB [String]
forall (m :: * -> *). MonadLB m => String -> [String] -> m [String]
handleUrl String
url []
                Response String
_ -> [String] -> LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"No Result Found."]
  where handleUrl :: String -> [String] -> m [String]
handleUrl String
url [String]
extra = do
            Maybe String
title <- BrowserAction (HandleStream String) (Maybe String)
-> m (Maybe String)
forall (m :: * -> *) conn a.
MonadLB m =>
BrowserAction conn a -> m a
browseLB (String -> BrowserAction (HandleStream String) (Maybe String)
urlPageTitle String
url)
            [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ [String]
extra [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String
url] (\String
t -> [String
url, String
"Title: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t]) Maybe String
title
        Just (URI
uri, String -> String
makeQuery, [Header]
headers) = String
-> [(String, (URI, String -> String, [Header]))]
-> Maybe (URI, String -> String, [Header])
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
engineName [(String, (URI, String -> String, [Header]))]
engines
        request' :: LB (Request String)
request' = do
            NormalizeRequestOptions String
opts <- LB (NormalizeRequestOptions String)
forall (m :: * -> *) a. MonadLB m => m (NormalizeRequestOptions a)
normalizeOptions
            Request String -> LB (Request String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request String -> LB (Request String))
-> Request String -> LB (Request String)
forall a b. (a -> b) -> a -> b
$ NormalizeRequestOptions String -> Request String -> Request String
forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeRequest NormalizeRequestOptions String
opts (Request String -> Request String)
-> Request String -> Request String
forall a b. (a -> b) -> a -> b
$ Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request
                { rqURI :: URI
rqURI = URI
uri { uriQuery :: String
uriQuery = String -> String
makeQuery String
query }
                , rqMethod :: RequestMethod
rqMethod = RequestMethod
HEAD
                , rqHeaders :: [Header]
rqHeaders = [Header]
headers
                , rqBody :: String
rqBody = String
""
                }
        doGoogle :: LB [String]
doGoogle = do
            Request String
request <- LB (Request String)
request'
            Request String -> (Response String -> LB [String]) -> LB [String]
forall a.
HStream a =>
Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP (Request String
request { rqMethod :: RequestMethod
rqMethod = RequestMethod
GET, rqURI :: URI
rqURI = URI
uri { uriQuery :: String
uriQuery = String
"?hl=en&q=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
query } }) ((Response String -> LB [String]) -> LB [String])
-> (Response String -> LB [String]) -> LB [String]
forall a b. (a -> b) -> a -> b
$ \Response String
response ->
                case Response String
response of
                    Response { rspCode :: forall a. Response a -> ResponseCode
rspCode = (Int
2,Int
_,Int
_), rspBody :: forall a. Response a -> a
rspBody = (String -> Maybe String
extractConversion -> Just String
result) } ->
                        [String] -> LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
result]
                    Response String
_ -> [String] -> LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

doHTTP :: HStream a => Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP :: Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP Request a
request Response a -> LB [String]
handler = do
    Result (Response a)
result <- IO (Result (Response a)) -> LB (Result (Response a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Result (Response a)) -> LB (Result (Response a)))
-> IO (Result (Response a)) -> LB (Result (Response a))
forall a b. (a -> b) -> a -> b
$ Request a -> IO (Result (Response a))
forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP Request a
request
    case Result (Response a)
result of
        Left ConnError
connError -> [String] -> LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Connection error: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ConnError -> String
forall a. Show a => a -> String
show ConnError
connError]
        Right Response a
response -> Response a -> LB [String]
handler Response a
response

-- This is clearly fragile.
extractConversion :: String -> Maybe String
extractConversion :: String -> Maybe String
extractConversion (String -> [Tag String]
forall str. StringLike str => str -> [Tag str]
parseTags -> [Tag String]
tags) = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String
txt |
    [Tag String]
section <- (Tag String -> Bool) -> [Tag String] -> [[Tag String]]
forall a. (a -> Bool) -> [a] -> [[a]]
sections ((String -> Bool)
-> ([Attribute String] -> Bool) -> Tag String -> Bool
forall str.
(str -> Bool) -> ([Attribute str] -> Bool) -> Tag str -> Bool
tagOpen (String
"h2"String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) ((Attribute String -> Bool) -> [Attribute String] -> Bool
forall str. ((str, str) -> Bool) -> [(str, str)] -> Bool
anyAttr (\(String
name, String
value) -> String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"class" Bool -> Bool -> Bool
&& String
value String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"r"))) [Tag String]
tags,
    let txt :: String
txt = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
80 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [Tag String] -> String
extractText [Tag String]
section,
    Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
txt)]

extractText :: [Tag String] -> String
extractText :: [Tag String] -> String
extractText (TagText String
t : [Tag String]
ts) = String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Tag String] -> String
extractText [Tag String]
ts
extractText (TagOpen String
"sup" [Attribute String]
_ : TagText String
t : TagClose String
"sup" : [Tag String]
ts) = String
"^" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Tag String] -> String
extractText [Tag String]
ts
extractText (TagClose String
"h2" : [Tag String]
_) = String
""
extractText (Tag String
_ : [Tag String]
ts) = [Tag String] -> String
extractText [Tag String]
ts
extractText [Tag String]
_ = String
""