{-# LANGUAGE PatternGuards #-}
-- | URL Utility Functions
module Lambdabot.Url (
getHtmlPage,
getHeader,
rawPageTitle,
urlPageTitle,
urlTitlePrompt,
runWebReq
) where
import Data.List
import Data.Maybe
import Lambdabot.MiniHTTP
import Control.Monad.Reader
import Text.HTML.TagSoup.Parser
import Text.HTML.TagSoup.Match
import Text.HTML.TagSoup
import Codec.Binary.UTF8.String
-- | The string that I prepend to the quoted page title.
urlTitlePrompt :: String
urlTitlePrompt = "Title: "
-- | Limit the maximum title length to prevent jokers from spamming
-- the channel with specially crafted HTML pages.
maxTitleLength :: Int
maxTitleLength = 80
-- | A web request monad transformer for keeping hold of the proxy.
type WebReq a = ReaderT Proxy IO a
runWebReq :: WebReq a -> Proxy -> IO a
runWebReq = runReaderT
-- | Fetches a page title suitable for display. Ideally, other
-- plugins should make use of this function if the result is to be
-- displayed in an IRC channel because it ensures that a consistent
-- look is used (and also lets the URL plugin effectively ignore
-- contextual URLs that might be generated by another instance of
-- lambdabot; the URL plugin matches on 'urlTitlePrompt').
urlPageTitle :: String -> WebReq (Maybe String)
urlPageTitle url = do
title <- rawPageTitle url
return $ maybe Nothing prettyTitle title
where
limitLength s
| length s > maxTitleLength = (take maxTitleLength s) ++ " ..."
| otherwise = s
prettyTitle = Just . (urlTitlePrompt ++) . limitLength
-- | Fetches a page title for the specified URL. This function should
-- only be used by other plugins if and only if the result is not to
-- be displayed in an IRC channel. Instead, use 'urlPageTitle'.
rawPageTitle :: String -> WebReq (Maybe String)
rawPageTitle url
| Just uri <- parseURI url' = do
contents <- getHtmlPage uri
case contentType contents of
Just "text/html" -> return $ extractTitle contents
Just "application/pdf" -> rawPageTitle (googleCacheURL url)
_ -> return $ Nothing
| otherwise = return Nothing
-- URLs containing `#' fail to parse with parseURI, but
-- these kind of URLs are commonly pasted, so we ought to try
-- removing that part of provided URLs.
where url' = takeWhile (/='#') url
googleCacheURL = (gURL++) . escapeURIString (const False)
gURL = "http://www.google.com/search?hl=en&q=cache:"
-- | Fetch the contents of a URL following HTTP redirects. It returns
-- a list of strings comprising the server response which includes the
-- status line, response headers, and body.
getHtmlPage :: URI -> WebReq [String]
getHtmlPage u = getHtmlPage' u 5
where
getHtmlPage' :: URI -> Int -> WebReq [String]
getHtmlPage' _ 0 = return []
getHtmlPage' uri n = do
contents <- getURIContents uri
case responseStatus contents of
301 -> getHtmlPage' (redirectedUrl contents) (n-1)
302 -> getHtmlPage' (redirectedUrl contents) (n-1)
200 -> return contents
_ -> return []
where
-- | Parse the HTTP response code from a line in the following
-- format: HTTP/1.1 200 Success.
responseStatus hdrs = (read . (!!1) . words . (!!0)) hdrs :: Int
-- | Return the value of the "Location" header in the server
-- response
redirectedUrl hdrs
| Just loc <- getHeader "Location" hdrs =
case parseURI loc of
Nothing -> (fromJust . parseURI) $ fullUrl loc
Just uri' -> uri'
| otherwise = error("No Location header found in 3xx response.")
-- | Construct a full absolute URL based on the current uri. This is
-- used when a Location header violates the HTTP RFC and does not send
-- an absolute URI in the response, instead, a relative URI is sent, so
-- we must manually construct the absolute URI.
fullUrl loc = let auth = fromJust $ uriAuthority uri
in (uriScheme uri) ++ "//" ++
(uriRegName auth) ++
loc
-- | Fetch the contents of a URL returning a list of strings
-- comprising the server response which includes the status line,
-- response headers, and body.
getURIContents :: URI -> WebReq [String]
getURIContents uri = do
proxy <- ask
liftIO $ readNBytes 3048 proxy uri (request proxy) ""
where
request Nothing = ["GET " ++ abs_path ++ " HTTP/1.1",
"host: " ++ host,
"Connection: close", ""]
request _ = ["GET " ++ show uri ++ " HTTP/1.0", ""]
abs_path = case uriPath uri ++ uriQuery uri ++ uriFragment uri of
url@('/':_) -> url
url -> '/':url
host = uriRegName . fromJust $ uriAuthority uri
-- | Given a server response (list of Strings), return the text in
-- between the title HTML element, only if it is text/html content.
-- Now supports all(?) HTML entities thanks to TagSoup.
extractTitle :: [String] -> Maybe String
extractTitle = content . tags . decodeString . unlines where
tags = closing . opening . canonicalizeTags . parseTags
opening = dropWhile (not . tagOpenLit "title" (const True))
closing = takeWhile (not . tagCloseLit "title")
content = maybeText . format . innerText
format = unwords . words
maybeText [] = Nothing
maybeText t = Just (encodeString t)
-- | What is the type of the server response?
contentType :: [String] -> Maybe (String)
contentType [] = Nothing
contentType contents = Just val
where
val = takeWhile (/=';') ctype
ctype = case getHeader "Content-Type" contents of
Nothing -> error "Lib.URL.isTextHTML: getHeader failed"
Just c -> c
-- | Retrieve the specified header from the server response being
-- careful to strip the trailing carriage return. I swiped this code
-- from Search.hs, but had to modify it because it was not properly
-- stripping off the trailing CR (must not have manifested itself as a
-- bug in that code; however, parseURI will fail against CR-terminated
-- strings.
getHeader :: String -> [String] -> Maybe String
getHeader _ [] = Nothing
getHeader hdr (_:hs) = lookup hdr $ concatMap mkassoc hs
where
removeCR = takeWhile (/='\r')
mkassoc s = case findIndex (==':') s of
Just n -> [(take n s, removeCR $ drop (n+2) s)]
Nothing -> []