# LANGUAGE PatternGuards #

-- | URL Utility Functions

module Lambdabot.Util.Browser
    ( urlPageTitle
    , browseLB
    ) where

import Codec.Binary.UTF8.String
import Control.Applicative
import Control.Monad.Trans
import Lambdabot.Config
import Lambdabot.Config.Reference
import Lambdabot.Monad
import Lambdabot.Util (limitStr)
import Network.Browser
import Network.HTTP
import Network.URI
import Text.HTML.TagSoup
import Text.HTML.TagSoup.Match
import Data.Char (toLower)
import Data.List (isPrefixOf)

-- | Run a browser action with some standardized settings
browseLB :: MonadLB m => BrowserAction conn a -> m a
browseLB act = lb $ do
    proxy' <- getConfig proxy
    liftIO . browse $ do
        setOutHandler (const (return ()))
        setErrHandler (const (return ()))

        setAllowRedirects True
        setMaxRedirects (Just 5)
        setProxy proxy'
        act

-- | Limit the maximum title length to prevent jokers from spamming
-- the channel with specially crafted HTML pages.
maxTitleLength :: Int
maxTitleLength = 80

-- | 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 -> BrowserAction (HandleStream String) (Maybe String)
urlPageTitle = fmap (fmap (limitStr maxTitleLength)) . rawPageTitle

-- | 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 -> BrowserAction (HandleStream String) (Maybe String)
rawPageTitle url = checkHTTPS $ do
    (_, result) <- request (getRequest (takeWhile (/='#') url))
    case rspCode result of
        (2,0,0)   -> do
            case takeWhile (/= ';') <$> lookupHeader HdrContentType (rspHeaders result) of
                Just "text/html"       -> return $ extractTitle (rspBody result)
                Just "application/pdf" -> rawPageTitle (googleCacheURL url)
                _                      -> return $ Nothing
        _         -> return Nothing
    
    where googleCacheURL = (gURL++) . escapeURIString (const False)
          gURL = ":"
          checkHTTPS act | "https:" `isPrefixOf` map toLower url = return Nothing
                         | otherwise = act

  | Given a server response ( list of  ) , 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 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)

 | URL Utility Functions
 | Run a browser action with some standardized settings
 | Limit the maximum title length to prevent jokers from spamming
 the channel with specially crafted HTML pages.
 | Fetches a page title suitable for display.  Ideally, other
 plugins should make use of this function if the result is to be
 look is used (and also lets the URL plugin effectively ignore
 contextual URLs that might be generated by another instance of
 | 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
 between the title HTML element, only if it is text/html content.
 Now supports all(?) HTML entities thanks to TagSoup.
# LANGUAGE PatternGuards #


module Lambdabot.Util.Browser
    ( urlPageTitle
    , browseLB
    ) where

import Codec.Binary.UTF8.String
import Control.Applicative
import Control.Monad.Trans
import Lambdabot.Config
import Lambdabot.Config.Reference
import Lambdabot.Monad
import Lambdabot.Util (limitStr)
import Network.Browser
import Network.HTTP
import Network.URI
import Text.HTML.TagSoup
import Text.HTML.TagSoup.Match
import Data.Char (toLower)
import Data.List (isPrefixOf)

browseLB :: MonadLB m => BrowserAction conn a -> m a
browseLB act = lb $ do
    proxy' <- getConfig proxy
    liftIO . browse $ do
        setOutHandler (const (return ()))
        setErrHandler (const (return ()))

        setAllowRedirects True
        setMaxRedirects (Just 5)
        setProxy proxy'
        act

maxTitleLength :: Int
maxTitleLength = 80

  displayed in an IRC channel because it ensures that a consistent
  lambdabot ; the URL plugin matches on ' urlTitlePrompt ' ) .
urlPageTitle :: String -> BrowserAction (HandleStream String) (Maybe String)
urlPageTitle = fmap (fmap (limitStr maxTitleLength)) . rawPageTitle

  be displayed in an IRC channel .   Instead , use ' urlPageTitle ' .
rawPageTitle :: String -> BrowserAction (HandleStream String) (Maybe String)
rawPageTitle url = checkHTTPS $ do
    (_, result) <- request (getRequest (takeWhile (/='#') url))
    case rspCode result of
        (2,0,0)   -> do
            case takeWhile (/= ';') <$> lookupHeader HdrContentType (rspHeaders result) of
                Just "text/html"       -> return $ extractTitle (rspBody result)
                Just "application/pdf" -> rawPageTitle (googleCacheURL url)
                _                      -> return $ Nothing
        _         -> return Nothing
    
    where googleCacheURL = (gURL++) . escapeURIString (const False)
          gURL = ":"
          checkHTTPS act | "https:" `isPrefixOf` map toLower url = return Nothing
                         | otherwise = act

  | Given a server response ( list of  ) , return the text in
extractTitle :: String -> Maybe String
extractTitle = content . tags . decodeString 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)
