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

{- |
   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

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