module Network.Curl
( module Network.Curl.Opts
, module Network.Curl.Easy
, module Network.Curl.Post
, module Network.Curl.Info
, module Network.Curl.Types
, module Network.Curl.Code
, withCurlDo
, setopts
, CurlResponse(..)
, curlGet
, curlGetString
, curlGetResponse
, perform_with_response
, do_curl
, curlHead
, curlMultiPost
, curlPost
, getResponseCode
, setDefaultSSLOpts
, callbackWriter
, easyWriter
, ignoreOutput
, gatherOutput
, method_GET
, method_HEAD
, method_POST
, parseStatusNHeaders, concRev
) where
import Network.Curl.Opts
import Network.Curl.Code
import Network.Curl.Types
import Network.Curl.Post
import Network.Curl.Info
import Network.Curl.Easy
import Foreign.C.String
import Data.IORef
import Data.List(isPrefixOf)
import System.IO
withCurlDo :: IO a -> IO a
withCurlDo m = do curl_global_init 3
a <- m
curl_global_cleanup
return a
setopts :: Curl -> [CurlOption] -> IO ()
setopts h opts = mapM_ (setopt h) opts
method_GET :: [CurlOption]
method_GET = [CurlPost False, CurlNoBody False]
method_POST :: [CurlOption]
method_POST = [CurlPost True, CurlNoBody False]
method_HEAD :: [CurlOption]
method_HEAD = [CurlPost False, CurlNoBody True]
curlGet :: URLString -> [CurlOption] -> IO ()
curlGet url opts = initialize >>= \ h -> do
setopt h (CurlFailOnError True)
setopt h (CurlURL url)
setDefaultSSLOpts h url
mapM_ (setopt h) opts
perform h
return ()
setDefaultSSLOpts :: Curl -> URLString -> IO ()
setDefaultSSLOpts h url
| "https:" `isPrefixOf` url = do
mapM_ (setopt h)
[ CurlSSLVerifyPeer False
, CurlSSLVerifyHost 0
]
| otherwise = return ()
curlGetString :: URLString
-> [CurlOption]
-> IO (CurlCode, String)
curlGetString url opts = initialize >>= \ h -> do
ref <- newIORef []
setopt h (CurlFailOnError True)
setDefaultSSLOpts h url
setopt h (CurlURL url)
setopt h (CurlWriteFunction (gatherOutput ref))
mapM_ (setopt h) opts
rc <- perform h
lss <- readIORef ref
return (rc, concat $ reverse lss)
data CurlResponse
= CurlResponse
{ respCurlCode :: CurlCode
, respStatus :: Int
, respStatusLine :: String
, respHeaders :: [(String,String)]
, respBody :: String
, respGetInfo :: (Info -> IO InfoValue)
}
curlGetResponse :: URLString
-> [CurlOption]
-> IO CurlResponse
curlGetResponse url opts = do
h <- initialize
body_ref <- newIORef []
hdr_ref <- newIORef []
setopt h (CurlFailOnError True)
setDefaultSSLOpts h url
setopt h (CurlURL url)
setopt h (CurlWriteFunction (gatherOutput body_ref))
setopt h (CurlHeaderFunction (gatherOutput hdr_ref))
mapM_ (setopt h) opts
perform_with_response h
perform_with_response :: Curl -> IO CurlResponse
perform_with_response h =
do body_ref <- newIORef []
hdr_ref <- newIORef []
setopt h (CurlWriteFunction (gatherOutput body_ref))
setopt h (CurlHeaderFunction (gatherOutput hdr_ref))
rc <- perform h
bss <- readIORef body_ref
hss <- readIORef hdr_ref
rspCode <- getResponseCode h
let (st,hs) = parseStatusNHeaders (concRev [] hss)
return CurlResponse
{ respCurlCode = rc
, respStatus = rspCode
, respStatusLine = st
, respHeaders = hs
, respBody = concRev [] bss
, respGetInfo = getInfo h
}
do_curl :: Curl -> URLString -> [CurlOption] -> IO CurlResponse
do_curl h url opts =
do setDefaultSSLOpts h url
setopts h opts
setopt h (CurlURL url)
perform_with_response h
curlHead :: URLString -> [CurlOption] -> IO (String,[(String,String)])
curlHead url opts = initialize >>= \ h ->
do ref <- newIORef []
setopt h (CurlURL url)
setopt h (CurlNoBody True)
mapM_ (setopt h) opts
setopt h (CurlHeaderFunction (gatherOutput ref))
perform h
lss <- readIORef ref
return (parseStatusNHeaders (concRev [] lss))
concRev :: [a] -> [[a]] -> [a]
concRev acc [] = acc
concRev acc (x:xs) = concRev (x++acc) xs
parseStatusNHeaders :: String -> (String, [(String,String)])
parseStatusNHeaders ys =
case intoLines [] ys of
a:as -> (a,map parseHeader as)
[] -> ("",[])
where
intoLines acc "" = addLine acc []
intoLines acc ('\r':'\n':xs) = addLine acc (intoLines "" xs)
intoLines acc (x:xs) = intoLines (x:acc) xs
addLine "" ls = ls
addLine l ls = (reverse l) : ls
parseHeader xs =
case break (':' ==) xs of
(as,_:bs) -> (as, bs)
(as,_) -> (as,"")
curlMultiPost :: URLString -> [CurlOption] -> [HttpPost] -> IO ()
curlMultiPost s os ps = initialize >>= \ h -> do
setopt h (CurlVerbose True)
setopt h (CurlURL s)
setopt h (CurlHttpPost ps)
mapM_ (setopt h) os
perform h
return ()
curlPost :: URLString -> [String] -> IO ()
curlPost s ps = initialize >>= \ h -> do
setopt h (CurlVerbose True)
setopt h (CurlPostFields ps)
setopt h (CurlCookieJar "cookies")
setopt h (CurlURL s)
perform h
return ()
easyWriter :: (String -> IO ()) -> WriteFunction
easyWriter = callbackWriter
callbackWriter :: (String -> IO ()) -> WriteFunction
callbackWriter f pBuf sz szI _ =
do let bytes = sz * szI
f =<< peekCStringLen (pBuf,fromIntegral bytes)
return bytes
ignoreOutput :: WriteFunction
ignoreOutput _ x y _ = return (x*y)
gatherOutput :: IORef [String] -> WriteFunction
gatherOutput r = callbackWriter $ \xs -> do xss <- readIORef r
writeIORef r (xs:xss)
getResponseCode :: Curl -> IO Int
getResponseCode c = do
iv <- getInfo c ResponseCode
case iv of
IString s ->
case (reads s) of
((v,_):_) -> return v
_ -> fail ("Curl.getResponseCode: not a valid integer string " ++ s)
IDouble d -> return (round d)
ILong x -> return (fromIntegral x)
IList{} -> fail ("Curl.getResponseCode: unexpected response code " ++ show iv)