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

module Text.XML.HXT.Parser.ProtocolHandlerHttpNative
    ( getHttpContentsWithHttp
    )

where

import Text.XML.HXT.DOM.XmlTree

import Text.XML.HXT.DOM.XmlState

import Text.XML.HXT.Parser.ProtocolHandlerUtil
    ( parseContentType
    )

import Text.XML.HXT.DOM.Util
    ( stringTrim
    )

import Text.ParserCombinators.Parsec
    ( parse
    )

import System.IO
import System.IO.Error

import Network.URI
    ( URI
    )

import Network.Socket
    ( withSocketsDo
    )

import Network.HTTP		-- http modules
import Network.Browser

-- ------------------------------------------------------------
--
-- the native http protocol handler

-- ------------------------------------------------------------
--
-- the http protocol handler, haskell implementation

getHttpContentsWithHttp	:: URI -> XmlStateFilter a
getHttpContentsWithHttp uri n
    = do
      traceLevel <- getTraceLevel
      trace 2 ("getHttpContent: reading from URL " ++ show uri)
      proxy <- getSysParam a_proxy
      res <- io $  try (getHttp traceLevel uri proxy)
      case res of
	       Left e
		   -> readErr ( "http error when requesting URI "
				++ show uri
				++ ": "
				++ ioeGetErrorString e
				++ " (perhaps server does not understand HTTP/1.1) "
			      )
	       Right response
		   -> let
		      al = convertResponseHeaders response
		      cs = xtext (rspBody response)
		      st = convertResponseStatus (rspCode response)
		      in
		      if st >= 200 && st < 300
			 then
			 return $ (addAttrl (const al) .> replaceChildren cs) n
			 else 
			 readErr ( "http error when accessing URI "
				   ++ show (show uri)
				   ++ ": "
				   ++ show st
				   ++ " "
				   ++ rspReason response
				 )
    where
    readErr msg	= addFatal msg n

    getHttp		:: Int -> 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' >= 5
		= hPutStrLn stderr ("-- (" ++ show trc' ++ ") 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 -> XmlTrees
    convertResponseHeaders r'
	= cvResponseCode (rspCode r')
	  ++
	  cvResponseReason (rspReason r')
          ++
	  cvResponseHeaders (rspHeaders r')
	where
	cvResponseCode	:: (Int, Int, Int) -> XmlTrees
	cvResponseCode st'
	    = xattr transferStatus (show (convertResponseStatus st'))
	      ++
	      xattr transferVersion httpVersion

	cvResponseReason	:: String -> XmlTrees
	cvResponseReason r''
	    = xattr transferMessage (stringTrim r'')

	cvResponseHeaders	:: [Header] -> XmlTrees
	cvResponseHeaders
	    = concatMap cvResponseHeader

	cvResponseHeader	:: Header -> XmlTrees
	cvResponseHeader (Header name value)
	    | name == HdrContentType
		= ( case (parse parseContentType (show HdrContentType) value) of
		    Right res -> concatMap (uncurry xattr) res
		    Left  _   -> []
		  )
                  ++
		  addHttpAttr
	    | otherwise
		= addHttpAttr
	    where
	    addHttpAttr = xattr (httpPrefix ++ (show name)) value


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