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)
then [ CurlHttpGet True,CurlCustomRequest (show other) ]
else [ CurlPost True,CurlCustomRequest (show other) ]
curlPostData = if (B.null.reqPayload $ req)
then []
else [ CurlPostFields [map (chr.fromIntegral).B.unpack.reqPayload $ req] ]
curlHeaders = let headers = (map (\(k,v) -> k++": "++v).toList.reqHeaders $ req)
in [ CurlHttpHeaders $ ("Content-Length: " ++ (show.B.length.reqPayload $ req))
: headers
]
opts = [ CurlURL (showURL req)
, CurlHttpVersion httpVersion
, CurlHeader False
, CurlSSLVerifyHost 1
, CurlSSLVerifyPeer False
, 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)