module Network.HTTP.Dispatch.Internal.Request
( toRequest
, runRequest
, Runnable
) where
import Control.Applicative ((<$>))
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as LBS
import qualified Data.CaseInsensitive as CI
import Data.List (isPrefixOf)
import Network.HTTP.Client as Client
import Network.HTTP.Client.TLS
import Network.HTTP.Dispatch.Types (HTTPRequest (..),
HTTPRequestMethod (..),
HTTPResponse (..), Header (..))
import Network.HTTP.Types (RequestHeaders, Status (..))
toRequest :: HTTPRequest -> IO Client.Request
toRequest (HTTPRequest method url headers body) = do
initReq <- parseRequest url
let hdrs = map (\(k, v) -> (CI.mk k, v)) headers
req = initReq
{ method = C.pack . show $ method
, requestHeaders = hdrs
}
case body of
Just lbs ->
return $ req { requestBody = RequestBodyBS lbs }
Nothing ->
return req
getManagerForUrl :: String -> IO Manager
getManagerForUrl url =
if ("https" `isPrefixOf` url) then newManager tlsManagerSettings
else newManager defaultManagerSettings
toResponse :: Client.Response LBS.ByteString -> HTTPResponse
toResponse resp =
let rStatus = statusCode . responseStatus $ resp
rHdrs = responseHeaders resp
rBody = LBS.toStrict $ responseBody resp
in
HTTPResponse rStatus (map (\(k,v) ->
let hk = CI.original k
in
(hk, v)) rHdrs) rBody
class Runnable a where
runRequest :: a -> IO HTTPResponse
runRequestWithSettings :: a -> ManagerSettings -> IO HTTPResponse
instance Runnable HTTPRequest where
runRequest httpRequest = do
manager <- getManagerForUrl (reqUrl httpRequest)
request <- toRequest httpRequest
toResponse <$> httpLbs request manager
runRequestWithSettings httpRequest settings = do
manager <- newManager settings
request <- toRequest httpRequest
toResponse <$> httpLbs request manager