module Web.Apiary.HTTP.Client
( HTTPClient
, initHTTPClient
, getManager
, withHTTPClient
, fromWaiRequest
, fromRequest
, resetHeaders
, setPort
, setHostName
, setHostHeader
, setHost
, sendRequset
, openRequset
, sendRequsetNoBody
, proxyTo
, proxyWith
, forwardBadStatus
, forwardBadStatus'
, module Network.HTTP.Client
) where
import Control.Monad.IO.Class
import Control.Exception (throwIO)
import Network.HTTP.Client hiding (Proxy)
import qualified Network.Wai as W
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status (notFound404)
import Data.Apiary.Extension
import Data.Proxy
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Builder as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Control.Monad.Apiary.Action as A
newtype HTTPClient = HTTPClient Manager
instance Extension HTTPClient
initHTTPClient :: MonadIO m
=> Manager -> Initializer m exts (HTTPClient ': exts)
initHTTPClient manager = initializer' . liftIO $ return (HTTPClient manager)
getManager :: (Has HTTPClient es, MonadExts es m, MonadIO m) => m Manager
getManager = do
(HTTPClient manager) <- getExt (Proxy :: Proxy HTTPClient)
return manager
withHTTPClient :: (Has HTTPClient es, MonadExts es m, MonadIO m)
=> (Request -> Manager -> IO a) -> Request -> m a
withHTTPClient f r = do
manager <- getManager
liftIO $ f r manager
fromWaiRequest
:: ([T.Text] -> [T.Text])
-> ([Header] -> [Header])
-> W.Request -> Request
fromWaiRequest pm hm req =
let
needsPopper = \ r -> r (W.requestBody req)
path = pm (W.pathInfo req)
headers = hm (W.requestHeaders req)
requestBody' = case W.requestBodyLength req of
W.ChunkedBody -> RequestBodyStreamChunked needsPopper
W.KnownLength len -> RequestBodyStream (unsafeCoerce len) needsPopper
in
defaultRequest {
queryString = W.rawQueryString req
, path = T.encodeUtf8 (T.intercalate "/" path)
, method = W.requestMethod req
, requestHeaders = headers
, requestBody = requestBody'
}
resetHeaders :: [Header] -> [Header]
resetHeaders = filter (\ (name, _) -> name `notElem` [hTransferEncoding, hContentLength, hContentEncoding, hAcceptEncoding])
fromRequest
:: (Has HTTPClient exts, MonadIO m)
=> ([T.Text] -> [T.Text])
-> ([Header] -> [Header])
-> A.ActionT exts prms m Request
fromRequest pm hm= A.getRequest >>= return . fromWaiRequest pm hm
setPort :: Int -> Request -> Request
setPort port req = req{ port = port }
setHostName :: B.ByteString -> Request -> Request
setHostName host req = req{ host = host }
setHostHeader :: B.ByteString -> Request -> Request
setHostHeader host req = req{ requestHeaders = headers }
where
oHeaders = requestHeaders req
headers = (hHost, host) : filter (\ (name, _) -> name /= hHost ) oHeaders
setHost :: B.ByteString -> Request -> Request
setHost host = setHostHeader host . setHostName host
sendRequset :: (Has HTTPClient exts, MonadIO m)
=> Request -> A.ActionT exts prms m (Response LB.ByteString)
sendRequset req = withHTTPClient httpLbs req
sendRequsetNoBody :: (Has HTTPClient exts, MonadIO m)
=> Request -> A.ActionT exts prms m (Response ())
sendRequsetNoBody req = withHTTPClient httpNoBody req
openRequset :: (Has HTTPClient exts, MonadIO m)
=> Request -> A.ActionT exts prms m (Response BodyReader)
openRequset req = withHTTPClient responseOpen req
proxyTo :: (Has HTTPClient exts, MonadIO m)
=> Request -> A.ActionT exts prms m ()
proxyTo req = do
res <- openRequset req
A.rawResponse $ \ _ _ ->
W.responseStream
(responseStatus res)
(resetHeaders $ responseHeaders res)
$ \ sendBuilder flush ->
let
bodyReader = responseBody res
loop = do
bs <- bodyReader
if B.null bs then responseClose res >> flush
else sendBuilder (B.byteString bs) >> loop
in loop
proxyWith
:: (Has HTTPClient exts, MonadIO m)
=> Request
-> (Response LB.ByteString -> Response LB.ByteString)
-> A.ActionT exts prms m ()
proxyWith req modifier = do
resLbs <- sendRequset req
let resLbs' = modifier resLbs
A.status (responseStatus resLbs')
A.setHeaders (responseHeaders resLbs')
A.lazyBytes (responseBody resLbs')
forwardBadStatus :: (Has HTTPClient exts, MonadIO m)
=> HttpException -> A.ActionT exts prms m ()
forwardBadStatus (HttpExceptionRequest _ (StatusCodeException s h)) = A.status (responseStatus s) >> A.stop
forwardBadStatus err = liftIO $ throwIO err
forwardBadStatus' :: (Has HTTPClient exts, MonadIO m)
=> HttpException -> A.ActionT exts prms m ()
forwardBadStatus' (HttpExceptionRequest _ (StatusCodeException s h)) = A.status (responseStatus s) >> A.stop
forwardBadStatus' err = A.status notFound404 >> A.showing err >> A.stop