module URL.Curl where
#ifdef HAVE_CURL
import Control.Exception.Extensible ( bracket )
import Control.Monad ( when )
import Foreign.C.Types ( CLong, CInt )
import Progress ( debugMessage )
import URL.Request
import Foreign.C.String ( withCString, peekCString, CString )
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable
setDebugHTTP :: IO ()
setDebugHTTP = curl_enable_debug
requestUrl :: String -> FilePath -> Cachable -> IO String
requestUrl u f cache =
withCString u $ \ustr ->
withCString f $ \fstr -> do
err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString
return err
waitNextUrl :: IO (String, String, Maybe ConnectionError)
waitNextUrl =
bracket malloc free $ \ errorPointer ->
bracket malloc free $ \ httpErrorPointer -> do
e <- curl_wait_next_url errorPointer httpErrorPointer >>= peekCString
ce <- do
errorNum <- peek errorPointer
if not (null e)
then return $
case errorNum of
6 -> Just CouldNotResolveHost
7 -> Just CouldNotConnectToServer
28 -> Just OperationTimeout
_ -> Nothing
else do
when (errorNum == 90 ) $ debugMessage "The environment variable DARCS_CONNECTION_TIMEOUT is not a number"
return Nothing
u <- curl_last_url >>= peekCString
httpErrorCode <- peek httpErrorPointer
let detailedErrorMessage = if httpErrorCode > 0
then e ++ " " ++ show httpErrorCode
else e
return (u, detailedErrorMessage, ce)
pipeliningEnabled :: IO Bool
pipeliningEnabled = do
r <- curl_pipelining_enabled
return $ r /= 0
cachableToInt :: Cachable -> CInt
cachableToInt Cachable = 1
cachableToInt Uncachable = 0
cachableToInt (MaxAge n) = n
foreign import ccall "hscurl.h curl_request_url"
curl_request_url :: CString -> CString -> CInt -> IO CString
foreign import ccall "hscurl.h curl_wait_next_url"
curl_wait_next_url :: Ptr CInt -> Ptr CLong-> IO CString
foreign import ccall "hscurl.h curl_last_url"
curl_last_url :: IO CString
foreign import ccall "hscurl.h curl_enable_debug"
curl_enable_debug :: IO ()
foreign import ccall "hscurl.h curl_pipelining_enabled"
curl_pipelining_enabled :: IO CInt
#endif