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_(..)
, CurlResponse
, curlGet
, curlGetString
, curlGetResponse
, perform_with_response
, do_curl
, curlGetString_
, curlGetResponse_
, perform_with_response_
, do_curl_
, curlHead_
, curlHead
, curlMultiPost
, curlPost
, getResponseCode
, setDefaultSSLOpts
, callbackWriter
, easyWriter
, ignoreOutput
, gatherOutput
, gatherOutput_
, CurlBuffer(..)
, CurlHeader(..)
, method_GET
, method_HEAD
, method_POST
, parseStatusNHeaders
, parseHeader
, 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
import Control.Exception ( finally )
import Data.ByteString ( ByteString, packCStringLen )
import qualified Data.ByteString as BS ( concat )
import qualified Data.ByteString.Lazy as LazyBS ( ByteString, fromChunks )
class CurlBuffer bufferTy where
newIncoming :: IO (IO bufferTy, CStringLen -> IO ())
class CurlHeader headerTy where
newIncomingHeader :: IO (IO (String,headerTy), CStringLen -> IO ())
instance CurlHeader [(String,String)] where
newIncomingHeader = do
ref <- newIORef []
let readFinalHeader = do
hss <- readIORef ref
let (st,hs) = parseStatusNHeaders (concRev [] hss)
return (st,hs)
return (readFinalHeader, \ v -> peekCStringLen v >>= \ x -> modifyIORef ref (x:))
instance CurlBuffer String where
newIncoming = do
ref <- newIORef []
let readFinal = readIORef ref >>= return . concat . reverse
return (readFinal, \ v -> peekCStringLen v >>= \ x -> modifyIORef ref (x:))
instance CurlBuffer ByteString where
newIncoming = do
ref <- newIORef []
let readFinal = readIORef ref >>= return . BS.concat . reverse
return (readFinal, \ v -> packCStringLen v >>= \ x -> modifyIORef ref (x:))
instance CurlBuffer [ByteString] where
newIncoming = do
ref <- newIORef []
let readFinal = readIORef ref >>= return . reverse
return (readFinal, \ v -> packCStringLen v >>= \ x -> modifyIORef ref (x:))
instance CurlBuffer LazyBS.ByteString where
newIncoming = do
ref <- newIORef []
let readFinal = readIORef ref >>= return . LazyBS.fromChunks . reverse
return (readFinal, \ v -> packCStringLen v >>= \ x -> modifyIORef ref (x:))
withCurlDo :: IO a -> IO a
withCurlDo m = do curl_global_init 3
finally m curl_global_cleanup
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)
curlGetString_ :: (CurlBuffer ty)
=> URLString
-> [CurlOption]
-> IO (CurlCode, ty)
curlGetString_ url opts = initialize >>= \ h -> do
(finalBody, gatherBody) <- newIncoming
setopt h (CurlFailOnError True)
setDefaultSSLOpts h url
setopt h (CurlURL url)
setopt h (CurlWriteFunction (gatherOutput_ gatherBody))
mapM_ (setopt h) opts
rc <- perform h
bs <- finalBody
return (rc, bs)
type CurlResponse = CurlResponse_ [(String,String)] String
data CurlResponse_ headerTy bodyTy
= CurlResponse
{ respCurlCode :: CurlCode
, respStatus :: Int
, respStatusLine :: String
, respHeaders :: headerTy
, respBody :: bodyTy
, respGetInfo :: (Info -> IO InfoValue)
}
curlGetResponse_ :: (CurlHeader hdr, CurlBuffer ty)
=> URLString
-> [CurlOption]
-> IO (CurlResponse_ hdr ty)
curlGetResponse_ url opts = do
h <- initialize
setopt h (CurlFailOnError True)
setDefaultSSLOpts h url
setopt h (CurlURL url)
mapM_ (setopt h) opts
perform_with_response_ h
curlGetResponse :: URLString
-> [CurlOption]
-> IO CurlResponse
curlGetResponse url opts = curlGetResponse_ url opts
perform_with_response :: (CurlHeader hdrTy, CurlBuffer bufTy)
=> Curl
-> IO (CurlResponse_ hdrTy bufTy)
perform_with_response h = perform_with_response_ h
perform_with_response_ :: (CurlHeader headerTy, CurlBuffer bodyTy)
=> Curl
-> IO (CurlResponse_ headerTy bodyTy)
perform_with_response_ h = do
(finalHeader, gatherHeader) <- newIncomingHeader
(finalBody, gatherBody) <- newIncoming
setopt h (CurlWriteFunction (gatherOutput_ gatherBody))
setopt h (CurlHeaderFunction (gatherOutput_ gatherHeader))
rc <- perform h
rspCode <- getResponseCode h
(st,hs) <- finalHeader
bs <- finalBody
return CurlResponse
{ respCurlCode = rc
, respStatus = rspCode
, respStatusLine = st
, respHeaders = hs
, respBody = bs
, respGetInfo = getInfo h
}
do_curl :: Curl -> URLString -> [CurlOption] -> IO CurlResponse
do_curl h url opts = do_curl_ h url opts
do_curl_ :: (CurlHeader headerTy, CurlBuffer bodyTy)
=> Curl
-> URLString
-> [CurlOption]
-> IO (CurlResponse_ headerTy bodyTy)
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))
curlHead_ :: (CurlHeader headers)
=> URLString
-> [CurlOption]
-> IO (String, headers)
curlHead_ url opts = initialize >>= \ h -> do
(finalHeader, gatherHeader) <- newIncomingHeader
setopt h (CurlURL url)
setopt h (CurlNoBody True)
mapM_ (setopt h) opts
setopt h (CurlHeaderFunction (gatherOutput_ gatherHeader))
perform h
finalHeader
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 :: String -> (String,String)
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
callbackWriter_ :: (CStringLen -> IO ()) -> WriteFunction
callbackWriter_ f pBuf sz szI _ = do
do let bytes = sz * szI
f (pBuf,fromIntegral bytes)
return bytes
ignoreOutput :: WriteFunction
ignoreOutput _ x y _ = return (x*y)
gatherOutput :: IORef [String] -> WriteFunction
gatherOutput r = callbackWriter (\ v -> modifyIORef r (v:))
gatherOutput_ :: (CStringLen -> IO ()) -> WriteFunction
gatherOutput_ f = callbackWriter_ f
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)