module Text.XML.HXT.IO.GetHTTPNative
( module Text.XML.HXT.IO.GetHTTPNative
)
where
import Control.Arrow
import Control.Exception (try)
import Text.XML.HXT.DOM.TypeDefs (Attributes)
import Text.XML.HXT.DOM.Util (stringTrim)
import Text.XML.HXT.DOM.XmlKeywords
import Text.XML.HXT.Arrow.XmlOptions (a_if_modified_since,
a_if_unmodified_since)
import Text.XML.HXT.Parser.ProtocolHandlerUtil (parseContentType)
import Text.ParserCombinators.Parsec (parse)
import qualified Data.ByteString.Lazy as B
import Data.Char (isDigit)
import Data.Int (Int64)
import Data.List (isPrefixOf)
import Data.Maybe
import System.IO (hPutStrLn, stderr)
import System.IO.Error (ioeGetErrorString)
import Network.Browser (BrowserAction,
Proxy (..), browse,
defaultGETRequest_,
request,
setAllowRedirects,
setErrHandler,
setMaxRedirects,
setOutHandler,
setProxy)
import Network.HTTP (Header (..),
HeaderName (..),
Request (..),
Response (..),
httpVersion,
replaceHeader)
import Network.Socket (withSocketsDo)
import Network.URI (URI,
parseURIReference)
getCont :: Bool -> String -> String -> Bool -> Attributes ->
IO (Either ([(String, String)], String)
([(String, String)], B.ByteString)
)
getCont strictInput proxy uri redirect options
= do
res <- try (getHttp False uri1 proxy redirect options)
either processError processResponse res
where
uri1 = fromJust (parseURIReference uri)
processError e
= return $
Left ( [ (transferStatus, "999")
, (transferMessage, "HTTP library error")
]
, "http error when requesting URI "
++ show uri
++ ": "
++ ioeGetErrorString e
++ " (perhaps server does not understand HTTP/1.1) "
)
processResponse response
| ( (rc >= 200 && rc < 300)
||
rc == 304
)
&&
fileSizeOK
= do
if strictInput
then B.length cs `seq` return res
else return res
| not fileSizeOK
= return $
ers "999 max-filesize exceeded"
| otherwise
= return $
ers (show rc ++ " " ++ rr)
where
fileSizeOK = case getCurlMaxFileSize options of
Nothing -> True
Just mx -> B.length cs <= mx
rc = convertResponseStatus $ rspCode response
rr = rspReason response
res = Right (rs, cs)
ers e = Left (rs, "http error when accessing URI " ++ show uri ++ ": " ++ e)
rs = rst ++ rsh
rst = [ (transferStatus, show rc)
, (transferMessage, rr)
]
rsh = convertResponseHeaders response
cs = rspBody response
getHttp :: Bool -> URI -> String -> Bool -> Attributes -> IO (Response B.ByteString)
getHttp trc' uri' proxy' redirect' options'
= withSocketsDo $
browse ( do
sequence_ configHttp
(_ruri, rsp) <- request $ theRequest
return rsp
)
where
theRequest :: Request B.ByteString
theRequest
= configHeaders $ defaultGETRequest_ uri'
configHeaders :: Request B.ByteString -> Request B.ByteString
configHeaders
= foldr (>>>) id . map (uncurry replaceHeader) . concatMap (uncurry setHOption) $ options'
configHttp
= setOutHandler (trcFct)
: setErrHandler (trcFct)
: ( if null proxy'
then return ()
else setProxy (Proxy proxy' Nothing)
)
: setAllowRedirects redirect'
: concatMap (uncurry setOption) options'
trcFct s
| trc'
= hPutStrLn stderr ("-- (5) http: " ++ s)
| otherwise
= return ()
convertResponseStatus :: (Int, Int, Int) -> Int
convertResponseStatus (a, b, c)
= 100 * a + 10 * b + c
convertResponseHeaders :: Response B.ByteString -> [(String, String)]
convertResponseHeaders r'
= cvResponseCode (rspCode r')
++
cvResponseReason (rspReason r')
++
cvResponseHeaders (rspHeaders r')
where
cvResponseCode :: (Int, Int, Int) -> [(String, String)]
cvResponseCode st'
= [ (transferStatus, show (convertResponseStatus st'))
, (transferVersion, httpVersion)
]
cvResponseReason :: String -> [(String, String)]
cvResponseReason r''
= [ (transferMessage, (stringTrim r'')) ]
cvResponseHeaders :: [Header] -> [(String, String)]
cvResponseHeaders
= concatMap cvResponseHeader
cvResponseHeader :: Header -> [(String, String)]
cvResponseHeader (Header name value)
| name == HdrContentType
= ( case (parse parseContentType (show HdrContentType) value) of
Right res -> res
Left _ -> []
)
++
addHttpAttr
| otherwise
= addHttpAttr
where
addHttpAttr = [ (httpPrefix ++ (show name), value) ]
setOption :: String -> String -> [BrowserAction t ()]
setOption k0 v
| k == "max-redirs"
&&
isIntArg v = [setMaxRedirects (Just $ read v)]
| k == "max-redirs"
&&
null v = [setMaxRedirects Nothing]
| otherwise = []
where
k = dropCurlPrefix k0
curlPrefix :: String
curlPrefix = "curl--"
dropCurlPrefix :: String -> String
dropCurlPrefix k
| curlPrefix `isPrefixOf` k = drop (length curlPrefix) k
| otherwise = k
setHOption :: String -> String -> [(HeaderName, String)]
setHOption k0 v
| k `elem` [ "-A"
, "user-agent"
, "curl--user-agent"
] = [(HdrUserAgent, v)]
| k `elem` [ "-e"
, "referer"] = [(HdrReferer, v)]
| k == a_if_modified_since = [(HdrIfModifiedSince, v)]
| k == a_if_unmodified_since = [(HdrIfUnmodifiedSince, v)]
| otherwise = []
where
k = dropCurlPrefix k0
isIntArg :: String -> Bool
isIntArg s = not (null s) && all isDigit s
getCurlMaxFileSize :: Attributes -> Maybe Int64
getCurlMaxFileSize options
= (\ s -> if isIntArg s
then Just (read s)
else Nothing
)
. fromMaybe ""
. lookup (curlPrefix ++ "max-filesize")
$ options