content: -- ------------------------------------------------------------
  
  {- |
     Module     : Text.XML.HXT.Arrow.LibCurlInput
     Copyright  : Copyright (C) 2005 Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : experimental
     Portability: portable
  
     libcurl HTTP access
  -}
  
  -- ------------------------------------------------------------
  
  module Text.XML.HXT.IO.GetHTTPCurl
      ( getCont
      )
  
  where
  
  import Text.XML.HXT.DOM.XmlKeywords
  
  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 as Parsec (try)  -- try
  
  import System.PipeOpen
      ( popen
      )
  
  import Data.Char
      ( toLower
      )
  
  import System.IO
  
  -- ------------------------------------------------------------
  --
  -- the http protocol handler implemented by calling external program curl
  
  getCont         :: String -> String -> String -> IO (Either String ([(String, String)], String))
  getCont curlOptions uri proxy
      = do
        (res, errs, rc) <- popen cmd allArgs
        if rc /= 0
           then return $ Left ( "http error when requesting URI "
                                ++ show uri
                                ++ ": (rc=" ++ show rc ++ ") "
                                ++ errs
                              )
           else let
                (st, al, contents) = parseResponse res
                in
                if st >= 200 && st < 300
                   then return $ Right (al, contents)
                   else return $ Left ( "http error when accessing URI "
                                        ++ show uri
                                        ++ ": "
                                        ++ show st
                                      )
      where
      cmd         = "curl"
  
      allArgs     = args
                    ++ proxyArgs proxy
                    ++ words curlOptions
  
      args        = [ "--silent"
                    , "--show-error"
                    , "--dump-header", "-"
                    , uri
                    ]
      proxyArgs ""
                  = []
      proxyArgs prx
                  = [ "--proxy", prx ]
  
  parseResponse   :: String -> (Int, [(String, String)], String)
  parseResponse inp
      = ( either
            ( const (999, [(transferMessage, "illegal HTTP response")], inp))
            id
          .
          parse parseHttpResponse "HTTP Header"
        ) inp
  
  -- ------------------------------------------------------------
  
  parseHttpResponse               :: Parser (Int, [(String, String)], String)
  parseHttpResponse
      = do
        allResponses <- many1 parse1Response
        let (rc, rh, rhs) = last allResponses
        content <- getInput
        return (rc, rh ++ rhs, content)
      where
  
      parse1Response
          = do
            (rc, rh) <- parseResp
            rhs      <- parseHeaders
            return (rc, rh, rhs)
  
      crlf                :: Parser ()
      crlf
          = do
            ( Parsec.try (string "\r\n") <|> string "\n" )
            return ()
  
      parseResp           :: Parser (Int, [(String, String)])
      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,
                     [(transferMessage, reason), (transferVersion, vers)]
                   )
  
      parseHeaders        :: Parser [(String, String)]
      parseHeaders
          = ( do
              crlf
              return []
            )
            <|>
            ( do
              header1 <- parse1Header
              rest    <- parseHeaders
              return (header1 ++ rest)
            )
            <|>
            ( do
              return [(httpPrefix ++ "IllegalHeaders", "")]
            )
  
      parse1Header        :: Parser [(String, String)]
      parse1Header
          = do
            header <- manyTill anyChar (char ':')
            spaces
            value  <- manyTill anyChar crlf
            let ct = parseCT header value
            return $ ct ++ [(httpPrefix ++ header, value)]
          where
          parseCT :: String -> String -> [(String, String)]
          parseCT h v
              | map toLower h == "content-type"
                  = either (const []) id . parse parseContentType h $ v
              | otherwise
                  = []
  
  -- ------------------------------------------------------------
  