content: -- ------------------------------------------------------------
  
  {- |
     Module     : Text.XML.HXT.IO.GetHTTPNative
     Copyright  : Copyright (C) 2010 Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : experimental
     Portability: portable
  
     HXT interface for native HTTP access via package HTTP
  -}
  
  -- ------------------------------------------------------------
  
  module Text.XML.HXT.IO.GetHTTPNative
      ( module Text.XML.HXT.IO.GetHTTPNative
      )
  
  where
  
  import           Control.Arrow
  import           Control.Exception                       (try)
  
  import           Text.XML.HXT.DOM.TypeDefs               (Attributes)
  import           Text.XML.HXT.DOM.Util                   (stringTrim)
  import           Text.XML.HXT.DOM.XmlKeywords
  
  import           Text.XML.HXT.Arrow.XmlOptions           (a_if_modified_since,
                                                            a_if_unmodified_since)
  
  import           Text.XML.HXT.Parser.ProtocolHandlerUtil (parseContentType)
  
  import           Text.ParserCombinators.Parsec           (parse)
  
  import qualified Data.ByteString.Lazy                    as B
  
  import           Data.Char                               (isDigit)
  import           Data.Int                                (Int64)
  import           Data.List                               (isPrefixOf)
  import           Data.Maybe
  import           System.IO                               (hPutStrLn, stderr)
  import           System.IO.Error                         (ioeGetErrorString)
  
  import           Network.Browser                         (BrowserAction,
                                                            Proxy (..), browse,
                                                            defaultGETRequest_,
                                                            request,
                                                            setAllowRedirects,
                                                            setErrHandler,
                                                            setMaxRedirects,
                                                            setOutHandler,
                                                            setProxy)
  import           Network.HTTP                            (Header (..),
                                                            HeaderName (..),
                                                            Request (..),
                                                            Response (..),
                                                            httpVersion,
                                                            replaceHeader)
  import           Network.Socket                          (withSocketsDo)
  import           Network.URI                             (URI,
                                                            parseURIReference)
  
  -- import qualified Debug.Trace as T
  -- ------------------------------------------------------------
  --
  -- the native http protocol handler
  
  -- ------------------------------------------------------------
  --
  -- the http protocol handler, haskell implementation
  
  getCont         :: Bool -> String -> String -> Bool -> Attributes ->
                     IO (Either ([(String, String)],       String)
                                ([(String, String)], B.ByteString)
                        )
  getCont strictInput proxy uri redirect options
      = do
        res <- try (getHttp False uri1 proxy redirect options)
        either processError processResponse res
      where
      uri1 = fromJust (parseURIReference uri)
  
      processError e
          = return $
            Left ( [ (transferStatus, "999")
                   , (transferMessage, "HTTP library error")
                   ]
                 , "http error when requesting URI "
                   ++ show uri
                   ++ ": "
                   ++ ioeGetErrorString e
                   ++ " (perhaps server does not understand HTTP/1.1) "
                 )
  
      processResponse response
          | ( (rc >= 200 && rc < 300)
              ||
              rc == 304           -- not modified is o.k., this rc only occurs together with if-modified-since
            )
            &&
            fileSizeOK
              = do
                if strictInput
                  then B.length cs `seq` return res
                  else                   return res
  
          | not fileSizeOK
              = return $
                ers "999 max-filesize exceeded"
  
          | otherwise
              = return $
                ers (show rc ++ " " ++ rr)
          where
          fileSizeOK = case getCurlMaxFileSize options of
                       Nothing -> True
                       Just mx -> B.length cs <= mx
          rc  = convertResponseStatus $ rspCode response
          rr  = rspReason response
          res   = Right (rs, cs)
          ers e = Left (rs, "http error when accessing URI " ++ show uri ++ ": " ++ e)
          rs  = rst ++ rsh
          rst = [ (transferStatus, show rc)
                , (transferMessage,     rr)
                ]
          rsh = convertResponseHeaders response
          cs  = rspBody response
  
      getHttp             :: Bool -> URI -> String -> Bool -> Attributes -> IO (Response B.ByteString)
      getHttp trc' uri' proxy' redirect' options'
          = withSocketsDo $
            browse ( do
                     sequence_ configHttp
                     (_ruri, rsp) <- request $ theRequest
                     return rsp
                   )
          where
          theRequest :: Request B.ByteString
          theRequest
              = configHeaders $ defaultGETRequest_ uri'
  
          configHeaders :: Request B.ByteString -> Request B.ByteString
          configHeaders
              = foldr (>>>) id . map (uncurry replaceHeader) . concatMap (uncurry setHOption) $ options'
  
          configHttp
              = setOutHandler (trcFct)
                : setErrHandler (trcFct)
                : ( if null proxy'
                    then return ()
                    else setProxy (Proxy proxy' Nothing)
                  )
                : setAllowRedirects redirect'
                : concatMap (uncurry setOption) options'
  
          trcFct s
              | trc'
                  = hPutStrLn stderr ("-- (5) http: " ++ s)
              | otherwise
                  = return ()
  
      convertResponseStatus       :: (Int, Int, Int) -> Int
      convertResponseStatus (a, b, c)
          = 100 * a + 10 * b + c
  
      convertResponseHeaders      :: Response B.ByteString -> [(String, String)]
      convertResponseHeaders r'
          = cvResponseCode (rspCode r')
            ++
            cvResponseReason (rspReason r')
            ++
            cvResponseHeaders (rspHeaders r')
          where
          cvResponseCode  :: (Int, Int, Int) -> [(String, String)]
          cvResponseCode st'
              = [ (transferStatus,        show (convertResponseStatus st'))
                , (transferVersion,       httpVersion)
                ]
  
          cvResponseReason        :: String -> [(String, String)]
          cvResponseReason r''
              = [ (transferMessage, (stringTrim r'')) ]
  
          cvResponseHeaders       :: [Header] -> [(String, String)]
          cvResponseHeaders
              = concatMap cvResponseHeader
  
          cvResponseHeader        :: Header -> [(String, String)]
          cvResponseHeader (Header name value)
              | name == HdrContentType
                  = ( case (parse parseContentType (show HdrContentType) value) of
                      Right res -> res
                      Left  _   -> []
                    )
                    ++
                    addHttpAttr
              | otherwise
                  = addHttpAttr
              where
              addHttpAttr = [ (httpPrefix ++ (show name), value) ]
  
  
  setOption       :: String -> String -> [BrowserAction t ()]
  setOption k0 v
      | k == "max-redirs"
        &&
        isIntArg v                        = [setMaxRedirects (Just $ read v)]
      | k == "max-redirs"
        &&
        null v                            = [setMaxRedirects Nothing]
  
      | otherwise                         = []
    where
      k = dropCurlPrefix k0
  
  curlPrefix      :: String
  curlPrefix      = "curl--"
  
  dropCurlPrefix :: String -> String
  dropCurlPrefix k
    | curlPrefix `isPrefixOf` k  = drop (length curlPrefix) k
    | otherwise                  = k
  
  setHOption      :: String -> String -> [(HeaderName, String)]
  setHOption k0 v
      | k `elem` [ "-A"
                 , "user-agent"
                 , "curl--user-agent"
                 ]                        = [(HdrUserAgent,         v)]
      | k `elem` [ "-e"
                 , "referer"]             = [(HdrReferer,           v)]
      | k == a_if_modified_since          = [(HdrIfModifiedSince,   v)]
      | k == a_if_unmodified_since        = [(HdrIfUnmodifiedSince, v)]
      | otherwise                         = []
    where
      k = dropCurlPrefix k0
  
  isIntArg        :: String -> Bool
  isIntArg s      = not (null s) && all isDigit s
  
  getCurlMaxFileSize :: Attributes -> Maybe Int64
  getCurlMaxFileSize options
    = (\ s -> if isIntArg s
              then Just (read s)
              else Nothing
      )
      . fromMaybe ""
      . lookup (curlPrefix ++ "max-filesize")
      $ options
  
  -- ------------------------------------------------------------
  