{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.URI.Fetch(Session(..), newSession, fetchURL) 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
#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
data Session = Session {
locale :: [String],
#ifdef WITH_HTTP_URI
managerHTTP :: HTTP.Manager
#endif
}
newSession :: IO Session
newSession = do
locale' <- rfc2616Locale
#ifdef WITH_HTTP_URI
managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings
#endif
return Session {
locale = locale',
#ifdef WITH_HTTP_URI
managerHTTP = managerHTTP'
#endif
}
fetchURL :: Session -> [String] -> URI -> IO (String, Either Text ByteString)
#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)
#endif
#ifdef WITH_FILE_URI
fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "file:"} = do
response <- B.readFile $ uriPath uri
return (defaultMIME, Right response)
#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
fetchURL _ _ uri = return ("text/plain", Left $ Txt.concat ["Unsupported link type ", Txt.pack $ uriScheme uri])
#ifdef WITH_DATA_URI
breakOn c (a:as) | c == a = ([], as)
| otherwise = let (x, y) = breakOn c as in (a:x, y)
breakOn _ [] = ([], [])
#endif