diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 winterland + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,28 @@ +Apiary HTTP Client +================== + +A HTTP Client for [Apiary](http://hackage.haskell.org/package/apiary), using `Apiary`'s extension api, suitable for proxying HTTP request to backend API, with flexible APIs and streamming proxying abilities. + +This module also reexport `Network.HTTP.Client`. Example: + +```haskell +main :: IO () +main = runApiaryWith (run serverPort) (HTTP.initHTTPClient HTTP.defaultManagerSettings) def $ do + + [capture|/query|] . action $ do + + -- make a new Network.HTTP.Client.Request from current ActionT's Network.Wai.Request + -- it's recommended to use resetHeaders to remove following headers: + -- Transfer-Encoding, Content-Length, Content-Encoding and Accept-Encoding. + req <- HTTP.fromRequest id resetHeaders + + -- set proxying host and port + -- use function from Network.HTTP.Client to modify more + let req' = HTTP.setHost influxDB_API_HOST . HTTP.setPort 80 $ req + + -- send request and proxy respond in streamming fashion. + HTTP.proxyTo req' +``` + + +More document are W.I.P. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Web/Apiary/HTTP/Client.hs b/Web/Apiary/HTTP/Client.hs new file mode 100644 --- /dev/null +++ b/Web/Apiary/HTTP/Client.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} + +module Web.Apiary.HTTP.Client + ( HTTPClient + , initHTTPClient + , getManager + , withHTTPClient + -- ** helpers to make new Request + , fromWaiRequest + , fromRequest + , resetHeaders + , setPort + , setHost + , setHostName + , setHostHeader + -- ** send request and get respond + , sendRequset + , openRequset + -- ** send request for side effect + , sendRequsetNoBody + -- ** send request and proxy respond + , proxyTo + , proxyWith + , module Network.HTTP.Client + ) where + +import Control.Monad.IO.Class +import Network.HTTP.Client +import qualified Network.Wai as W +import Network.HTTP.Types.Header +import Data.Apiary.Extension +import qualified Data.Proxy.Compat as P (Proxy(..)) +import Unsafe.Coerce (unsafeCoerce) +import Data.Default.Class +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 + +-- |Initialize a @MonadExts@ with @Network.HTTP.Client.ManagerSettings@. +initHTTPClient :: MonadIO m + => ManagerSettings -> Initializer m exts (HTTPClient ': exts) +initHTTPClient ms = initializer' . liftIO $ newManager ms >>= return . HTTPClient + +-- |Get @Network.HTTP.Client.Manage@ from Apiary's @MonadExts@ context. +getManager :: (Has HTTPClient es, MonadExts es m, MonadIO m) => m Manager +getManager = do + (HTTPClient manager) <- getExt (P.Proxy :: P.Proxy HTTPClient) + return manager + +-- |lift operations with initial 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 + +-- |Copy path, headers, body and queryString from @Network.Wai.Request@ +fromWaiRequest + :: ([T.Text] -> [T.Text]) -- ^ Function to modify request path + -> ([Header] -> [Header]) -- ^ Function to modify request headers + -> W.Request -> Request -- ^ From @Network.Wai.Request@ To @Network.HTTP.Client.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 + def { + queryString = W.rawQueryString req + , path = T.encodeUtf8 (T.intercalate "/" path) + , requestHeaders = headers + , requestBody = requestBody' + } + +-- |Remove following headers: +-- Transfer-Encoding, Content-Length, Content-Encoding and Accept-Encoding. +-- It's very likely you want to do this. +resetHeaders :: [Header] -> [Header] +resetHeaders = filter (\ (name, _) -> name `notElem` [hTransferEncoding, hContentLength, hContentEncoding, hAcceptEncoding]) + +-- |Copy path, headers, body and queryString from current @ActionT@'s context. +fromRequest + :: (Has HTTPClient exts, MonadIO m) + => ([T.Text] -> [T.Text]) -- ^ Function to modify request path + -> ([Header] -> [Header]) -- ^ Function to modify request headers + -> 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 + +-- |send requset and get @Response@ @ByteString@ +-- For large response consider using @openRequset@ and @responseClose@ instead. +sendRequset :: (Has HTTPClient exts, MonadIO m) + => Request -> A.ActionT exts prms m (Response LB.ByteString) +sendRequset req = withHTTPClient httpLbs req + +-- |send request without receive any body. +sendRequsetNoBody :: (Has HTTPClient exts, MonadIO m) + => Request -> A.ActionT exts prms m (Response ()) +sendRequsetNoBody req = withHTTPClient httpNoBody req + +-- |send request and get @Response@ @BodyReader@ +openRequset :: (Has HTTPClient exts, MonadIO m) + => Request -> A.ActionT exts prms m (Response BodyReader) +openRequset req = withHTTPClient responseOpen req + +-- |streamming response directly from proxy target. +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 + +-- |Modify response from proxy target then send. +-- You should consider remove following headers: +-- Transfer-Encoding, Content-Length, Content-Encoding and Accept-Encoding. +proxyWith + :: (Has HTTPClient exts, MonadIO m) + => Request + -> (Response LB.ByteString -> Response LB.ByteString) -- ^ Function to modify response. + -> 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') diff --git a/apiary-http-client.cabal b/apiary-http-client.cabal new file mode 100644 --- /dev/null +++ b/apiary-http-client.cabal @@ -0,0 +1,34 @@ +-- Initial apiary-http-client.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: apiary-http-client +version: 0.1.0.0 +synopsis: A http client for Apiary. +-- synopsis: +-- description: +homepage: https://github.com/winterland1989/apiary-http-client +license: MIT +license-file: LICENSE +author: winterland +maintainer: winterland1989@gmail.com +-- copyright: +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: Web.Apiary.HTTP.Client + -- other-modules: + build-depends: base >=4.8 && <4.9 + , transformers + , types-compat >=0.1 && <0.2 + , http-client >=0.4.26 + , http-types >=0.8 + , apiary >=1.0.0 + , wai + , data-default-class + , bytestring + , text + -- hs-source-dirs: + default-language: Haskell2010