diff --git a/Data/Conduit/LogFile.hs b/Data/Conduit/LogFile.hs --- a/Data/Conduit/LogFile.hs +++ b/Data/Conduit/LogFile.hs @@ -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' diff --git a/Data/Conduit/Process/Unix.hs b/Data/Conduit/Process/Unix.hs --- a/Data/Conduit/Process/Unix.hs +++ b/Data/Conduit/Process/Unix.hs @@ -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) diff --git a/Keter/HostManager.hs b/Keter/HostManager.hs --- a/Keter/HostManager.hs +++ b/Keter/HostManager.hs @@ -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 diff --git a/Keter/LabelMap.hs b/Keter/LabelMap.hs --- a/Keter/LabelMap.hs +++ b/Keter/LabelMap.hs @@ -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 diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -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 diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -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 = diff --git a/Keter/Types/V04.hs b/Keter/Types/V04.hs --- a/Keter/Types/V04.hs +++ b/Keter/Types/V04.hs @@ -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 diff --git a/Keter/Types/V10.hs b/Keter/Types/V10.hs --- a/Keter/Types/V10.hs +++ b/Keter/Types/V10.hs @@ -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 diff --git a/Network/HTTP/ReverseProxy/Rewrite.hs b/Network/HTTP/ReverseProxy/Rewrite.hs --- a/Network/HTTP/ReverseProxy/Rewrite.hs +++ b/Network/HTTP/ReverseProxy/Rewrite.hs @@ -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 diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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: . 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 diff --git a/main/keter.hs b/main/keter.hs --- a/main/keter.hs +++ b/main/keter.hs @@ -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 ++ " " + _ -> printUsage + +printUsage :: IO () +printUsage = do + pn <- getProgName + error $ "Usage: " ++ pn ++ " "