module Text.XML.HXT.Parser.ProtocolHandlerHttpCurl
( getHttpContentsWithCurl
)
where
import Text.XML.HXT.DOM.XmlTree
import Text.XML.HXT.DOM.XmlState
import Text.XML.HXT.Parser.ProtocolHandlerUtil
( parseContentType
)
import Text.ParserCombinators.Parsec
( Parser
, parse
, anyChar
, char
, digit
, getInput
, many1
, manyTill
, spaces
, string
, (<|>)
)
import qualified Text.ParserCombinators.Parsec
( try
)
import Network.URI
( URI
)
import System.PipeOpen
( popen
)
import Data.Char
( toLower
)
getHttpContentsWithCurl :: URI -> XmlStateFilter a
getHttpContentsWithCurl uri n
= do
trace 2 ( "getHttpContentWithCurl: reading from URL " ++ show uri )
proxy <- getSysParam a_proxy
curlOptions <- getSysParam a_options_curl
let allArgs = args ++ proxyArgs proxy ++ words curlOptions
trace 4 ( "getHttpContentWithCurl: running " ++ show (unwords (cmd : allArgs)) )
(res, errs, rc) <- io $ popen cmd allArgs
trace 4 ( "getHttpContentWithCurl: PID: " ++ show rc )
trace 4 ( "getHttpContentWithCurl: stdin: " ++ show res )
trace 4 ( "getHttpContentWithCurl: stderr: " ++ show errs )
if rc /= 0
then addFatal ( "http error when requesting URI (rc=" ++ show rc ++ ") "
++ show uri
++ ": "
++ errs
) n
else let
(st, al, contents) = parseResponse res
in
liftMf ( addAttrl (const al)
.>
replaceChildren (xtext contents)
)
.>> ( if st >= 200 && st < 300
then thisM
else
addFatal ( "http error when accessing URI "
++ show uri
++ ": "
++ show st
++ " "
++ (valueOf transferMessage $ newRoot al)
)
)
$ n
where
cmd = "curl"
args = [ "--silent"
, "--show-error"
, "--dump-header", "-"
, show uri
]
proxyArgs ""
= []
proxyArgs prx
= [ "--proxy", prx ]
parseResponse :: String -> (Int, XmlTrees, String)
parseResponse inp
= case (parse parseHttpResponse "HTTP Header" inp) of
Right res -> res
Left _ -> (999, xattr transferMessage "illegal HTTP response", inp)
parseHttpResponse :: Parser (Int, XmlTrees, String)
parseHttpResponse
= do
allResponses <- many1
( do
(rc, rh) <- parseResp
rhs <- parseHeaders
return (rc, rh, rhs)
)
let (rc, rh, rhs) = last allResponses
content <- getInput
return (rc, rh ++ rhs, content)
where
crlf :: Parser ()
crlf
= do
( Text.ParserCombinators.Parsec.try (string "\r\n") <|> string "\n" )
return ()
parseResp :: Parser (Int, XmlTrees)
parseResp
= do
vers <- ( do
http <- string "HTTP/"
mav <- many1 digit
char '.'
miv <- many1 digit
return (http ++ mav ++ "." ++ miv)
)
spaces
ds <- many1 digit
spaces
reason <- manyTill anyChar crlf
return ( read ds,
xattr transferMessage reason ++ xattr transferVersion vers
)
parseHeaders :: Parser XmlTrees
parseHeaders
= ( do
crlf
return []
)
<|>
( do
header1 <- parse1Header
rest <- parseHeaders
return $ header1 ++ rest
)
<|>
( do
return $ xattr (httpPrefix ++ "IllegalHeaders") ""
)
parse1Header :: Parser XmlTrees
parse1Header
= do
header <- manyTill anyChar (char ':')
spaces
value <- manyTill anyChar crlf
let ct = parseCT header value
return $ ct ++ xattr (httpPrefix ++ header) value
where
parseCT :: String -> String -> XmlTrees
parseCT h v
| map toLower h == "content-type"
= ( case (parse parseContentType h v) of
Right res -> concatMap (uncurry xattr) res
Left _ -> []
)
| otherwise
= []