{-# LANGUAGE CPP, ForeignFunctionInterface #-}

module Darcs.Util.Download.Curl where

#ifdef HAVE_CURL

import Prelude ()
import Darcs.Prelude

import Control.Exception ( bracket )
import Control.Monad ( when )
import Foreign.C.Types ( CLong(..), CInt(..) )

import Darcs.Util.Progress ( debugMessage )

import Darcs.Util.Download.Request

import Foreign.C.String ( withCString, peekCString, CString )
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable

setDebugHTTP :: IO ()
setDebugHTTP :: IO ()
setDebugHTTP = IO ()
curl_enable_debug

requestUrl :: String -> FilePath -> Cachable -> IO String
requestUrl :: String -> String -> Cachable -> IO String
requestUrl u :: String
u f :: String
f cache :: Cachable
cache =
  String -> (CString -> IO String) -> IO String
forall a. String -> (CString -> IO a) -> IO a
withCString String
u ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ustr :: CString
ustr ->
  String -> (CString -> IO String) -> IO String
forall a. String -> (CString -> IO a) -> IO a
withCString String
f ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \fstr :: CString
fstr ->
  IO (Ptr CInt)
-> (Ptr CInt -> IO ()) -> (Ptr CInt -> IO String) -> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr CInt)
forall a. Storable a => IO (Ptr a)
malloc Ptr CInt -> IO ()
forall a. Ptr a -> IO ()
free ((Ptr CInt -> IO String) -> IO String)
-> (Ptr CInt -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ errorPointer :: Ptr CInt
errorPointer -> do
    String
e <- CString -> CString -> CInt -> Ptr CInt -> IO CString
curl_request_url CString
ustr CString
fstr (Cachable -> CInt
cachableToInt Cachable
cache) Ptr CInt
errorPointer IO CString -> (CString -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString
    CInt
errorNum <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
errorPointer
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
errorNum CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 90 ) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
debugMessage "The environment variable DARCS_CONNECTION_TIMEOUT is not a number"
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
e

waitNextUrl :: IO (String, String, Maybe ConnectionError)
waitNextUrl :: IO (String, String, Maybe ConnectionError)
waitNextUrl =
  IO (Ptr CInt)
-> (Ptr CInt -> IO ())
-> (Ptr CInt -> IO (String, String, Maybe ConnectionError))
-> IO (String, String, Maybe ConnectionError)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr CInt)
forall a. Storable a => IO (Ptr a)
malloc Ptr CInt -> IO ()
forall a. Ptr a -> IO ()
free ((Ptr CInt -> IO (String, String, Maybe ConnectionError))
 -> IO (String, String, Maybe ConnectionError))
-> (Ptr CInt -> IO (String, String, Maybe ConnectionError))
-> IO (String, String, Maybe ConnectionError)
forall a b. (a -> b) -> a -> b
$ \ errorPointer :: Ptr CInt
errorPointer ->
  IO (Ptr CLong)
-> (Ptr CLong -> IO ())
-> (Ptr CLong -> IO (String, String, Maybe ConnectionError))
-> IO (String, String, Maybe ConnectionError)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr CLong)
forall a. Storable a => IO (Ptr a)
malloc Ptr CLong -> IO ()
forall a. Ptr a -> IO ()
free ((Ptr CLong -> IO (String, String, Maybe ConnectionError))
 -> IO (String, String, Maybe ConnectionError))
-> (Ptr CLong -> IO (String, String, Maybe ConnectionError))
-> IO (String, String, Maybe ConnectionError)
forall a b. (a -> b) -> a -> b
$ \ httpErrorPointer :: Ptr CLong
httpErrorPointer -> do
    String
e <- Ptr CInt -> Ptr CLong -> IO CString
curl_wait_next_url Ptr CInt
errorPointer Ptr CLong
httpErrorPointer IO CString -> (CString -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString
    Maybe ConnectionError
ce <- do
           CInt
errorNum <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
errorPointer
           if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
e then Maybe ConnectionError -> IO (Maybe ConnectionError)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConnectionError
forall a. Maybe a
Nothing
             else Maybe ConnectionError -> IO (Maybe ConnectionError)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ConnectionError -> IO (Maybe ConnectionError))
-> Maybe ConnectionError -> IO (Maybe ConnectionError)
forall a b. (a -> b) -> a -> b
$
              case CInt
errorNum of
                6  -> ConnectionError -> Maybe ConnectionError
forall a. a -> Maybe a
Just ConnectionError
CouldNotResolveHost
                7  -> ConnectionError -> Maybe ConnectionError
forall a. a -> Maybe a
Just ConnectionError
CouldNotConnectToServer
                28 -> ConnectionError -> Maybe ConnectionError
forall a. a -> Maybe a
Just ConnectionError
OperationTimeout
                _  -> Maybe ConnectionError
forall a. Maybe a
Nothing
    String
u <- IO CString
curl_last_url IO CString -> (CString -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString
    CLong
httpErrorCode <- Ptr CLong -> IO CLong
forall a. Storable a => Ptr a -> IO a
peek Ptr CLong
httpErrorPointer
    let detailedErrorMessage :: String
detailedErrorMessage = if CLong
httpErrorCode CLong -> CLong -> Bool
forall a. Ord a => a -> a -> Bool
> 0
                               then String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CLong -> String
forall a. Show a => a -> String
show CLong
httpErrorCode
                               else String
e
    (String, String, Maybe ConnectionError)
-> IO (String, String, Maybe ConnectionError)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
u, String
detailedErrorMessage, Maybe ConnectionError
ce)

pipeliningEnabled :: IO Bool
pipeliningEnabled :: IO Bool
pipeliningEnabled = do
  CInt
r <- IO CInt
curl_pipelining_enabled
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0

cachableToInt :: Cachable -> CInt
cachableToInt :: Cachable -> CInt
cachableToInt Cachable = -1
cachableToInt Uncachable = 0
cachableToInt (MaxAge n :: CInt
n) = CInt
n

foreign import ccall "hscurl.h curl_request_url"
  curl_request_url :: CString -> CString -> CInt -> Ptr 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