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

{- |
   Module     : Text.XML.HXT.IO.GetHTTPLibCurl
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   GET for http access with libcurl

-}

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

module Text.XML.HXT.IO.GetHTTPLibCurl
    ( getCont
    )

where

import           Control.Arrow                           (first, (>>>))
import           Control.Concurrent.MVar
import           Control.Monad                           (when)

import qualified Data.ByteString.Lazy                    as B

import           Data.Char                               (isDigit, isSpace)
import           Data.List                               (isPrefixOf)

import           Network.Curl

import           System.IO
import           System.IO.Unsafe                        (unsafePerformIO)

import           Text.ParserCombinators.Parsec           (parse)

import           Text.XML.HXT.DOM.Util                   (stringToLower)
import           Text.XML.HXT.DOM.XmlKeywords            (httpPrefix,
                                                          transferMessage,
                                                          transferStatus,
                                                          transferVersion)

import           Text.XML.HXT.Arrow.XmlOptions           (a_if_modified_since,
                                                          a_if_unmodified_since,
                                                          a_proxy, a_redirect)

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

-- ------------------------------------------------------------
--
-- the global flag for initializing curl in the 1. call
-- this is a hack, but until now no better solution found

isInitCurl      :: MVar Bool
isInitCurl      = unsafePerformIO $ newMVar False

