keter 0.3.6.1 → 0.4.0

raw patch · 8 files changed

+164/−90 lines, 8 filesdep +fsnotifydep +warpdep +warp-tlsdep −hinotifydep ~http-reverse-proxyPVP ok

version bump matches the API change (PVP)

Dependencies added: fsnotify, warp, warp-tls

Dependencies removed: hinotify

Dependency ranges changed: http-reverse-proxy

API changes (from Hackage documentation)

Files

• Keter/App.hs +4/−4
• Keter/Main.hs +68/−27
• Keter/Process.hs +2/−3
• Keter/Proxy.hs +44/−32
• Keter/ReverseProxy.hs +5/−2
• Keter/SSL.hs +30/−17
• Keter/TempFolder.hs +2/−2
• keter.cabal +9/−3

@@ -35,12 +35,12 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Conduit.List as CL-import System.Posix.IO.ByteString (fdWriteBuf, closeFd, FdOption (CloseOnExec), setFdOption, createFile)+import System.Posix.IO (fdWriteBuf, closeFd, FdOption (CloseOnExec), setFdOption, createFile) import Foreign.Ptr (castPtr) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Text.Encoding (encodeUtf8) import System.Posix.Types (UserID, GroupID)-import System.Posix.Files.ByteString (setOwnerAndGroup, setFdOwnerAndGroup)+import System.Posix.Files (setOwnerAndGroup, setFdOwnerAndGroup) import Control.Monad (unless)  data AppConfig = AppConfig@@ -155,7 +155,7 @@         unless exists $ do             go $ F.parent fp             F.createDirectory False fp-            setOwnerAndGroup (F.encode fp) uid gid+            setOwnerAndGroup (F.encodeString fp) uid gid  unpackTar :: Maybe (UserID, GroupID)           -> FilePath -> Tar.Entries Tar.FormatError -> IO ()@@ -178,7 +178,7 @@                         return ()                 bracket                     (do-                        fd <- createFile (F.encode fp) $ Tar.entryPermissions e+                        fd <- createFile (F.encodeString fp) $ Tar.entryPermissions e                         setFdOption fd CloseOnExec True                         case muid of                             Nothing -> return ()

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-}@@ -17,13 +18,15 @@ import qualified Keter.PortManager as PortMan import qualified Keter.Proxy as Proxy import qualified Keter.ReverseProxy as ReverseProxy+import System.Posix.Files (modificationTime, getFileStatus)+import System.Posix.Signals (sigHUP, installHandler, Handler (Catch)) -import Data.Conduit.Network (serverSettings, HostPreference)+import Data.Conduit.Network (HostPreference) import qualified Control.Concurrent.MVar as M import Control.Concurrent (forkIO) import qualified Data.Map as Map-import qualified System.INotify as I-import Control.Monad (forever, mzero)+import qualified System.FSNotify as FSN+import Control.Monad (forever, mzero, forM) import qualified Filesystem.Path.CurrentOS as F import qualified Filesystem as F import Control.Exception (throwIO, try)@@ -31,7 +34,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Time (getCurrentTime) import qualified Data.Text as T-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, catMaybes) import Data.Yaml (decodeFile, FromJSON (parseJSON), Value (Object), (.:), (.:?), (.!=)) import Control.Applicative ((<$>), (<*>)) import Data.String (fromString)@@ -40,6 +43,7 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Network.HTTP.Conduit as HTTP (newManager)+import qualified Network.Wai.Handler.Warp as Warp  data Config = Config     { configDir :: F.FilePath@@ -49,6 +53,7 @@     , configSsl :: Maybe Proxy.TLSConfigNoDir     , configSetuid :: Maybe Text     , configReverseProxy :: Set ReverseProxy.ReverseProxyConfig+    , configIpFromHeader :: Bool     }  instance Default Config where@@ -60,6 +65,7 @@         , configSsl = Nothing         , configSetuid = Nothing         , configReverseProxy = Set.empty+        , configIpFromHeader = False         }  instance FromJSON Config where@@ -71,6 +77,7 @@         <*> o .:? "ssl"         <*> o .:? "setuid"         <*> o .:? "reverse-proxy" .!= Set.empty+        <*> o .:? "ip-from-header" .!= False     parseJSON _ = mzero  keter :: P.FilePath -- ^ root directory or config file@@ -112,14 +119,23 @@             runKIOPrint $ LogFile.addChunk mainlog bs         runKIOPrint = runKIO P.print +    manager <- HTTP.newManager def     _ <- forkIO $ Proxy.reverseProxy-            (serverSettings configPort configHost)+            configIpFromHeader+            manager+            Warp.defaultSettings+                { Warp.settingsPort = configPort+                , Warp.settingsHost = configHost+                }             (runKIOPrint . PortMan.lookupPort portman)     case configSsl of         Nothing -> return ()-        Just ssl -> do+        Just (Proxy.setDir dir -> (s, ts)) -> do             _ <- forkIO $ Proxy.reverseProxySsl-                    (Proxy.setDir dir ssl)+                    configIpFromHeader+                    manager+                    ts+                    s                     (runKIOPrint . PortMan.lookupPort portman)             return () @@ -129,9 +145,11 @@             let appname = getAppname bundle             rest <- modifyMVar mappMap $ \appMap ->                 case Map.lookup appname appMap of-                    Just app -> do+                    Just (app, _time) -> do                         App.reload app-                        return (appMap, return ())+                        etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)+                        let time = either (P.const 0) id etime+                        return (Map.insert appname (app, time) appMap, return ())                     Nothing -> do                         mlogger <- do                             let dirout = dir </> "log" </> fromText ("app-" ++ appname)@@ -160,38 +178,61 @@                             appname                             bundle                             (removeApp appname)-                        let appMap' = Map.insert appname app appMap+                        etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)+                        let time = either (P.const 0) id etime+                        let appMap' = Map.insert appname (app, time) appMap                         return (appMap', rest)             rest         terminateApp appname = do+            -- FIXME why not remove it from the map?             appMap <- M.readMVar mappMap             case Map.lookup appname appMap of                 Nothing -> return ()-                Just app -> runKIO' $ App.terminate app+                Just (app, _) -> runKIO' $ App.terminate app      let incoming = dir </> "incoming"         isKeter fp = hasExtension fp "keter"-        isKeter' = isKeter . F.decodeString     createTree incoming-    bundles <- fmap (filter isKeter) $ listDirectory incoming-    runKIO' $ mapM_ addApp bundles+    bundles0 <- fmap (filter isKeter) $ listDirectory incoming+    runKIO' $ mapM_ addApp bundles0      let staticReverse r = do-          initMgr <- liftIO $ HTTP.newManager def-          case initMgr of-            Left e -> log $ ExceptionThrown "Failed to instantiate manager for reverse proxy." e-            Right mgr -> PortMan.addEntry portman (ReverseProxy.reversingHost r) $ PortMan.PEReverseProxy $ ReverseProxy.RPEntry r mgr +            PortMan.addEntry portman (ReverseProxy.reversingHost r)+                $ PortMan.PEReverseProxy+                $ ReverseProxy.RPEntry r manager     runKIO' $ mapM_ staticReverse (Set.toList configReverseProxy)     -    let events = [I.MoveIn, I.MoveOut, I.Delete, I.CloseWrite]-    i <- I.initINotify-    _ <- I.addWatch i events (toString incoming) $ \e -> do-        case e of-            I.Deleted _ fp -> when (isKeter' fp) $ terminateApp $ getAppname' fp-            I.MovedOut _ fp _ -> when (isKeter' fp) $ terminateApp $ getAppname' fp-            I.Closed _ (Just fp) _ -> when (isKeter' fp) $ runKIO' $ addApp $ incoming </> F.decodeString fp-            I.MovedIn _ fp _ -> when (isKeter' fp) $ runKIO' $ addApp $ incoming </> F.decodeString fp-            _ -> runKIO' $ log $ ReceivedInotifyEvent $ show e+    -- File system watching+    wm <- FSN.startManager+    FSN.watchDir wm incoming (P.const True) $ \e ->+        let e' =+                case e of+                    FSN.Removed fp _ -> Left fp+                    FSN.Added fp _ -> Right fp+                    FSN.Modified fp _ -> Right fp+         in case e' of+            Left fp -> when (isKeter fp) $ terminateApp $ getAppname fp+            Right fp -> when (isKeter fp) $ runKIO' $ addApp $ incoming </> fp++    -- Install HUP handler for cases when inotify cannot be used.+    _ <- flip (installHandler sigHUP) Nothing $ Catch $ do+        actions <- M.withMVar mappMap $ \appMap -> do+            bundles <- fmap (filter isKeter) $ F.listDirectory incoming+            newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do+                time <- modificationTime <$> getFileStatus (F.encodeString bundle)+                return (getAppname' $ F.encodeString bundle, (bundle, time))++            let apps = Set.toList $ Set.fromList (Map.keys newMap)+                        `Set.union` Set.fromList (Map.keys appMap)+            fmap catMaybes $ forM apps $ \appname -> return $+                case (Map.lookup appname appMap, Map.lookup appname newMap) of+                    (Nothing, Nothing) -> Nothing -- should never happen+                    (Just _, Nothing) -> Just $ terminateApp appname+                    (Nothing, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle+                    (Just (_, oldTime), Just (bundle, newTime))+                        | newTime /= oldTime -> Just $ runKIO' $ addApp bundle+                        | otherwise -> Nothing+        P.sequence_ actions      runKIO' $ forever $ threadDelay $ 60 * 1000 * 1000   where

@@ -14,7 +14,6 @@ import Data.Conduit.Process.Unix (forkExecuteFile, waitForProcess, killProcess, terminateProcess) import System.Process (ProcessHandle) import Prelude (error)-import Filesystem.Path.CurrentOS (encode) import Data.Text.Encoding (encodeUtf8) import Data.Conduit (($$)) import Control.Exception (onException)@@ -45,7 +44,7 @@                             _ -> return ()                         (pout, sout) <- mkLogPipe                         (perr, serr) <- mkLogPipe-                        let cmd0 = encode exec+                        let cmd0 = encodeUtf8 $ either id id $ toText exec                             args0 = map encodeUtf8 args                             (cmd, args') =                                 case msetuid of@@ -55,7 +54,7 @@                             cmd                             args'                             (Just $ map (encodeUtf8 *** encodeUtf8) env)-                            (Just $ encode dir)+                            (Just $ encodeUtf8 $ either id id $ toText dir)                             (Just $ return ())                             (Just sout)                             (Just serr)

@@ -5,52 +5,62 @@     , PortLookup     , reverseProxySsl     , setDir-    , TLSConfig     , TLSConfigNoDir     ) where  import Prelude hiding ((++), FilePath)-import Keter.Prelude ((++))-import Data.Conduit-import Data.Conduit.Network+import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Keter.PortManager (PortEntry (..)) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Keter.SSL-import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest), waiToRaw)+import Network.HTTP.ReverseProxy (waiProxyToSettings, wpsSetIpHeader, SetIpHeader (..), ProxyDest (ProxyDest), WaiProxyResponse (..)) import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) import qualified Network.Wai as Wai-import Network.HTTP.Types (status301)+import Network.HTTP.Types (status301, status200) import qualified Keter.ReverseProxy as ReverseProxy+import Network.HTTP.Conduit (Manager)+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as WarpTLS+import Blaze.ByteString.Builder (copyByteString)+import Data.Monoid (mappend)+import Data.Default  -- | Mapping from virtual hostname to port number. type PortLookup = ByteString -> IO (Maybe PortEntry) -reverseProxy :: ServerSettings IO -> PortLookup -> IO ()-reverseProxy settings = runTCPServer settings . withClient+reverseProxy :: Bool -> Manager -> Warp.Settings -> PortLookup -> IO ()+reverseProxy useHeader manager settings = Warp.runSettings settings . withClient useHeader manager -reverseProxySsl :: TLSConfig -> PortLookup -> IO ()-reverseProxySsl settings = runTCPServerTLS settings . withClient+reverseProxySsl :: Bool -> Manager -> WarpTLS.TLSSettings -> Warp.Settings -> PortLookup -> IO ()+reverseProxySsl useHeader manager tsettings settings = WarpTLS.runTLS tsettings settings . withClient useHeader manager -withClient :: PortLookup-           -> Application IO-withClient portLookup =-    rawProxyTo getDest+withClient :: Bool -- ^ use incoming request header for IP address+           -> Manager+           -> PortLookup+           -> Wai.Application+withClient useHeader manager portLookup =+    waiProxyToSettings getDest def+        { wpsSetIpHeader =+            if useHeader+                then SIHFromHeader+                else SIHFromSocket+        } manager   where-    getDest headers = do-        mport <- maybe (return Nothing) portLookup mhost+    getDest req = do+        mport <- liftIO $ maybe (return Nothing) portLookup mhost         case mport of-            Nothing -> return $ Left $ srcToApp $ toResponse mhost-            Just (PEPort port) -> return $ Right $ ProxyDest "127.0.0.1" port-            Just (PEStatic root) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root-            Just (PERedirect host) -> return $ Left $ waiToRaw $ redirectApp host-            Just (PEReverseProxy rpentry) -> return $ Left $ waiToRaw $ ReverseProxy.simpleReverseProxy rpentry+            Nothing -> return $ WPRResponse $ toResponse mhost+            Just (PEPort port) -> return $ WPRProxyDest $ ProxyDest "127.0.0.1" port+            Just (PEStatic root) -> fmap WPRResponse $ staticApp (defaultFileServerSettings root) req+            Just (PERedirect host) -> return $ WPRResponse $ redirectApp host req+            Just (PEReverseProxy rpentry) -> fmap WPRResponse $ ReverseProxy.simpleReverseProxy rpentry req       where-        mhost = lookup "host" headers+        mhost = lookup "host" $ Wai.requestHeaders req -redirectApp :: ByteString -> Wai.Application-redirectApp host req = return $ Wai.responseLBS+redirectApp :: ByteString -> Wai.Request -> Wai.Response+redirectApp host req = Wai.responseLBS     status301     [("Location", dest)]     (L.fromChunks [dest])@@ -62,11 +72,13 @@         , Wai.rawQueryString req         ] -srcToApp :: Monad m => Source m ByteString -> Application m-srcToApp src appdata = src $$ appSink appdata--toResponse :: Monad m => Maybe ByteString -> Source m ByteString-toResponse Nothing =-    yield "HTTP/1.1 200 OK\r\nContent-Type: text/html; charset=utf-8\r\n\r\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You did not provide a virtual hostname for this request.</p></body></html>"-toResponse (Just host) =-    yield $ "HTTP/1.1 200 OK\r\nContent-Type: text/html; charset=utf-8\r\n\r\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>" ++ host ++ "</code>, is not recognized.</p></body></html>"+toResponse :: Maybe ByteString -> Wai.Response+toResponse mhost = Wai.ResponseBuilder+    status200+    [("Content-Type", "text/html; charset=utf-8")]+    $ case mhost of+        Nothing -> copyByteString "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You did not provide a virtual hostname for this request.</p></body></html>"+        Just host ->+            copyByteString "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>"+            `mappend` copyByteString host+            `mappend` copyByteString "</code>, is not recognized.</p></body></html>"

