module Network.CURL000.LibHS
( curl_easy_cleanup
, curl_easy_getinfo
, curl_easy_init
, curl_easy_perform
, curl_easy_recv
, curl_easy_reset
, curl_easy_send
, curl_easy_setopt
, curl_global_cleanup
, curl_global_init
, curl_share_cleanup
, curl_share_init
, curl_share_setopt
, curl_version
, curl_version_info
) where
import qualified Network.CURL000.LibCC as C
import Network.CURL000.Types
import qualified Data.ByteString as BS
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.ByteString (ByteString, packCStringLen)
import Data.IORef (IORef, newIORef, atomicModifyIORef)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import Data.List (partition)
import Data.Unique (newUnique)
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (MVar, newMVar, takeMVar, tryPutMVar, modifyMVar)
import Control.Concurrent (withMVar, modifyMVar_)
import Control.Exception (throwIO, bracketOnError)
import Control.Monad (when, forM_, foldM)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.Storable
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
curl_global_init :: IO ()
curl_global_init = do
code <- C.curl_global_init 3
when (code/=0) (error "<curlhs> curl_global_init failed")
curl_global_cleanup :: IO ()
curl_global_cleanup = C.curl_global_cleanup
curl_version :: IO String
curl_version = C.curl_version >>= peekCAString
curl_version_info :: IO CURL_version_info
curl_version_info =
C.curl_version_info 3 >>= \ptr -> CURL_version_info
<$> ((\hsc_ptr -> peekByteOff hsc_ptr 8) ptr >>= peekCAString)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 16) ptr >>= peekCUInt)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 24) ptr >>= peekCAString)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 32) ptr >>= peekCFeatures)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 40) ptr >>= peekCString0)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 48) ptr >>= peekCLong)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 56) ptr >>= peekCString0)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 64) ptr >>= peekCStringL)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 72) ptr >>= peekCString0)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 80) ptr >>= peekCInt)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 88) ptr >>= peekCString0)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 96) ptr >>= peekCInt)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 104) ptr >>= peekCString0)
peekCString0 :: Ptr CChar -> IO String
peekCString0 ptr = if (ptr==nullPtr) then return [] else peekCAString ptr
peekCStringL :: Ptr (Ptr CChar) -> IO [String]
peekCStringL ptr = peekArray0 nullPtr ptr >>= mapM peekCAString
peekCFeatures :: CInt -> IO [CURLfeature]
peekCFeatures = return . fromCIntMask
peekCUInt :: CUInt -> IO Int
peekCUInt = return . fromIntegral
peekCInt :: CInt -> IO Int
peekCInt = return . fromIntegral
peekCLong :: CLong -> IO Int
peekCLong = return . fromIntegral
curl_easy_init :: IO CURL
curl_easy_init = do
ccurl <- C.curl_easy_init; curlmvar <- newMVar ccurl
uid <- newUnique; cbref <- newIORef []; slref <- newIORef []
let curl = CURL uid curlmvar cbref slref
if (ccurl/=nullPtr) then return curl else do
desc <- C.curl_easy_strerror 2 >>= peekCString0
throwCURLE curl "curl_easy_init" desc CURLE_FAILED_INIT
throwCURLE :: CURL -> String -> String -> CURLC -> IO a
throwCURLE curl func desc code = throwIO (CURLE curl func desc code)
checkCURLE :: CURL -> String -> (IO CInt) -> IO ()
checkCURLE curl func action =
action >>= \code -> when (code/=0) $ do
desc <- C.curl_easy_strerror code >>= peekCString0
throwCURLE curl func desc (toCURLC code)
withCCURL :: CURL -> (Ptr C.CURL -> IO a) -> IO a
withCCURL (CURL _ curlmvar _ _) = withMVar curlmvar
curl_easy_reset :: CURL -> IO ()
curl_easy_reset (CURL _ curlmvar cbref slref) =
modifyMVar_ curlmvar $ \ccurl -> do
when (ccurl/=nullPtr) (C.curl_easy_reset ccurl)
freeCURL cbref slref >> return ccurl
curl_easy_cleanup :: CURL -> IO ()
curl_easy_cleanup (CURL _ curlmvar cbref slref) =
modifyMVar_ curlmvar $ \ccurl -> do
when (ccurl/=nullPtr) (C.curl_easy_cleanup ccurl)
freeCURL cbref slref >> return nullPtr
freeCURL :: IORef [CURLCB] -> IORef [CURLSL] -> IO ()
freeCURL cbref slref = do
atomicModifyIORef cbref (\cbs -> ([],cbs)) >>= mapM_ freeCB
atomicModifyIORef slref (\sls -> ([],sls)) >>= mapM_ freeSL
curl_easy_perform :: CURL -> IO ()
curl_easy_perform curl =
withCCURL curl (checkCURLE curl "curl_easy_perform" . C.curl_easy_perform)
curl_easy_recv :: CURL -> Int -> IO ByteString
curl_easy_recv curl len =
withCCURL curl $ \ccurl -> alloca $ \nptr -> allocaBytes len $ \buff -> do
let check = checkCURLE curl "curl_easy_recv"
check $ C.curl_easy_recv ccurl buff (fromIntegral len) nptr
n <- fmap fromIntegral (peek nptr)
packCStringLen (castPtr buff, n)
curl_easy_send :: CURL -> ByteString -> IO Int
curl_easy_send curl bs =
withCCURL curl $ \ccurl -> alloca $ \nptr -> do
let check = checkCURLE curl "curl_easy_send"
check $ unsafeUseAsCStringLen bs $ \(cs, cl) ->
C.curl_easy_send ccurl (castPtr cs) (fromIntegral cl) nptr
fmap fromIntegral (peek nptr)
curl_easy_getinfo :: CURL -> CURLinfo a -> IO a
curl_easy_getinfo curl opt = withCCURL curl $ \ccurl ->
let getopt :: Storable x => CInt -> (Ptr x -> IO a) -> IO a
getopt x fpeek = alloca $ \ptr -> getptr x (castPtr ptr) >> fpeek ptr
getptr x ptr = check $ C.curl_easy_getinfo ccurl x ptr
check = checkCURLE curl "curl_easy_getinfo"
in case opt of
CURLINFO_EFFECTIVE_URL -> getopt 1048577 getString
CURLINFO_RESPONSE_CODE -> getopt 2097154 getCLong
CURLINFO_HTTP_CONNECTCODE -> getopt 2097174 getCLong
CURLINFO_FILETIME -> getopt 2097166 getTime
CURLINFO_TOTAL_TIME -> getopt 3145731 getDouble
CURLINFO_NAMELOOKUP_TIME -> getopt 3145732 getDouble
CURLINFO_CONNECT_TIME -> getopt 3145733 getDouble
CURLINFO_APPCONNECT_TIME -> getopt 3145761 getDouble
CURLINFO_PRETRANSFER_TIME -> getopt 3145734 getDouble
CURLINFO_STARTTRANSFER_TIME -> getopt 3145745 getDouble
CURLINFO_REDIRECT_TIME -> getopt 3145747 getDouble
CURLINFO_REDIRECT_COUNT -> getopt 2097172 getCLong
CURLINFO_REDIRECT_URL -> getopt 1048607 getString
CURLINFO_SIZE_UPLOAD -> getopt 3145735 getDouble
CURLINFO_SIZE_DOWNLOAD -> getopt 3145736 getDouble
CURLINFO_SPEED_DOWNLOAD -> getopt 3145737 getDouble
CURLINFO_SPEED_UPLOAD -> getopt 3145738 getDouble
CURLINFO_HEADER_SIZE -> getopt 2097163 getCLong
CURLINFO_REQUEST_SIZE -> getopt 2097164 getCLong
CURLINFO_SSL_VERIFYRESULT -> getopt 2097165 getCLong
CURLINFO_SSL_ENGINES -> getopt 4194331 getSList
CURLINFO_CONTENT_LENGTH_DOWNLOAD -> getopt 3145743 getDouble
CURLINFO_CONTENT_LENGTH_UPLOAD -> getopt 3145744 getDouble
CURLINFO_CONTENT_TYPE -> getopt 1048594 getString
CURLINFO_HTTPAUTH_AVAIL -> getopt 2097175 getAuth
CURLINFO_PROXYAUTH_AVAIL -> getopt 2097176 getAuth
CURLINFO_OS_ERRNO -> getopt 2097177 getCLong
CURLINFO_NUM_CONNECTS -> getopt 2097178 getCLong
CURLINFO_PRIMARY_IP -> getopt 1048608 getString
CURLINFO_PRIMARY_PORT -> getopt 2097192 getCLong
CURLINFO_LOCAL_IP -> getopt 1048617 getString
CURLINFO_LOCAL_PORT -> getopt 2097194 getCLong
CURLINFO_COOKIELIST -> getopt 4194332 getSList
CURLINFO_LASTSOCKET -> getopt 2097181 getCLong
CURLINFO_FTP_ENTRY_PATH -> getopt 1048606 getString
CURLINFO_CERTINFO -> getopt 4194338 getCerts
CURLINFO_CONDITION_UNMET -> getopt 2097187 getBool
CURLINFO_RTSP_SESSION_ID -> getopt 1048612 getString
CURLINFO_RTSP_CLIENT_CSEQ -> getopt 2097189 getCLong
CURLINFO_RTSP_SERVER_CSEQ -> getopt 2097190 getCLong
CURLINFO_RTSP_CSEQ_RECV -> getopt 2097191 getCLong
getString :: Ptr (Ptr CChar) -> IO String
getString ptr = peek ptr >>= peekCString0
getDouble :: Ptr CDouble -> IO Double
getDouble = fmap realToFrac . peek
getCLong :: Ptr CLong -> IO CLong
getCLong = peek
getBool :: Ptr CLong -> IO Bool
getBool = fmap toBool . peek
getAuth :: Ptr CLong -> IO [CURLauth]
getAuth = fmap fromCLongMask . peek
getTime :: Ptr CLong -> IO (Maybe UTCTime)
getTime =
let mconv f x = if (x==(1) || x==0) then Nothing else Just (f x)
in fmap (mconv (posixSecondsToUTCTime . realToFrac)) . peek
getCerts :: Ptr (Ptr C.CURLcerts) -> IO [[String]]
getCerts ptr =
peek ptr >>= \certs -> if (certs==nullPtr) then return [] else
peek certs >>= \(C.CURLcerts len tab) ->
peekArray (fromIntegral len) tab >>= mapM peekCURLslist
getSList :: Ptr (Ptr C.CURLslist) -> IO [String]
getSList ptr =
peek ptr >>= \slist -> do
strings <- peekCURLslist slist
C.curl_slist_free_all slist
return strings
peekCURLslist :: Ptr C.CURLslist -> IO [String]
peekCURLslist ptr =
if (ptr==nullPtr) then return [] else
peek ptr >>= \(C.CURLslist cs csl) -> do
slist_head <- peekCAString cs
slist_tail <- peekCURLslist csl
return (slist_head : slist_tail)
curl_easy_setopt :: CURL -> [CURLoption] -> IO ()
curl_easy_setopt curl@(CURL _ _ cbref slref) opts =
withCCURL curl $ \ccurl -> forM_ opts $ \opt ->
checkCURLE curl "curl_easy_setopt" $ case opt of
CURLOPT_WRITEFUNCTION x -> curlcb FWRITE ccurl 20011 x
CURLOPT_READFUNCTION x -> curlcb FREAD ccurl 20012 x
CURLOPT_VERBOSE x -> bool ccurl 41 x
CURLOPT_HEADER x -> bool ccurl 42 x
CURLOPT_NOPROGRESS x -> bool ccurl 43 x
CURLOPT_NOSIGNAL x -> bool ccurl 99 x
CURLOPT_WILDCARDMATCH x -> bool ccurl 197 x
CURLOPT_FAILONERROR x -> bool ccurl 45 x
CURLOPT_URL x -> string ccurl 10002 x
CURLOPT_PROTOCOLS x -> enum ccurl 181 x
CURLOPT_REDIR_PROTOCOLS x -> enum ccurl 182 x
CURLOPT_PROXY x -> string ccurl 10004 x
CURLOPT_PROXYPORT x -> clong ccurl 59 x
CURLOPT_PROXYTYPE x -> enum ccurl 101 x
CURLOPT_NOPROXY x -> string ccurl 10177 x
CURLOPT_HTTPPROXYTUNNEL x -> bool ccurl 61 x
CURLOPT_SOCKS5_GSSAPI_SERVICE x -> string ccurl 10179 x
CURLOPT_SOCKS5_GSSAPI_NEC x -> bool ccurl 180 x
CURLOPT_INTERFACE x -> string ccurl 10062 x
CURLOPT_LOCALPORT x -> clong ccurl 139 x
CURLOPT_LOCALPORTRANGE x -> clong ccurl 140 x
CURLOPT_DNS_CACHE_TIMEOUT x -> clong ccurl 92 x
CURLOPT_BUFFERSIZE x -> clong ccurl 98 x
CURLOPT_PORT x -> clong ccurl 3 x
CURLOPT_TCP_NODELAY x -> bool ccurl 121 x
CURLOPT_ADDRESS_SCOPE x -> clong ccurl 171 x
CURLOPT_TCP_KEEPALIVE x -> bool ccurl 213 x
CURLOPT_TCP_KEEPIDLE x -> clong ccurl 214 x
CURLOPT_TCP_KEEPINTVL x -> clong ccurl 215 x
CURLOPT_NETRC x -> enum ccurl 51 x
CURLOPT_NETRC_FILE x -> string ccurl 10118 x
CURLOPT_USERPWD x -> string ccurl 10005 x
CURLOPT_PROXYUSERPWD x -> string ccurl 10006 x
CURLOPT_USERNAME x -> string ccurl 10173 x
CURLOPT_PASSWORD x -> string ccurl 10174 x
CURLOPT_PROXYUSERNAME x -> string ccurl 10175 x
CURLOPT_PROXYPASSWORD x -> string ccurl 10176 x
CURLOPT_HTTPAUTH x -> enum ccurl 107 x
CURLOPT_TLSAUTH_TYPE x -> string ccurl 10206 x
CURLOPT_TLSAUTH_USERNAME x -> string ccurl 10204 x
CURLOPT_TLSAUTH_PASSWORD x -> string ccurl 10205 x
CURLOPT_PROXYAUTH x -> enum ccurl 111 x
CURLOPT_AUTOREFERER x -> bool ccurl 58 x
CURLOPT_ACCEPT_ENCODING x -> string ccurl 10102 x
CURLOPT_TRANSFER_ENCODING x -> bool ccurl 207 x
CURLOPT_FOLLOWLOCATION x -> bool ccurl 52 x
CURLOPT_UNRESTRICTED_AUTH x -> bool ccurl 105 x
CURLOPT_MAXREDIRS x -> clong ccurl 68 x
CURLOPT_POSTREDIR x -> enum ccurl 161 x
CURLOPT_PUT x -> bool ccurl 54 x
CURLOPT_POST x -> bool ccurl 47 x
CURLOPT_POSTFIELDSIZE x -> clong ccurl 60 x
CURLOPT_POSTFIELDSIZE_LARGE x -> int64 ccurl 30120 x
CURLOPT_COPYPOSTFIELDS x -> string ccurl 10165 x
CURLOPT_REFERER x -> string ccurl 10016 x
CURLOPT_USERAGENT x -> string ccurl 10018 x
CURLOPT_HTTPHEADER x -> slist ccurl 10023 x
CURLOPT_HTTP200ALIASES x -> slist ccurl 10104 x
CURLOPT_COOKIE x -> string ccurl 10022 x
CURLOPT_COOKIEFILE x -> string ccurl 10031 x
CURLOPT_COOKIEJAR x -> string ccurl 10082 x
CURLOPT_COOKIESESSION x -> bool ccurl 96 x
CURLOPT_COOKIELIST x -> string ccurl 10135 x
CURLOPT_HTTPGET x -> bool ccurl 80 x
CURLOPT_HTTP_VERSION x -> enum ccurl 84 x
CURLOPT_IGNORE_CONTENT_LENGTH x -> bool ccurl 136 x
CURLOPT_HTTP_CONTENT_DECODING x -> bool ccurl 158 x
CURLOPT_HTTP_TRANSFER_DECODING x -> bool ccurl 157 x
CURLOPT_MAIL_FROM x -> string ccurl 10186 x
CURLOPT_MAIL_RCPT x -> slist ccurl 10187 x
CURLOPT_MAIL_AUTH x -> string ccurl 10217 x
CURLOPT_TFTP_BLKSIZE x -> clong ccurl 178 x
CURLOPT_FTPPORT x -> string ccurl 10017 x
CURLOPT_QUOTE x -> slist ccurl 10028 x
CURLOPT_POSTQUOTE x -> slist ccurl 10039 x
CURLOPT_PREQUOTE x -> slist ccurl 10093 x
CURLOPT_DIRLISTONLY x -> bool ccurl 48 x
CURLOPT_APPEND x -> bool ccurl 50 x
CURLOPT_FTP_USE_EPRT x -> bool ccurl 106 x
CURLOPT_FTP_USE_EPSV x -> bool ccurl 85 x
CURLOPT_FTP_USE_PRET x -> bool ccurl 188 x
CURLOPT_FTP_CREATE_MISSING_DIRS x -> enum ccurl 110 x
CURLOPT_FTP_RESPONSE_TIMEOUT x -> clong ccurl 112 x
CURLOPT_FTP_ALTERNATIVE_TO_USER x -> string ccurl 10147 x
CURLOPT_FTP_SKIP_PASV_IP x -> bool ccurl 137 x
CURLOPT_FTPSSLAUTH x -> enum ccurl 129 x
CURLOPT_FTP_SSL_CCC x -> enum ccurl 154 x
CURLOPT_FTP_ACCOUNT x -> string ccurl 10134 x
CURLOPT_FTP_FILEMETHOD x -> enum ccurl 138 x
CURLOPT_RTSP_REQUEST x -> enum ccurl 189 x
CURLOPT_RTSP_SESSION_ID x -> string ccurl 10190 x
CURLOPT_RTSP_STREAM_URI x -> string ccurl 10191 x
CURLOPT_RTSP_TRANSPORT x -> string ccurl 10192 x
CURLOPT_RTSP_HEADER x -> slist ccurl 10023 x
CURLOPT_RTSP_CLIENT_CSEQ x -> clong ccurl 193 x
CURLOPT_RTSP_SERVER_CSEQ x -> clong ccurl 194 x
CURLOPT_TRANSFERTEXT x -> bool ccurl 53 x
CURLOPT_PROXY_TRANSFER_MODE x -> bool ccurl 166 x
CURLOPT_CRLF x -> bool ccurl 27 x
CURLOPT_RANGE x -> string ccurl 10007 x
CURLOPT_RESUME_FROM x -> clong ccurl 21 x
CURLOPT_RESUME_FROM_LARGE x -> int64 ccurl 30116 x
CURLOPT_CUSTOMREQUEST x -> string ccurl 10036 x
CURLOPT_FILETIME x -> bool ccurl 69 x
CURLOPT_NOBODY x -> bool ccurl 44 x
CURLOPT_INFILESIZE x -> clong ccurl 14 x
CURLOPT_INFILESIZE_LARGE x -> int64 ccurl 30115 x
CURLOPT_UPLOAD x -> bool ccurl 46 x
CURLOPT_MAXFILESIZE x -> clong ccurl 114 x
CURLOPT_MAXFILESIZE_LARGE x -> int64 ccurl 30117 x
CURLOPT_TIMECONDITION x -> enum ccurl 33 x
CURLOPT_TIMEVALUE x -> time ccurl 34 x
CURLOPT_TIMEOUT x -> clong ccurl 13 x
CURLOPT_TIMEOUT_MS x -> clong ccurl 155 x
CURLOPT_LOW_SPEED_LIMIT x -> clong ccurl 19 x
CURLOPT_LOW_SPEED_TIME x -> clong ccurl 20 x
CURLOPT_MAX_SEND_SPEED_LARGE x -> int64 ccurl 30145 x
CURLOPT_MAX_RECV_SPEED_LARGE x -> int64 ccurl 30146 x
CURLOPT_MAXCONNECTS x -> clong ccurl 71 x
CURLOPT_FRESH_CONNECT x -> bool ccurl 74 x
CURLOPT_FORBID_REUSE x -> bool ccurl 75 x
CURLOPT_CONNECTTIMEOUT x -> clong ccurl 78 x
CURLOPT_CONNECTTIMEOUT_MS x -> clong ccurl 156 x
CURLOPT_IPRESOLVE x -> enum ccurl 113 x
CURLOPT_CONNECT_ONLY x -> bool ccurl 141 x
CURLOPT_USE_SSL x -> enum ccurl 119 x
CURLOPT_RESOLVE x -> slist ccurl 10203 x
CURLOPT_DNS_SERVERS x -> string ccurl 10211 x
CURLOPT_ACCEPTTIMEOUT_MS x -> clong ccurl 212 x
CURLOPT_SSLCERT x -> string ccurl 10025 x
CURLOPT_SSLCERTTYPE x -> string ccurl 10086 x
CURLOPT_SSLKEY x -> string ccurl 10087 x
CURLOPT_SSLKEYTYPE x -> string ccurl 10088 x
CURLOPT_KEYPASSWD x -> string ccurl 10026 x
CURLOPT_SSLENGINE x -> string ccurl 10089 x
CURLOPT_SSLENGINE_DEFAULT x -> bool ccurl 90 x
CURLOPT_SSLVERSION x -> enum ccurl 32 x
CURLOPT_SSL_VERIFYPEER x -> bool ccurl 64 x
CURLOPT_CAINFO x -> string ccurl 10065 x
CURLOPT_ISSUERCERT x -> string ccurl 10170 x
CURLOPT_CAPATH x -> string ccurl 10097 x
CURLOPT_CRLFILE x -> string ccurl 10169 x
CURLOPT_SSL_VERIFYHOST x -> bool2 ccurl 81 x
CURLOPT_CERTINFO x -> bool ccurl 172 x
CURLOPT_RANDOM_FILE x -> string ccurl 10076 x
CURLOPT_EGDSOCKET x -> string ccurl 10077 x
CURLOPT_SSL_CIPHER_LIST x -> string ccurl 10083 x
CURLOPT_SSL_SESSIONID_CACHE x -> bool ccurl 150 x
CURLOPT_SSL_OPTIONS x -> enum ccurl 216 x
CURLOPT_KRBLEVEL x -> string ccurl 10063 x
CURLOPT_GSSAPI_DELEGATION x -> enum ccurl 210 x
CURLOPT_SSH_AUTH_TYPES x -> enum ccurl 151 x
CURLOPT_SSH_HOST_PUBLIC_KEY_MD5 x -> string ccurl 10162 x
CURLOPT_SSH_PUBLIC_KEYFILE x -> string ccurl 10152 x
CURLOPT_SSH_PRIVATE_KEYFILE x -> string ccurl 10153 x
CURLOPT_SSH_KNOWNHOSTS x -> string ccurl 10183 x
CURLOPT_SHARE x -> curlsh ccurl 10100 x
CURLOPT_NEW_FILE_PERMS x -> clong ccurl 159 x
CURLOPT_NEW_DIRECTORY_PERMS x -> clong ccurl 160 x
CURLOPT_TELNETOPTIONS x -> slist ccurl 10070 x
where
enum ccurl copt x = C.curl_easy_setopt'Long ccurl copt (toCLong x)
bool ccurl copt x = C.curl_easy_setopt'Long ccurl copt (fromBool x)
bool2 ccurl copt x = C.curl_easy_setopt'Long ccurl copt (fromBool2 x)
time ccurl copt x = C.curl_easy_setopt'Long ccurl copt (fromUTCTime x)
clong ccurl copt x = C.curl_easy_setopt'Long ccurl copt (fromIntegral x)
int64 ccurl copt x = C.curl_easy_setopt'COff ccurl copt (fromIntegral x)
fromUTCTime = truncate . utcTimeToPOSIXSeconds
fromBool2 False = 0; fromBool2 True = 2
string ccurl copt x = withCAString x $ \p ->
C.curl_easy_setopt'DPtr ccurl copt (castPtr p)
slist ccurl copt x = makeSL slref ccurl copt x
curlcb :: CURLCBT a -> Ptr C.CURL -> CInt -> Maybe a -> IO CInt
curlcb cbt ccurl copt x = makeCB cbref cbt ccurl copt x
curlsh ccurl copt Nothing = C.curl_easy_setopt'DPtr ccurl copt nullPtr
curlsh ccurl copt (Just (CURLSH _ mvar)) =
withMVar mvar $ \(ccurlsh,_,_) ->
C.curl_easy_setopt'DPtr ccurl copt (castPtr ccurlsh)
wrapSL :: [String] -> IO (Maybe (Ptr C.CURLslist))
wrapSL = foldM wrap (Just nullPtr)
where
wrap Nothing _ = return Nothing
wrap (Just sl) xs =
withCAString xs (C.curl_slist_append sl) >>= \nsl ->
if (nsl/=nullPtr) then return (Just nsl) else do
when (sl/=nullPtr) (C.curl_slist_free_all sl)
return Nothing
freeSL :: CURLSL -> IO ()
freeSL (_,sl) = when (sl/=nullPtr) (C.curl_slist_free_all sl)
makeSL :: IORef [CURLSL] -> Ptr C.CURL -> CInt -> [String] -> IO CInt
makeSL slref ccurl copt xs =
let cons sl (tokeep, tofree) = ((copt,sl):tokeep, tofree)
keep 0 sl sls = cons sl $ partition ((==copt) . fst) sls
keep _ sl sls = cons sl $ (sls,[])
in wrapSL xs >>= \msl -> case msl of
Nothing -> return 27
Just sl -> do
code <- C.curl_easy_setopt'DPtr ccurl copt (castPtr sl)
atomicModifyIORef slref (keep code sl) >>= mapM_ freeSL
return code
wrapCB :: CURLCBT a -> a -> IO (FunPtr ())
wrapCB cbt = case cbt of
FWRITE -> fmap castFunPtr . C.wrapCURL_write_callback . write_callback
FREAD -> fmap castFunPtr . C.wrapCURL_read_callback . read_callback
freeCB :: CURLCB -> IO ()
freeCB (CURLCB _ fp) = when (fp/=nullFunPtr) (freeHaskellFunPtr fp)
makeCB
:: IORef [CURLCB] -> CURLCBT a -> Ptr C.CURL -> CInt -> Maybe a -> IO CInt
makeCB cbref cbt ccurl copt mcb =
let comp :: CURLCBT a -> CURLCB -> Bool
comp FWRITE (CURLCB FWRITE _) = True; comp FWRITE _ = False
comp FREAD (CURLCB FREAD _) = True; comp FREAD _ = False
cons fp (tokeep, tofree) = ((CURLCB cbt fp):tokeep, tofree)
keep 0 fp cbs = cons fp $ partition (comp cbt) cbs
keep _ fp cbs = cons fp $ (cbs,[])
in maybe (return nullFunPtr) (wrapCB cbt) mcb >>= \fp -> do
code <- C.curl_easy_setopt'FPtr ccurl copt fp
atomicModifyIORef cbref (keep code fp) >>= mapM_ freeCB
return code
write_callback :: CURL_write_callback -> C.CURL_write_callback
write_callback fwrite ptr size nmemb _ = do
stat <- packCStringLen (ptr, fromIntegral (size * nmemb)) >>= fwrite
return $ case stat of
CURL_WRITEFUNC_OK -> (size * nmemb)
CURL_WRITEFUNC_FAIL -> 0
CURL_WRITEFUNC_PAUSE -> 268435457
read_callback :: CURL_read_callback -> C.CURL_read_callback
read_callback fread buff size nmemb _ = do
let buffLen = fromIntegral (size * nmemb)
stat <- fread buffLen
case stat of
CURL_READFUNC_PAUSE -> return 268435457
CURL_READFUNC_ABORT -> return 268435456
CURL_READFUNC_OK bs -> unsafeUseAsCStringLen (BS.take buffLen bs)
(\(cs, cl) -> copyBytes buff cs cl >> return (fromIntegral cl))
curl_share_init :: IO CURLSH
curl_share_init = bracketOnError createcurlsh curl_share_cleanup setupcurlsh
where
createcurlsh = do
ccurlsh <- C.curl_share_init
(f1,f2) <- if (ccurlsh == nullPtr)
then return (nullFunPtr, nullFunPtr)
else do
shlocks <- newSHLocks
f1 <- C.wrapCURL_lock_function (lock_function shlocks)
f2 <- C.wrapCURL_unlock_function (unlock_function shlocks)
return (castFunPtr f1, castFunPtr f2)
uid <- newUnique; mvar <- newMVar (ccurlsh,f1,f2)
return (CURLSH uid mvar)
setupcurlsh curlsh@(CURLSH _ mvar) =
withMVar mvar $ \(ccurlsh,f1,f2) -> do
let func = "curl_share_init"
if (ccurlsh == nullPtr)
then do
let getstrerror x = C.curl_easy_strerror x >>= peekCString0
desc <- getstrerror 2
throwCURLSHE curlsh func desc CURLSHE_FAILED_INIT
else do
let withCHECK = checkCURLSHE curlsh func
let setshopt = C.curl_share_setopt'FPtr ccurlsh
withCHECK $ setshopt 3 f1
withCHECK $ setshopt 4 f2
return curlsh
curl_share_cleanup :: CURLSH -> IO ()
curl_share_cleanup curlsh@(CURLSH _ mvar) =
let withCHECK = checkCURLSHE curlsh "curl_share_cleanup"
in modifyMVar_ mvar $ \(ccurlsh,f1,f2) -> do
when (ccurlsh/=nullPtr) (withCHECK $ C.curl_share_cleanup ccurlsh)
when (f1/=nullFunPtr) (freeHaskellFunPtr f1)
when (f2/=nullFunPtr) (freeHaskellFunPtr f2)
return (nullPtr,nullFunPtr,nullFunPtr)
curl_share_setopt :: CURLSH -> [CURLSHoption] -> IO ()
curl_share_setopt curlsh@(CURLSH _ mvar) opts =
withMVar mvar $ \(ccurlsh,_,_) -> do
let func = "curl_share_setopt"
when (ccurlsh==nullPtr) $ do
desc <- C.curl_share_strerror 3 >>= peekCString0
throwCURLSHE curlsh func desc CURLSHE_INVALID
let enum copt x = C.curl_share_setopt'Long ccurlsh copt (toCLong x)
flip mapM_ opts $ \opt -> checkCURLSHE curlsh func $ case opt of
CURLSHOPT_SHARE x -> enum 1 x
CURLSHOPT_UNSHARE x -> enum 2 x
throwCURLSHE :: CURLSH -> String -> String -> CURLSHC -> IO a
throwCURLSHE curlsh func desc code = throwIO (CURLSHE curlsh func desc code)
checkCURLSHE :: CURLSH -> String -> (IO CInt) -> IO ()
checkCURLSHE curlsh func action =
action >>= \code -> when (code/=0) $ do
desc <- C.curl_share_strerror code >>= peekCString0
throwCURLSHE curlsh func desc (toCURLSHC code)
type SHLocks = MVar [(SHLockID, SHLock)]
type SHLock = MVar ()
type SHLockID = CInt
newSHLocks :: IO SHLocks
newSHLocks = newMVar []
getSHLock :: SHLock -> IO ()
getSHLock shlock = takeMVar shlock
putSHLock :: SHLock -> IO ()
putSHLock shlock = tryPutMVar shlock () >> return ()
lookupSHLock :: SHLocks -> SHLockID -> IO SHLock
lookupSHLock mvar shlockid =
modifyMVar mvar $ \shlocks ->
case (lookup shlockid shlocks) of
Just shlock -> return (shlocks, shlock)
Nothing -> newMVar () >>= \nl -> return ((shlockid, nl):shlocks, nl)
lock_function :: SHLocks -> C.CURL_lock_function
lock_function shlocks _ccurl lockdata _lockaccess _usrptr =
lookupSHLock shlocks lockdata >>= getSHLock
unlock_function :: SHLocks -> C.CURL_unlock_function
unlock_function shlocks _ccurl lockdata _usrptr =
lookupSHLock shlocks lockdata >>= putSHLock