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

    {- |
       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        as B
    import qualified Data.ByteString.Char8  as C

    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
    import Text.XML.HXT.DOM.XmlOptions	( isTrueValue )

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

    -- ------------------------------------------------------------
    --
    -- the global flag for initializing curl in the 1. call

    isInitCurl	:: MVar Bool
    isInitCurl	= unsafePerformIO $ newMVar False

    {-# NOINLINE isInitCurl #-}

    initCurl	:: IO ()
    initCurl
        = do
          i <- takeMVar isInitCurl
          when (not i) ( do
    		     _ <- 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 [("curl--user-agent","My first HXT app"),("curl-e","http://the.referer.url/")] "http://..."
    --
    -- will set the user agent and the referer URL for this request.

    getCont		:: [(String, String)] -> String -> IO (Either ([(String, String)], String)
    						              ([(String, String)], String))
    getCont 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
    	    = B.length body
                  `seq`
                  Right ( contentT rsh ++ headers
                        , C.unpack body
    		    )
    	where
            body :: B.ByteString
            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 the status field, which is contains the last status
    	      , mkH transferMessage $ unwords msg
    	      , 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
    	= opt2copt (drop 4 k) v

        | k `elem` [a_proxy, a_redirect]
    	= opt2copt k v

        | k == a_options_curl
    	= curlOptionString v

        | otherwise
    	= []

    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"]	= [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 `elem` ["-z", "--time-cond", a_if_modified_since]
    					=  ifModifiedOptions

        | k == a_if_modified_since		= [CurlHttpHeaders	   $ ["If-Modified-Since: " ++ v] ]
    					-- CurlTimeValue seems to be buggy, therefore this workaround
        | 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 v
    	    | otherwise		= 1080
    	(phost, pp) 		= span (/=':') v
    	ppp      		= drop 1 pp

    isTrue		:: String -> Bool
    isTrue s  	= null s || isTrueValue s

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

    curlOptionString	:: String -> [CurlOption]
    curlOptionString
        = concatMap (uncurry copt) . opts . words
        where
        opts l
    	| null l			= []
    	| not ("-" `isPrefixOf` k)	= opts l1		-- k not an option: ignore
    	| null l1			= opts (k:"":l1)	-- last option
    	| "-" `isPrefixOf` v		= (k, "") : opts (v:l)	-- k option without arg
    	| otherwise			= (k, v) : opts l2	-- k with value
    	where
    	(k:l1) = l
    	(v:l2) = l1

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