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