-- ------------------------------------------------------------
--
-- protocol handler functions for native http access
--
-- Version : $Id: ProtocolHandlerHttpCurl.hs,v 1.3 2004/03/24 11:42:47 hxml Exp $

module ProtocolHandlerHttpCurl
    ( getHttpContentsWithCurl
    )

where

import XmlTree

import XmlState

import 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 Posix
    ( popen
    )
-}
import POpen
    ( 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 "curlOptions"

      let allArgs = args ++ proxyArgs proxy ++ words curlOptions

      trace 4 ( "getHttpContentWithCurl: running " ++ show (unwords (cmd : allArgs)) )

      (res, errs, pid) <- io $ popen cmd allArgs Nothing

      trace 4 ( "getHttpContentWithCurl: PID:    " ++ show pid )
      trace 4 ( "getHttpContentWithCurl: stdin:  " ++ show res  )
      trace 4 ( "getHttpContentWithCurl: stderr: " ++ show errs )

      if null res
         then addFatal ( "http error whenrequesting URI "
                        ++ 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
      (rc, rh) <- parseResp
      rhs      <- parseHeaders
      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 h v
            | map toLower h == "content-type"
                = ( case (parse parseContentType h v) of
                    Right res -> res
                    Left  _   -> []
                  )
            | otherwise
                = []

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