{-# 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="forall a. [a] -> [a] -> [a]
++String
sforall 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"forall a. [a] -> [a] -> [a]
++String
sforall 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+" forall a. [a] -> [a] -> [a]
++String
sforall 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 :: forall (m :: * -> *) a. MonadLB m => m (NormalizeRequestOptions a)
normalizeOptions = do
    Proxy
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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions
        { normDoClose :: Bool
normDoClose = Bool
True
        , normForProxy :: Bool
normForProxy = Bool
hasProxy
        , normUserAgent :: Maybe String
normUserAgent = 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 = forall a. a -> Maybe a
Just (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 = forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
name)
            { help :: Cmd (ModuleT () LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> String
moduleHelp String
name)
            , process :: String -> Cmd (ModuleT () LB) ()
process = \String
e -> do
                String
s <- forall (m :: * -> *). Monad m => Cmd m String
getCmdName
                forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> String -> LB [String]
searchCmd String
s (forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace String
e)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say
            }
        | String
name <- forall a b. (a -> b) -> [a] -> [b]
map 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 \"" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"\""

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

searchCmd :: String -> String -> LB [String]
searchCmd :: String -> String -> LB [String]
searchCmd String
_          []   = forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Empty search."]
searchCmd String
engineName (String -> String
urlEncode -> String
query)
    | String
engineName 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'
        forall a.
HStream a =>
Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP Request String
request 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  forall {m :: * -> *}. MonadLB m => String -> [String] -> m [String]
handleUrl String
url
                Response String
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[String]
extra -> if 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'
        forall a.
HStream a =>
Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP Request String
request 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) } ->
                    forall {m :: * -> *}. MonadLB m => String -> [String] -> m [String]
handleUrl String
url []
                Response 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 <- forall (m :: * -> *) conn a.
MonadLB m =>
BrowserAction conn a -> m a
browseLB (String -> BrowserAction (HandleStream String) (Maybe String)
urlPageTitle String
url)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String]
extra forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String
url] (\String
t -> [String
url, String
"Title: " forall a. [a] -> [a] -> [a]
++ String
t]) Maybe String
title
        Just (URI
uri, String -> String
makeQuery, [Header]
headers) = 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 <- forall (m :: * -> *) a. MonadLB m => m (NormalizeRequestOptions a)
normalizeOptions
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeRequest NormalizeRequestOptions String
opts forall a b. (a -> b) -> a -> b
$ 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'
            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=" forall a. [a] -> [a] -> [a]
++ String
query } }) 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) } ->
                        forall (m :: * -> *) a. Monad m => a -> m a
return [String
result]
                    Response String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []

doHTTP :: HStream a => Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP :: forall a.
HStream a =>
Request a -> (Response a -> LB [String]) -> LB [String]
doHTTP Request a
request Response a -> LB [String]
handler = do
    Result (Response a)
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP Request a
request
    case Result (Response a)
result of
        Left ConnError
connError -> forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Connection error: "forall a. [a] -> [a] -> [a]
++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 (forall str. StringLike str => str -> [Tag str]
parseTags -> [Tag String]
tags) = forall a. [a] -> Maybe a
listToMaybe [String
txt |
    [Tag String]
section <- forall a. (a -> Bool) -> [a] -> [[a]]
sections (forall str.
(str -> Bool) -> ([Attribute str] -> Bool) -> Tag str -> Bool
tagOpen (String
"h2"forall a. Eq a => a -> a -> Bool
==) (forall str. ((str, str) -> Bool) -> [(str, str)] -> Bool
anyAttr (\(String
name, String
value) -> String
name forall a. Eq a => a -> a -> Bool
== String
"class" Bool -> Bool -> Bool
&& String
value forall a. Eq a => a -> a -> Bool
== String
"r"))) [Tag String]
tags,
    let txt :: String
txt = forall a. Int -> [a] -> [a]
take Int
80 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'=') forall a b. (a -> b) -> a -> b
$ [Tag String] -> String
extractText [Tag String]
section,
    Bool -> Bool
not (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 forall a. [a] -> [a] -> [a]
++ [Tag String] -> String
extractText [Tag String]
ts
extractText (TagOpen String
"sup" [(String, String)]
_ : TagText String
t : TagClose String
"sup" : [Tag String]
ts) = String
"^" forall a. [a] -> [a] -> [a]
++ String
t 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
""