@@ -46,6 +46,7 @@     , reversedPort :: Int     , reversingHost :: Text     , reverseUseSSL :: Bool+    , reverseTimeout :: Maybe Int     , rewriteResponseRules :: Set RewriteRule     , rewriteRequestRules :: Set RewriteRule     } deriving (Eq, Ord)@@ -55,7 +56,8 @@         <$> o .: "reversed-host"         <*> o .: "reversed-port"         <*> o .: "reversing-host"-        <*> o .: "ssl" .!= False+        <*> o .:? "ssl" .!= False+        <*> o .:? "timeout" .!= Nothing         <*> o .:? "rewrite-response" .!= Set.empty         <*> o .:? "rewrite-request" .!= Set.empty     parseJSON _ = fail "Wanted an object"@@ -66,6 +68,7 @@         , reversedPort = 80         , reversingHost = ""         , reverseUseSSL = False+        , reverseTimeout = Nothing         , rewriteResponseRules = Set.empty         , rewriteRequestRules = Set.empty         }@@ -165,7 +168,7 @@       , decompress = const False       , redirectCount = 0       , checkStatus = \_ _ _ -> Nothing-      --, responseTimeout = 5000 -- current default (as of 2013-03-18)+      , responseTimeout = reverseTimeout rpConfig       , cookieJar = Nothing       }   where

