    {-# 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 :: forall (m :: * -> *) a. MonadLB m => m (NormalizeRequestOptions a)
    normalizeOptions = do
        proxy' <- Config Proxy -> m Proxy
    forall a. Config a -> m a
    forall (m :: * -> *) a. MonadConfig m => Config a -> m a
    getConfig Config Proxy
    proxy
        let hasProxy = case Proxy
    proxy' of
                Proxy
    NoProxy -> Bool
    False
                Proxy
    _       -> Bool
    True
        return defaultNormalizeRequestOptions
            { normDoClose = True
            , normForProxy = hasProxy
            , normUserAgent = 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 = "http:",
        uriAuthority = Just (URIAuth { uriUserInfo = "", uriRegName = regName, uriPort = "" }),
        uriPath = 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 = return
            [ (command name)
                { help = say (moduleHelp name)
                , process = \String
    e -> do
                    s <- Cmd (ModuleT () LB) String
    forall (m :: * -> *). Monad m => Cmd m String
    getCmdName
                    lb (searchCmd s (strip isSpace e)) >>= mapM_ say
                }
            | name <- map fst 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 a. a -> LB a
    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 <- LB (Request String)
    request'
            doHTTP request $ \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 a b. LB a -> (a -> LB b) -> LB b
    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 a b. (a -> b) -> LB a -> LB b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\[String]
    extra -> if [String] -> Bool
    forall a. [a] -> 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 <- LB (Request String)
    request'
            doHTTP request $ \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 a. a -> LB a
    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
                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)
                return $ extra ++ maybe [url] (\String
    t -> [String
    url, String
    "Title: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    t]) 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
                opts <- LB (NormalizeRequestOptions String)
    forall (m :: * -> *) a. MonadLB m => m (NormalizeRequestOptions a)
    normalizeOptions
                return $ normalizeRequest opts $ Request
                    { rqURI = uri { uriQuery = makeQuery query }
                    , rqMethod = HEAD
                    , rqHeaders = headers
                    , rqBody = ""
                    }
            doGoogle :: LB [String]
    doGoogle = do
                request <- LB (Request String)
    request'
                doHTTP (request { rqMethod = GET, rqURI = uri { uriQuery = "?hl=en&q=" ++ query } }) $ \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 a. a -> LB a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [String
    result]
                        Response String
    _ -> [String] -> LB [String]
    forall a. a -> LB a
    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 <- 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 of
            Left ConnError
    connError -> [String] -> LB [String]
    forall a. a -> LB a
    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 a. [a] -> 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
    ""