{-# LANGUAGE ViewPatterns #-}
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)),
(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]
= [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
}
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"
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"
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
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
extractConversion :: String -> Maybe String
(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
(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
""