{-# NOINLINE isInitCurl #-}

initCurl        :: IO ()
initCurl
    = do
      i <- takeMVar isInitCurl
      when (not i) ( curl_global_init 3
                     >>
                     return ()
                   )
      putMVar isInitCurl True

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

-- The curl lib is not thread save

curlResource    :: MVar ()
curlResource    = unsafePerformIO $ newMVar ()

{-# NOINLINE curlResource #-}

requestCurl     :: IO ()
requestCurl     = takeMVar curlResource

releaseCurl     :: IO ()
releaseCurl     = putMVar curlResource ()

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

--
-- the http protocol handler implemented by calling libcurl
-- (<http://curl.haxx.se/>)
-- via the curl binding
-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/curl>
-- This function tries to support mostly all curl options concerning HTTP requests.
-- The naming convetion is as follows: A curl option must be prefixed by the string
-- \"curl\" and then written exactly as described in the curl man page
-- (<http://curl.haxx.se/docs/manpage.html>).
--
-- Example:
--
-- > getCont [("--user-agent","My first HXT app"),("-e","http://the.referer.url/")] "http://..."
--
-- will set the user agent and the referer URL for this request.

getCont         :: Bool -> [(String, String)] -> String ->
                   IO (Either ([(String, String)],       String)
                              ([(String, String)], B.ByteString))
getCont strictInput options uri
    = do
      initCurl
      requestCurl
      resp <- curlGetResponse_ uri curlOptions
      let resp' = evalResponse resp
      resp' `seq`
            releaseCurl
      -- dumpResponse
      return resp'
    where
    _dumpResponse r
        = do
          hPutStrLn stderr $ show $ respCurlCode   r
          hPutStrLn stderr $ show $ respStatus     r
          hPutStrLn stderr $        respStatusLine r
          hPutStrLn stderr $ show $ respHeaders    r
          hPutStrLn stderr $        respBody       r

    curlOptions
        = defaultOptions ++ concatMap (uncurry copt) options ++ standardOptions

    defaultOptions                                              -- these options may be overwritten
        = [ CurlUserAgent ("hxt/" ++ hxt_version ++ " via libcurl")
          , CurlFollowLocation True
          ]

    standardOptions                                             -- these options can't be overwritten
        = [ CurlFailOnError    False
          , CurlHeader         False
          , CurlNoProgress     True
          ]
    evalResponse r
        | rc /= CurlOK
            = Left ( [ mkH transferStatus    "999"
                     , mkH transferMessage $ "curl library rc: " ++ show rc
                     ]
                   , "curl library error when requesting URI "
                     ++ show uri
                     ++ ": (curl return code=" ++ show rc ++ ") "
                   )
        | rs < 200 && rs >= 300
            = Left ( contentT rsh ++ headers
                   , "http error when accessing URI "
                     ++ show uri
                     ++ ": "
                     ++ show rsl
                   )
        | otherwise
            = Right ( contentT rsh ++ headers
                    , body
                    )
        where
        body :: B.ByteString
        body
            | strictInput       = B.length body' `seq` body'
            | otherwise         =                      body'
            where
            body'               = respBody r

        mkH x y = (x, dropWhile isSpace y)

        headers
            = map (\ (k, v) -> mkH (httpPrefix ++ stringToLower k) v) rsh
              ++
              statusLine (words rsl)

        contentT
            = map (first stringToLower)           -- all header names to lowercase
              >>>
              filter ((== "content-type") . fst)  -- select content-type header
              >>>
              reverse                             -- when libcurl is called with automatic redirects,
              >>>                                 -- there are more than one content-type headers
              take 1                              -- take the last one, (if at leat one is found)
              >>>
              map snd                             -- select content-type value
              >>>
              map ( either (const []) id
                    . parse parseContentType ""   -- parse the content-type for mimetype and charset
                  )
              >>>
              concat

        statusLine (vers : _code : msg)           -- the status line of the curl response can be an old one,
                                                  -- e.g. in the case of a redirect,
            = [ mkH transferVersion   vers        -- so the return code is taken from that status field,
              , mkH transferMessage $ unwords msg -- which is contains the last status
              , mkH transferStatus  $ show rs
              ]
        statusLine _
            = []

        rc  = respCurlCode    r
        rs  = respStatus      r
        rsl = respStatusLine  r
        rsh = respHeaders     r

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

copt    :: String -> String -> [CurlOption]
copt k v
    | "curl-" `isPrefixOf` k    = copt (drop 4 k) v             -- throw away curl prefix
    | "--"    `isPrefixOf` k    = opt2copt (drop 2 k) v
    | k `elem` [ a_proxy
               , a_redirect]    = opt2copt k v

    | otherwise                 = opt2copt k v

opt2copt        :: String -> String -> [CurlOption]
opt2copt k v
    | k `elem` ["-A", "user-agent"]     = [CurlUserAgent v]
    | k `elem` ["-b", "cookie"]         = [CurlCookie v]
    | k == "connect-timeout"
      &&
      isIntArg v                        = [CurlConnectTimeout      $ read    v]
    | k == "crlf"                       = [CurlCRLF                $ isTrue  v]
    | k `elem` ["-d", "data"]           = [CurlPostFields          $ lines   v]
    | k `elem` ["-e", "referer"]        = [CurlReferer                       v]
    | k `elem` ["-H", "header"]         = [CurlHttpHeaders         $ lines   v]
    | k == "ignore-content-length"      = [CurlIgnoreContentLength $ isTrue  v]
    | k `elem` ["-I", "head"]           = [CurlNoBody              $ isTrue  v]
    | k `elem` [ "-L"
               , "location"
               , a_redirect
               ]                        = [CurlFollowLocation      $ isTrue  v]
    | k == "max-filesize"
      &&
      isIntArg v                        = [CurlMaxFileSizeLarge    $ read    v]
    | k `elem` ["-m", "max-time"]
      &&
      isIntArg v                        = [CurlTimeoutMS           $ read    v]
    | k `elem` ["-n", "netrc"]          = [CurlNetrcFile                     v]
    | k `elem` ["ssl-verify-peer"]
      &&
      isIntArg v                        = [CurlSSLVerifyPeer       $ read    v]
    | k `elem` ["-R", "remote-time"]    = [CurlFiletime            $ isTrue  v]
    | k `elem` ["-u", "user"]           = [CurlUserPwd                       v]
    | k `elem` ["-U", "proxy-user"]     = [CurlProxyUserPwd                  v]
    | k `elem` [ "-x"
               , "proxy"
               , a_proxy
               ]                        =  proxyOptions
    | k `elem` ["-X", "request"]        = [CurlCustomRequest                 v]
    | k `elem` ["-y", "speed-time"]
      &&
      isIntArg v                        = [CurlLowSpeedTime        $ read    v]
    | k `elem` ["-Y", "speed-limit"]
      &&
      isIntArg v                        = [CurlLowSpeed            $ read    v]
    | k == a_if_modified_since          = [CurlHttpHeaders         $ ["If-Modified-Since: "   ++ v] ]
    | k == a_if_unmodified_since        = [CurlHttpHeaders         $ ["If-Unmodified-Since: " ++ v] ]
                                        -- CurlTimeValue seems to be buggy, therefore the above workaround
    | k `elem` [ "-z"
               , "time-cond"
               , a_if_modified_since
               ]                        =  ifModifiedOptions

    | k == "max-redirs"
      &&
      isIntArg v                        = [CurlMaxRedirs           $ read    v]
    | k `elem` ["-0", "http1.0"]        = [CurlHttpVersion       HttpVersion10]
    | otherwise                         = []
    where
    ifModifiedOptions
        | "-" `isPrefixOf` v
          &&
          isIntArg v'                   = [CurlTimeCondition TimeCondIfUnmodSince
                                          ,CurlTimeValue           $ read   v'
                                          ]
        | isIntArg v                    = [CurlTimeCondition TimeCondIfModSince
                                          ,CurlTimeValue           $ read   v'
                                          ]
        | otherwise                     = []
        where
        v' = tail v

    proxyOptions
        = [ CurlProxyPort pport
          , CurlProxy     phost
          ]
        where
        pport
            | isIntArg ppp      = read ppp
            | otherwise         = 1080
        (phost, pp)             = span (/=':') v
        ppp                     = drop 1 pp

isTrue          :: String -> Bool
isTrue s        = null s || (s `elem` ["1", "True", "true", "Yes", "yes"])

isIntArg        :: String -> Bool
isIntArg s      = not (null s) && all isDigit s

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