-- ------------------------------------------------------------
--
-- protocol handler functions for native http access

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
    )

-- ------------------------------------------------------------
--
-- the http protocol handler implemented by calling external program curl

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)

-- ------------------------------------------------------------
--
-- parsers for HTTP response

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
		= []

-- ------------------------------------------------------------