http-reverse-proxy 0.4.1.3 → 0.4.2

raw patch · 3 files changed

+103/−48 lines, 3 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Network/HTTP/ReverseProxy.hs +98/−47
• http-reverse-proxy.cabal +1/−1

@@ -1,3 +1,7 @@+## 0.4.2++*  Add configurable timeouts [#8](https://github.com/fpco/http-reverse-proxy/pull/8)+ ## 0.4.1.3  * Include README.md and ChangeLog.md

@@ -1,4 +1,9 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE TupleSections         #-} module Network.HTTP.ReverseProxy     ( -- * Types       ProxyDest (..)@@ -17,49 +22,55 @@     , wpsSetIpHeader     , wpsProcessBody     , wpsUpgradeToRaw+    , wpsGetDest     , SetIpHeader (..)+      -- *** Local settings+    , LocalWaiProxySettings+    , defaultLocalWaiProxySettings+    , setLpsTimeBound     {- FIXME       -- * WAI to Raw     , waiToRaw     -}     ) where -import Data.Conduit-import Data.Streaming.Network (readLens, AppData)-import Data.Functor.Identity (Identity (..))-import Data.Maybe (fromMaybe)-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Default.Class (def)-import qualified Network.Wai as WAI-import qualified Network.HTTP.Client as HC-import Network.HTTP.Client (BodyReader, brRead)-import Control.Exception (bracket)-import Blaze.ByteString.Builder (fromByteString)-import Data.Word8 (isSpace, _colon, _cr)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Network.HTTP.Types as HT-import qualified Data.CaseInsensitive as CI-import qualified Data.Text.Lazy.Encoding as TLE-import qualified Data.Text.Lazy as TL-import qualified Data.Conduit.Network as DCN-import Control.Concurrent.MVar.Lifted (newEmptyMVar, putMVar, takeMVar)-import Control.Concurrent.Lifted (fork, killThread)-import Data.Default.Class (Default (..))-import Network.Wai.Logger (showSockAddr)-import qualified Data.Set as Set-import Data.IORef-import qualified Data.ByteString.Lazy as L-import Control.Concurrent.Async (concurrently)-import Blaze.ByteString.Builder (Builder, toLazyByteString)-import Data.ByteString (ByteString)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad (unless, void)-import Data.Monoid (mappend, (<>), mconcat)-import Control.Exception.Lifted (try, SomeException, finally)-import Control.Applicative ((<$>), (<|>))-import Data.Set (Set)-import qualified Data.Conduit.List as CL+import           Blaze.ByteString.Builder       (Builder, fromByteString,+                                                 toLazyByteString)+import           Control.Applicative            ((<$>), (<|>))+import           Control.Concurrent.Async       (concurrently)+import           Control.Concurrent.Lifted      (fork, killThread)+import           Control.Concurrent.MVar.Lifted (newEmptyMVar, putMVar,+                                                 takeMVar)+import           Control.Exception              (bracket)+import           Control.Exception.Lifted       (SomeException, finally, try)+import           Control.Monad                  (unless, void)+import           Control.Monad.IO.Class         (MonadIO, liftIO)+import           Control.Monad.Trans.Control    (MonadBaseControl)+import           Data.ByteString                (ByteString)+import qualified Data.ByteString                as S+import qualified Data.ByteString.Char8          as S8+import qualified Data.ByteString.Lazy           as L+import qualified Data.CaseInsensitive           as CI+import           Data.Conduit+import qualified Data.Conduit.List              as CL+import qualified Data.Conduit.Network           as DCN+import           Data.Default.Class             (Default (..), def)+import           Data.Functor.Identity          (Identity (..))+import           Data.IORef+import           Data.Maybe                     (fromMaybe)+import           Data.Monoid                    (mappend, mconcat, (<>))+import           Data.Set                       (Set)+import qualified Data.Set                       as Set+import           Data.Streaming.Network         (AppData, readLens)+import qualified Data.Text.Lazy                 as TL+import qualified Data.Text.Lazy.Encoding        as TLE+import           Data.Word8                     (isSpace, _colon, _cr)+import           Network.HTTP.Client            (BodyReader, brRead)+import qualified Network.HTTP.Client            as HC+import qualified Network.HTTP.Types             as HT+import qualified Network.Wai                    as WAI+import           Network.Wai.Logger             (showSockAddr)+import           System.Timeout.Lifted          (timeout)  -- | Host\/port combination to which we want to proxy. data ProxyDest = ProxyDest@@ -174,6 +185,31 @@            -> WAI.Application waiProxyTo getDest onError = waiProxyToSettings getDest def { wpsOnExc = onError } +data LocalWaiProxySettings = LocalWaiProxySettings+    { lpsTimeBound :: Maybe Int+    -- ^ Allows to specify the maximum time allowed for the conection on per request basis.+    --+    -- Default: no timeouts+    --+    -- Since 0.4.2+    }+instance Default LocalWaiProxySettings where+    def = LocalWaiProxySettings Nothing++-- | Default value for 'LocalWaiProxySettings', same as 'def' but with a more explicit name.+--+-- Since 0.4.2+defaultLocalWaiProxySettings :: LocalWaiProxySettings+defaultLocalWaiProxySettings = def++-- | Allows to specify the maximum time allowed for the conection on per request basis.+--+-- Default: no timeouts+--+-- Since 0.4.2+setLpsTimeBound :: Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings+setLpsTimeBound x s = s { lpsTimeBound = x }+ data WaiProxySettings = WaiProxySettings     { wpsOnExc :: SomeException -> WAI.Application     , wpsTimeout :: Maybe Int@@ -195,6 +231,14 @@     -- Default: check if the upgrade header is websocket.     --     -- Since 0.3.1+    , wpsGetDest :: Maybe (WAI.Request -> IO (LocalWaiProxySettings, WaiProxyResponse))+    -- ^ Allow to override proxy settings for each request.+    -- If you supply this field it will take precedence over+    -- getDest parameter in waiProxyToSettings+    --+    -- Default: have one global setting+    --+    -- Since 0.4.2     }  -- | How to set the X-Real-IP request header.@@ -212,6 +256,7 @@         , wpsProcessBody = const Nothing         , wpsUpgradeToRaw = \req ->             (CI.mk <$> lookup "upgrade" (WAI.requestHeaders req)) == Just "websocket"+        , wpsGetDest = Nothing         }  renderHeaders :: WAI.Request -> HT.RequestHeaders -> Builder@@ -282,16 +327,24 @@                    -> WaiProxySettings                    -> HC.Manager                    -> WAI.Application-waiProxyToSettings getDest wps manager req0 sendResponse = do-    edest' <- getDest req0+waiProxyToSettings getDest wps' manager req0 sendResponse = do+    let wps = wps'{wpsGetDest = wpsGetDest wps' <|> Just (fmap (LocalWaiProxySettings $ wpsTimeout wps',) . getDest)}+    (lps, edest') <- fromMaybe+        (const $ return (def, WPRResponse $ WAI.responseLBS HT.status500 [] "proxy not setup"))+        (wpsGetDest wps)+        req0     let edest =             case edest' of                 WPRResponse res -> Left $ \_req -> ($ res)                 WPRProxyDest pd -> Right (pd, req0)                 WPRModifiedRequest req pd -> Right (pd, req)                 WPRApplication app -> Left app+        timeBound us f =+            timeout us f >>= \case+                Just res -> return res+                Nothing -> sendResponse $ WAI.responseLBS HT.status500 [] "timeBound"     case edest of-        Left app -> app req0 sendResponse+        Left app -> maybe id timeBound (lpsTimeBound lps) $ app req0 sendResponse         Right (ProxyDest host port, req) -> tryWebSockets wps host port req sendResponse $ do             let req' = def                     { HC.method = WAI.requestMethod req@@ -303,7 +356,7 @@                     , HC.requestBody = body                     , HC.redirectCount = 0                     , HC.checkStatus = \_ _ _ -> Nothing-                    , HC.responseTimeout = wpsTimeout wps+                    , HC.responseTimeout = lpsTimeBound lps                     }                 body =                     case WAI.requestBodyLength req of@@ -314,14 +367,12 @@             bracket                 (try $ HC.responseOpen req' manager)                 (either (const $ return ()) HC.responseClose)-                $ \ex -> do-                case ex of+                $ \case                     Left e -> wpsOnExc wps e req sendResponse                     Right res -> do-                        let conduit =-                                case wpsProcessBody wps $ fmap (const ()) res of-                                    Nothing -> awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush)-                                    Just conduit' -> conduit'+                        let conduit = fromMaybe+                                        (awaitForever (\bs -> yield (Chunk $ fromByteString bs) >> yield Flush))+                                        (wpsProcessBody wps $ const () <$> res)                             src = bodyReaderSource $ HC.responseBody res                         sendResponse $ WAI.responseStream                             (HC.responseStatus res)

@@ -1,5 +1,5 @@ name:                http-reverse-proxy-version:             0.4.1.3+version:             0.4.2 synopsis:            Reverse proxy HTTP requests, either over raw sockets or with WAI description:         Provides a simple means of reverse-proxying HTTP requests. The raw approach uses the same technique as leveraged by keter, whereas the WAI approach performs full request/response parsing via WAI and http-conduit. homepage:            https://github.com/fpco/http-reverse-proxy