module Network.OAuth.Http.CurlHttpClient
( CurlClient(..)
) where
import Network.Curl
import Network.OAuth.Http.HttpClient
import Network.OAuth.Http.Request
import Network.OAuth.Http.Response
import Control.Monad.Trans
import Data.Char (chr,ord)
import qualified Data.ByteString.Lazy as B
data CurlClient = CurlClient | OptionsCurlClient [CurlOption]
instance HttpClient CurlClient where
runClient client req = liftIO $ withCurlDo $ do { c <- initialize
; setopts c opts
; rsp <- perform_with_response_ c
; case (respCurlCode rsp)
of errno
| errno `elem` successCodes -> return $ Right (fromResponse rsp)
| otherwise -> return $ Left (show errno)
}
where httpVersion = case (version req)
of Http10 -> HttpVersion10
Http11 -> HttpVersion11
successCodes = [ CurlOK
, CurlHttpReturnedError
]
curlMethod = case (method req)
of GET -> [ CurlHttpGet True ]
HEAD -> [ CurlNoBody True,CurlCustomRequest "HEAD" ]
other -> if ((B.null . reqPayload $ req) && 0 == length (multipartPayload req))
then [ CurlHttpGet True,CurlCustomRequest (show other) ]
else [ CurlPost True,CurlCustomRequest (show other) ]
curlPostData =
if B.null . reqPayload $ req
then
case multipartPayload req
of [] -> []
parts -> [CurlHttpPost (convertMultipart parts)]
else
case multipartPayload req
of [] -> let tostr = map (chr.fromIntegral).B.unpack
field = reqPayload req
in [CurlPostFields [tostr field]]
_ -> error "with both CurlPostFields and CurlHttpPost, I'm not sure what libcurl would do..."
curlHeaders = let headers = (map (\(k,v) -> k++": "++v).toList.reqHeaders $ req)
in [CurlHttpHeaders headers]
opts = [ CurlURL (showURL req)
, CurlHttpVersion httpVersion
, CurlHeader False
, CurlSSLVerifyHost 2
, CurlSSLVerifyPeer True
, CurlTimeout 30
] ++ curlHeaders
++ curlMethod
++ curlPostData
++ clientOptions
clientOptions = case client
of CurlClient -> []
OptionsCurlClient o -> o
fromResponse rsp = RspHttp (respStatus rsp) (respStatusLine rsp) (fromList.respHeaders $ rsp) (B.pack.map (fromIntegral.ord).respBody $ rsp)