keter 1.3.0 → 1.3.1

raw patch · 11 files changed

+63/−54 lines, 11 filesdep +http-clientdep ~http-reverse-proxydep ~processdep ~wai

Dependencies added: http-client

Dependency ranges changed: http-reverse-proxy, process, wai, wai-app-static

Files

• Data/Conduit/LogFile.hs +8/−8
• Data/Conduit/Process/Unix.hs +3/−4
• Keter/HostManager.hs +1/−0
• Keter/LabelMap.hs +1/−1
• Keter/Main.hs +1/−1
• Keter/Proxy.hs +12/−12
• Keter/Types/V04.hs +3/−4
• Keter/Types/V10.hs +4/−4
• Network/HTTP/ReverseProxy/Rewrite.hs +16/−13
• keter.cabal +7/−4
• main/keter.hs +7/−3

@@ -66,12 +66,12 @@ openRotatingLog dir maxTotal = do     createDirectoryIfMissing True dir     bracketOnError (moveCurrent dir) SIO.hClose $ \handle -> do-        queue <- newTBQueueIO 5-        let s = Running handle queue+        queue' <- newTBQueueIO 5+        let s = Running handle queue'         ts <- newTVarIO s         void $ forkIO $ loop dir ts maxTotal         let rl = RotatingLog ts-        addFinalizer rl (atomically (writeTBQueue queue Close))+        addFinalizer rl (atomically (writeTBQueue queue' Close))         return rl  current :: FilePath -- ^ folder containing logs@@ -117,14 +117,14 @@             s <- readTVar ts             case s of                 Closed -> return Nothing-                Running handle queue -> do-                    cmd <- readTBQueue queue+                Running handle queue' -> do+                    cmd <- readTBQueue queue'                     case cmd of                         Close -> return Nothing-                        AddChunk bs -> return $! Just (handle, queue, bs)+                        AddChunk bs -> return $! Just (handle, queue', bs)         case res of             Nothing -> return ()-            Just (handle, queue, bs) -> do+            Just (handle, queue', bs) -> do                 let total' = total + fromIntegral (S.length bs)                 S.hPut handle bs                 SIO.hFlush handle@@ -132,7 +132,7 @@                     then do                         bracket                             (SIO.hClose handle >> moveCurrent dir)-                            (\handle' -> atomically $ writeTVar ts $ Running handle' queue)+                            (\handle' -> atomically $ writeTVar ts $ Running handle' queue')                             (const $ return ())                         go 0                     else go total'

@@ -44,10 +44,9 @@ import           Foreign.C.Types import           Prelude                         (Bool (..), Either (..), IO,                                                   Maybe (..), Monad (..), Show,-                                                  const, error, flip, fmap,-                                                  fromIntegral, fst, head, id,-                                                  length, map, maybe, show, snd,-                                                  ($), ($!), (*), (.), (<),+                                                  const, error,+                                                  map, maybe, show,+                                                  ($), ($!), (*), (<),                                                   (==)) import           System.Exit                     (ExitCode) import           System.IO                       (hClose)

@@ -28,6 +28,7 @@ import           Keter.Types
 import           Keter.LabelMap      (LabelMap)
 import qualified Keter.LabelMap      as LabelMap
+import           Prelude             hiding (log)
 
 type HMState = LabelMap HostValue
 

@@ -224,7 +224,7 @@ lookupTree _ EmptyLabelMap = Nothing  lookupTree [l] (Static t)   = Map.lookup l t >>= getPortEntry-lookupTree [_] (Wildcard w) = getPortEntry $ w+--lookupTree (_:_) (Wildcard w) = getPortEntry $ w lookupTree [l] (WildcardExcept w t) =     case Map.lookup l t >>= getPortEntry of         Just e  -> Just e

@@ -147,7 +147,7 @@ startWatching kc@KeterConfig {..} appMan log = do     -- File system watching     wm <- FSN.startManager-    FSN.watchDir wm incoming (const True) $ \e -> do+    _ <- FSN.watchDir wm incoming (const True) $ \e -> do         e' <-             case e of                 FSN.Removed fp _ -> do

@@ -44,10 +44,7 @@ reverseProxy useHeader manager hostLookup listener =     run $ withClient useHeader manager hostLookup   where-    warp host port = Warp.defaultSettings-        { Warp.settingsHost = host-        , Warp.settingsPort = port-        }+    warp host port = Warp.setHost host $ Warp.setPort port Warp.defaultSettings     run =         case listener of             LPInsecure host port -> Warp.runSettings (warp host port)@@ -59,13 +56,13 @@            -> Manager            -> HostLookup            -> Wai.Application-withClient useHeader manager portLookup =-    timeBound (5 * 60 * 1000 * 1000) . waiProxyToSettings getDest def+withClient useHeader manager portLookup req0 sendResponse =+    timeBound (5 * 60 * 1000 * 1000) (waiProxyToSettings getDest def         { wpsSetIpHeader =             if useHeader                 then SIHFromHeader                 else SIHFromSocket-        } manager+        } manager req0 sendResponse)   where     -- FIXME This is a temporary workaround for     -- https://github.com/snoyberg/keter/issues/29. After some research, it@@ -78,12 +75,15 @@         mres <- timeout us f         case mres of             Just res -> return res-            Nothing -> return $ Wai.responseLBS status500 [] "timeBound"+            Nothing -> sendResponse $ Wai.responseLBS status500 [] "timeBound"++    getDest :: Wai.Request -> IO WaiProxyResponse     getDest req =         case lookup "host" $ Wai.requestHeaders req of             Nothing -> return $ WPRResponse missingHostResponse             Just host -> processHost req host +    processHost :: Wai.Request -> S.ByteString -> IO WaiProxyResponse     processHost req host = do         mport <- liftIO $ portLookup host         case mport of@@ -92,15 +92,15 @@      performAction _ (PAPort port) =         return $ WPRProxyDest $ ProxyDest "127.0.0.1" port-    performAction req (PAStatic StaticFilesConfig {..}) =-        fmap WPRResponse $ staticApp (defaultFileServerSettings sfconfigRoot)+    performAction _ (PAStatic StaticFilesConfig {..}) = do+        return $ WPRApplication $ staticApp (defaultFileServerSettings sfconfigRoot)             { ssListing =                 if sfconfigListings                     then Just defaultListing                     else Nothing-            } req+            }     performAction req (PARedirect config) = return $ WPRResponse $ redirectApp config req-    performAction req (PAReverseProxy config) = fmap WPRResponse $ Rewrite.simpleReverseProxy manager config req+    performAction _ (PAReverseProxy config) = return $ WPRApplication $ Rewrite.simpleReverseProxy manager config  redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response redirectApp RedirectConfig {..} req =

@@ -114,10 +114,9 @@         host <- (fmap fromString <$> o .:? "host") .!= "*"         port <- o .:? "port" .!= 443         return $! TLSConfig-            Warp.defaultSettings-                { Warp.settingsHost = host-                , Warp.settingsPort = port-                }+            ( Warp.setHost host+            $ Warp.setPort port+              Warp.defaultSettings)             WarpTLS.defaultTlsSettings                 { WarpTLS.certFile = encodeString cert                 , WarpTLS.keyFile = encodeString key

@@ -12,7 +12,7 @@ import qualified Keter.Types.V04 as V04 import Data.Yaml.FilePath import Data.Aeson (FromJSON (..), (.:), (.:?), Value (Object, String), withObject, (.!=))-import Control.Applicative ((<$>), (<*>), pure, (<|>))+import Control.Applicative ((<$>), (<*>), (<|>)) import qualified Data.Set as Set import qualified Filesystem.Path.CurrentOS as F import Data.Default@@ -20,7 +20,6 @@ import Data.Conduit.Network (HostPreference) import Data.Vector (Vector) import qualified Data.Vector as V-import Data.Monoid (mempty) import Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig) import Data.Maybe (fromMaybe, catMaybes) import qualified Network.Wai.Handler.Warp as Warp@@ -104,8 +103,8 @@       where         getSSL Nothing = V.empty         getSSL (Just (V04.TLSConfig s ts)) = V.singleton $ LPSecure-            (Warp.settingsHost s)-            (Warp.settingsPort s)+            (Warp.getHost s)+            (Warp.getPort s)             (F.decodeString $ WarpTLS.certFile ts)             (F.decodeString $ WarpTLS.keyFile ts) @@ -174,6 +173,7 @@     toJSON (StanzaReverseProxy x) = addStanzaType "reverse-proxy" x     toJSON (StanzaBackground x) = addStanzaType "background" x +addStanzaType :: ToJSON a => Value -> a -> Value addStanzaType t x =     case toJSON x of         Object o -> Object $ HashMap.insert "type" t o

@@ -9,6 +9,8 @@   where  import Control.Applicative+import Control.Exception (bracket)+import Data.Function (fix) import Data.Monoid ((<>))  import qualified Data.Set as Set@@ -18,14 +20,12 @@ import Data.Array ((!)) import Data.Aeson import Control.Monad (unless)-import Control.Monad.IO.Class (liftIO)  import qualified Data.ByteString as S import qualified Data.Text as T import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.CaseInsensitive as CI-import Control.Monad.Trans.Reader (runReaderT)  import Blaze.ByteString.Builder (fromByteString) @@ -39,10 +39,9 @@ import Data.Char (isDigit)  -- Reverse proxy apparatus-import Data.Conduit- import qualified Network.Wai as Wai import Network.HTTP.Client.Conduit+import qualified Network.HTTP.Client as NHC import Network.HTTP.Types  data RPEntry = RPEntry@@ -125,8 +124,8 @@       , requestHeaders = filterHeaders $ rewriteHeaders reqRuleMap (Wai.requestHeaders request)       , requestBody =           case Wai.requestBodyLength request of-            Wai.ChunkedBody   -> requestBodySourceChunked (Wai.requestBody request)-            Wai.KnownLength n -> requestBodySource (fromIntegral n) (Wai.requestBody request)+            Wai.ChunkedBody   -> RequestBodyStreamChunked ($ Wai.requestBody request)+            Wai.KnownLength n -> RequestBodyStream (fromIntegral n) ($ Wai.requestBody request)       , decompress = const False       , redirectCount = 0       , checkStatus = \_ _ _ -> Nothing@@ -137,17 +136,21 @@     reqRuleMap = mkRuleMap $ rewriteRequestRules rpConfig  simpleReverseProxy :: Manager -> ReverseProxyConfig -> Wai.Application-simpleReverseProxy mgr rpConfig request = Wai.responseSourceBracket-    (runReaderT (responseOpen proxiedRequest) mgr)+simpleReverseProxy mgr rpConfig request sendResponse = bracket+    (NHC.responseOpen proxiedRequest mgr)     responseClose-    $ \res -> return-        ( responseStatus res-        , rewriteHeaders respRuleMap $ responseHeaders res-        , mapOutput (Chunk . fromByteString) (responseBody res)-        )+    $ \res -> sendResponse $ Wai.responseStream+        (responseStatus res)+        (rewriteHeaders respRuleMap $ responseHeaders res)+        (sendBody $ responseBody res)   where     proxiedRequest = mkRequest rpConfig request     respRuleMap = mkRuleMap $ rewriteResponseRules rpConfig+    sendBody body send _flush = fix $ \loop -> do+        bs <- body+        unless (S.null bs) $ do+            () <- send $ fromByteString bs+            loop  data ReverseProxyConfig = ReverseProxyConfig     { reversedHost :: Text

@@ -1,11 +1,13 @@ Name:                keter-Version:             1.3.0+Version:             1.3.1 Synopsis:            Web application deployment manager, focusing on Haskell web frameworks Description:     Handles deployment of web apps, providing a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: <https://github.com/snoyberg/keter#readme>     .     Release history:     .+    [1.3.1] Upgrade to WAI 3.0+    .     [1.3.0] Upgrade to conduit 1.1     .     [1.0.1] Permit use of wildcard subdomains and exceptions to wildcards. Convert internal strings to use Data.Text in more places. (Although internationalized domain names are not supported unless entered in punycode in configuration files.)@@ -53,13 +55,14 @@                      , conduit                   >= 1.1                      , conduit-extra             >= 1.1                      , network-conduit-tls       >= 1.1-                     , http-reverse-proxy        >= 0.3.1         && < 0.4+                     , http-reverse-proxy        >= 0.4           && < 0.5                      , unix                      >= 2.5-                     , wai-app-static            >= 2.0           && < 2.1-                     , wai                       >= 2.1           && < 2.2+                     , wai-app-static            >= 3.0           && < 3.1+                     , wai                       >= 3.0           && < 3.1                      , http-types                      , regex-tdfa                >= 1.1                      , attoparsec                >= 0.10+                     , http-client                      , http-conduit              >= 2.1                      , case-insensitive                      , array

@@ -14,9 +14,13 @@     args <- getArgs     case args of         ["--version"] -> putStrLn $ "keter version: " ++ showVersion version+        ["--help"] -> printUsage         [dir] -> keter             (decodeString dir)             [\configDir -> Postgres.load def $ configDir </> "etc" </> "postgres.yaml"]-        _ -> do-            pn <- getProgName-            error $ "Usage: " ++ pn ++ " <root folder>"+        _ -> printUsage++printUsage :: IO ()+printUsage = do+    pn <- getProgName+    error $ "Usage: " ++ pn ++ " <config file>"