module Text.XML.HXT.IO.GetHTTPNative
( module Text.XML.HXT.IO.GetHTTPNative
)
where
import Text.XML.HXT.DOM.XmlKeywords
import Text.XML.HXT.DOM.Util ( stringTrim )
import Text.XML.HXT.Parser.ProtocolHandlerUtil ( parseContentType )
import Text.ParserCombinators.Parsec ( parse )
import Data.Maybe ( fromJust
)
import System.IO ( hPutStrLn
, stderr
)
import System.IO.Error ( ioeGetErrorString
, try
)
import Network.Browser ( Proxy(..)
, browse
, defaultGETRequest
, request
, setOutHandler
, setErrHandler
, setProxy
)
import Network.HTTP ( Header(..)
, HeaderName(..)
, Response(..)
, httpVersion
)
import Network.Socket ( withSocketsDo
)
import Network.URI ( URI
, parseURIReference
)
getCont :: String -> String -> IO (Either String ([(String, String)], String))
getCont uri proxy
= do
res <- try (getHttp False uri1 proxy)
either processError processResponse res
where
uri1 = fromJust (parseURIReference uri)
processError e
= return $ Left ( "http error when requesting URI "
++ show uri
++ ": "
++ ioeGetErrorString e
++ " (perhaps server does not understand HTTP/1.1) "
)
processResponse response
| st >= 200 && st < 300
= return $ Right (al, cs)
| otherwise
= return $ Left ( "http error when accessing URI "
++ show uri
++ ": "
++ show st
++ " "
++ rspReason response
)
where
al = convertResponseHeaders response
cs = rspBody response
st = convertResponseStatus (rspCode response)
getHttp :: Bool -> URI -> String -> IO Response
getHttp trc' uri' proxy'
= withSocketsDo $
browse ( do
setOutHandler (trcFct)
setErrHandler (trcFct)
setProxy' proxy'
(_ruri, rsp) <- request rq
return rsp
)
where
trcFct s
| trc'
= hPutStrLn stderr ("-- (5) http: " ++ s)
| otherwise
= return ()
rq = defaultGETRequest uri'
setProxy' "" = return ()
setProxy' p = setProxy (Proxy p Nothing)
convertResponseStatus :: (Int, Int, Int) -> Int
convertResponseStatus (a, b, c)
= 100 * a + 10 * b + c
convertResponseHeaders :: Response -> [(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) ]