Fetch.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Retrieves documents for a URL, supporting multiple URL schemes that can be
-- disabled at build-time for reduced dependencies.
module Network.URI.Fetch(Session, locale, newSession, fetchURL, dispatchByMIME) where

import qualified Data.Text as Txt
import           Data.Text (Text)
import           Network.URI
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import           Control.Exception

#ifdef WITH_HTTP_URI
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as TLS
import           Network.HTTP.Types
import           Network.URI.Charset
import           Data.List (intercalate)
#endif

#ifdef WITH_DATA_URI
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Base64 as B64
#endif

import Network.URI.Locale
import Network.URI.Messages

#ifdef WITH_XDG
import Network.URI.XDG
#endif

-- | Data shared accross multiple URI requests.
data Session = Session {
#ifdef WITH_HTTP_URI
    managerHTTP :: HTTP.Manager,
#endif
#ifdef WITH_XDG
    apps :: HandlersConfig,
#endif
    -- | The languages (RFC2616-encoded) to which responses should be localized.
    locale :: [String]
}

-- | Initializes a default Session object to support HTTPS & Accept-Language
-- if HTTP is enabled.
newSession :: IO Session
newSession = do
    locale' <- rfc2616Locale
#ifdef WITH_HTTP_URI
    managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings
#endif
#ifdef WITH_XDG
    apps' <- loadHandlers
#endif

    return Session {
#ifdef WITH_HTTP_URI
        managerHTTP = managerHTTP',
#endif
#ifdef WITH_XDG
        apps = apps',
#endif
        locale = locale'
    }

-- | Retrieves a URL-identified resource & it's MIMEtype, possibly decoding it's text.
fetchURL :: Session -- ^ The session of which this request is a part.
    -> [String] -- ^ The expected MIMEtypes in priority order.
    -> URI -- ^ The URL to retrieve
    -> IO (String, Either Text ByteString) -- ^ The MIMEtype & possibly text-decoded response.
#ifdef WITH_HTTP_URI
fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do
    request <- HTTP.requestFromURI uri
    response <- HTTP.httpLbs request {
            HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form.
            HTTP.requestHeaders = [
                ("Accept", C8.pack $ intercalate ", " accept),
                ("Accept-Language", C8.pack $ intercalate ", " $ locale session)
            ]
        } $ managerHTTP session
    return $ case (
            HTTP.responseBody response,
            [val | ("content-type", val) <- HTTP.responseHeaders response]
      ) of
        ("", _) -> ("text/plain", Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response)
        (response, (mimetype:_)) -> let mime = Txt.toLower $ convertCharset "utf-8" mimetype
            in resolveCharset (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" $ mime) response
        (response, []) -> (defaultMIME, Right response)
  `catches` [
    Handler $ \e -> do return ("text/plain", Left $ Txt.pack $ trans (locale session) $ Http e),
    Handler $ \(ErrorCall msg) -> do return ("text/plain", Left $ Txt.pack msg)
  ]
#endif

#ifdef WITH_FILE_URI
fetchURL Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do
    response <- B.readFile $ uriPath uri
    return (defaultMIME, Right response)
  `catch` \e -> do
    return (
        "text/plain",
        Left $ Txt.pack $ trans l $ ReadFailed $ displayException (e :: IOException))
#endif

#ifdef WITH_DATA_URI
fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
    let request = uriPath uri ++ uriQuery uri ++ uriFragment uri
    in case breakOn ',' $ unEscapeString request of
        ("", response) -> return (defaultMIME, Left $ Txt.pack response)
        (mime', response) | '4':'6':'e':'s':'a':'b':';':mime <- reverse mime' ->
            return $ case B64.decode $ C8.pack response of
                Left str -> ("text/plain", Left $ Txt.pack str)
                Right bytes -> (reverse mime, Right $ B.fromStrict bytes)
        (mime, response) -> return (mime, Left $ Txt.pack response)
#endif

#ifdef WITH_XDG
fetchURL Session {locale = l, apps = a} _ uri@(URI {uriScheme = s})
    | canDispatchMIME a ("x-scheme-handler/" ++ init s) = do
        app <- dispatchURIByMIME l a uri ("x-scheme-handler/" ++ init s)
        return (
            "text/plain",
            Left $ Txt.pack $ trans l $ case app of
                Just name -> OpenedWith name
                Nothing -> UnsupportedScheme s)
#endif

fetchURL Session {locale = l} _ URI {uriScheme = scheme} =
    return ("text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)

dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)
#if WITH_XDG
dispatchByMIME Session {locale = l, apps = a} mime uri = dispatchURIByMIME l a uri mime
#else
dispatchByMIME _ _ _ = return Nothing
#endif

#ifdef WITH_DATA_URI
breakOn c (a:as) | c == a = ([], as)
    | otherwise = let (x, y) = breakOn c as in (a:x, y)
breakOn _ [] = ([], [])
#endif