content: {-# 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%3Awiki.haskell.org+" ++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 <expr>. Search google and show url of first hit"
      -- "wikipedia" -> "wikipedia <expr>. Search wikipedia and show url of first hit"
      "gsite"     -> "gsite <site> <expr>. Search <site> for <expr> using google"
      "gwiki"     -> "gwiki <expr>. Search (new) haskell.org wiki for <expr> 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 _ = ""
  