@@ -1,31 +1,44 @@ {-# LANGUAGE OverloadedStrings #-} module Keter.SSL-    ( TLSConfig (..)-    , TLSConfigNoDir+    ( TLSConfigNoDir     , setDir-    , runTCPServerTLS     ) where  import Prelude hiding (FilePath) import Data.Yaml (FromJSON (parseJSON), (.:), (.:?), (.!=), Value (Object))-import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>)) import Control.Monad (mzero) import Data.String (fromString)-import Filesystem.Path.CurrentOS ((</>), FilePath)-import Data.Conduit.Network.TLS+import System.FilePath ((</>))+import Filesystem.Path.CurrentOS (FilePath, encodeString)+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as WarpTLS -setDir :: FilePath -> TLSConfigNoDir -> TLSConfig-setDir dir (TLSConfigNoDir tls) = tls-    { tlsCertificate = dir </> tlsCertificate tls-    , tlsKey = dir </> tlsKey tls-    }+setDir :: FilePath -> TLSConfigNoDir -> (Warp.Settings, WarpTLS.TLSSettings)+setDir dir' (TLSConfigNoDir s ts') =+    (s, ts)+  where+    dir = encodeString dir'+    ts = ts'+        { WarpTLS.certFile = dir </> WarpTLS.certFile ts'+        , WarpTLS.keyFile = dir </> WarpTLS.keyFile ts'+        } -newtype TLSConfigNoDir = TLSConfigNoDir TLSConfig+data TLSConfigNoDir = TLSConfigNoDir !Warp.Settings !WarpTLS.TLSSettings  instance FromJSON TLSConfigNoDir where-    parseJSON (Object o) = fmap TLSConfigNoDir $ tlsConfig-        <$> (fmap fromString <$> o .:? "host") .!= "*"-        <*> o .:? "port" .!= 443-        <*> (fromString <$> o .: "certificate")-        <*> (fromString <$> o .: "key")+    parseJSON (Object o) = do+        cert <- o .: "certificate"+        key <- o .: "key"+        host <- (fmap fromString <$> o .:? "host") .!= "*"+        port <- o .:? "port" .!= 443+        return $ TLSConfigNoDir+            Warp.defaultSettings+                { Warp.settingsHost = host+                , Warp.settingsPort = port+                }+            WarpTLS.defaultTlsSettings+                { WarpTLS.certFile = cert+                , WarpTLS.keyFile = key+                }     parseJSON _ = mzero

@@ -12,7 +12,7 @@ import Data.Word (Word) import Keter.Postgres (Appname) import qualified Data.IORef as I-import System.Posix.Files.ByteString (setOwnerAndGroup)+import System.Posix.Files (setOwnerAndGroup) import System.Posix.Types (UserID, GroupID) import qualified Filesystem.Path.CurrentOS as F @@ -37,5 +37,5 @@         createTree fp         case muid of             Nothing -> return ()-            Just (uid, gid) -> setOwnerAndGroup (F.encode fp) uid gid+            Just (uid, gid) -> setOwnerAndGroup (F.encodeString fp) uid gid         return fp

@@ -1,11 +1,15 @@ Name:                keter-Version:             0.3.6.1+Version:             0.4.0 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:     .+    [0.4.0] Switch to fsnotify to get cross-platform support. No longer using raw proxies, but instead WAI proxies.+    .+    [0.3.7] Sending a HUP signal reloads the list of deployed apps. This is useful for circumstances where inotify does not work correctly, such as on file systems which do not support it.+    .     [0.3.5] You can now create Keter bundles without any applications. These can contain static hosts and redirects. Homepage:            http://www.yesodweb.com/ License:             MIT@@ -35,13 +39,13 @@                      , blaze-builder             >= 0.3           && < 0.4                      , yaml                      >= 0.7           && < 0.9                      , unix-compat               >= 0.3           && < 0.5-                     , hinotify                  >= 0.3           && < 0.4+                     , fsnotify                  >= 0.0.11                      , system-filepath           >= 0.4           && < 0.5                      , system-fileio             >= 0.3           && < 0.4                      , conduit                   >= 0.5                      , network-conduit           >= 0.6                      , network-conduit-tls       >= 1.0.0.2-                     , http-reverse-proxy        >= 0.1.0.2       && < 0.2+                     , http-reverse-proxy        >= 0.2           && < 0.3                      , unix-process-conduit      >= 0.2           && < 0.3                      , unix                      >= 2.5           && < 2.7                      , wai-app-static            >= 1.3           && < 1.4@@ -53,6 +57,8 @@                      , case-insensitive                      , array                      , mtl+                     , warp+                     , warp-tls   Exposed-Modules:     Keter.Process                        Keter.ProcessTracker                        Keter.Postgres