keter 0.3.0.1 → 0.3.1
raw patch · 5 files changed
+108/−30 lines, 5 filesdep +wai-app-staticdep ~http-reverse-proxydep ~unix-process-conduit
Dependencies added: wai-app-static
Dependency ranges changed: http-reverse-proxy, unix-process-conduit
Files
- Keter/App.hs +81/−11
- Keter/PortManager.hs +5/−5
- Keter/Process.hs +12/−7
- Keter/Proxy.hs +6/−4
- keter.cabal +4/−3
Keter/App.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-} module Keter.App ( App , start@@ -9,6 +10,7 @@ , Keter.App.terminate ) where +import Prelude (IO, Eq, Ord) import Keter.Prelude import Keter.TempFolder import Keter.Postgres@@ -16,15 +18,24 @@ import Keter.Logger (Logger, detach) import Keter.PortManager hiding (start) import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Check as Tar+import qualified Codec.Archive.Tar.Entry as Tar import Codec.Compression.GZip (decompress) import qualified Filesystem.Path.CurrentOS as F import Data.Yaml import Control.Applicative ((<$>), (<*>))-import System.PosixCompat.Files import qualified Network-import Data.Maybe (fromMaybe)-import Control.Exception (onException)+import Data.Maybe (fromMaybe, mapMaybe)+import Control.Exception (onException, throwIO, bracket) import System.IO (hClose)+import qualified Data.ByteString.Lazy as L+import Data.Conduit (($$), yield)+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 Foreign.Ptr (castPtr)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen) data Config = Config { configExec :: F.FilePath@@ -32,6 +43,8 @@ , configHost :: String , configPostgres :: Bool , configSsl :: Bool+ , configExtraHosts :: Set String+ , configStaticHosts :: Set StaticHost } instance FromJSON Config where@@ -41,8 +54,22 @@ <*> o .: "host" <*> o .:? "postgres" .!= False <*> o .:? "ssl" .!= False+ <*> o .:? "extra-hosts" .!= Set.empty+ <*> o .:? "static-hosts" .!= Set.empty parseJSON _ = fail "Wanted an object" +data StaticHost = StaticHost+ { shHost :: String+ , shRoot :: FilePath+ }+ deriving (Eq, Ord)++instance FromJSON StaticHost where+ parseJSON (Object o) = StaticHost+ <$> o .: "host"+ <*> (F.fromText <$> o .: "root")+ parseJSON _ = fail "Wanted an object"+ data Command = Reload | Terminate newtype App = App (Command -> KIO ()) @@ -61,12 +88,53 @@ Right dir -> do log $ UnpackingBundle bundle dir let rest = do- Tar.unpack (F.encodeString dir) $ Tar.read $ decompress lbs+ unpackTar dir $ Tar.read $ decompress lbs let configFP = dir F.</> "config" F.</> "keter.yaml" Just config <- decodeFile $ F.encodeString configFP- return (dir, config)+ return (dir, config+ { configStaticHosts = Set.fromList+ $ mapMaybe (fixStaticHost dir)+ $ Set.toList+ $ configStaticHosts config+ }) liftIO $ rest `onException` removeTree dir +-- | Ensures that the given path does not escape the containing folder and sets+-- the pathname based on config file location.+fixStaticHost :: FilePath -> StaticHost -> Maybe StaticHost+fixStaticHost dir sh =+ case (F.stripPrefix (F.collapse dir F.</> "") fp, F.relative fp0) of+ (Just _, True) -> Just sh { shRoot = fp }+ _ -> Nothing+ where+ fp0 = shRoot sh+ fp = F.collapse $ dir F.</> "config" F.</> fp0++unpackTar :: FilePath -> Tar.Entries Tar.FormatError -> IO ()+unpackTar dir =+ loop . Tar.checkSecurity+ where+ loop Tar.Done = return ()+ loop (Tar.Fail e) = either throwIO throwIO e+ loop (Tar.Next e es) = go e >> loop es++ go e = do+ let fp = dir </> decodeString (Tar.entryPath e)+ case Tar.entryContent e of+ Tar.NormalFile lbs _ -> do+ createTree $ F.directory fp+ let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do+ _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len)+ return ()+ bracket+ (do+ fd <- createFile (F.encode fp) $ Tar.entryPermissions e+ setFdOption fd CloseOnExec True+ return fd)+ closeFd+ (\fd -> mapM_ yield (L.toChunks lbs) $$ CL.mapM_ (write fd))+ _ -> return ()+ start :: TempFolder -> PortManager -> Postgres@@ -80,10 +148,6 @@ return (App $ writeChan chan, rest chan) where runApp port dir config = do- res1 <- liftIO $ setFileMode (toString $ dir </> "config" </> configExec config) ownerExecuteMode- case res1 of- Left e -> $logEx e- Right () -> return () otherEnv <- do mdbi <- if configPostgres config@@ -131,7 +195,9 @@ b <- testApp port if b then do- addEntry portman (configHost config) port+ addEntry portman (configHost config) $ Left port+ mapM_ (flip (addEntry portman) $ Left port) $ Set.toList $ configExtraHosts config+ mapM_ (\StaticHost{..} -> addEntry portman shHost (Right shRoot)) $ Set.toList $ configStaticHosts config loop chan dir process port config else do removeFromList@@ -144,6 +210,8 @@ Terminate -> do removeFromList removeEntry portman $ configHost configOld+ mapM_ (removeEntry portman) $ Set.toList $ configExtraHosts configOld+ mapM_ (removeEntry portman) $ map shHost $ Set.toList $ configStaticHosts configOld log $ TerminatingApp appname terminateOld detach logger@@ -162,7 +230,9 @@ b <- testApp port if b then do- addEntry portman (configHost config) port+ addEntry portman (configHost config) $ Left port+ mapM_ (flip (addEntry portman) $ Left port) $ Set.toList $ configExtraHosts config+ mapM_ (\StaticHost{..} -> addEntry portman shHost (Right shRoot)) $ Set.toList $ configStaticHosts config when (configHost config /= configHost configOld) $ removeEntry portman $ configHost configOld log $ FinishedReloading appname
Keter/PortManager.hs view
@@ -42,9 +42,9 @@ data Command = GetPort (Either SomeException Port -> KIO ()) | ReleasePort Port - | AddEntry Host Port + | AddEntry Host (Either Port FilePath) | RemoveEntry Host - | LookupPort S.ByteString (Maybe Port -> KIO ()) + | LookupPort S.ByteString (Maybe (Either Port FilePath) -> KIO ()) | HostList ([S.ByteString] -> KIO ()) -- | An abstract type which can accept commands and sends them to a background @@ -122,7 +122,7 @@ data NState = NState { nsAvail :: [Port] , nsRecycled :: [Port] - , nsEntries :: Map.Map S.ByteString Port + , nsEntries :: Map.Map S.ByteString (Either Port FilePath) } -- | Gets an unassigned port number. @@ -143,14 +143,14 @@ -- nginx. Will overwrite any existing configuration for the given host. The -- second point is important: it is how we achieve zero downtime transitions -- between an old and new version of an app. -addEntry :: PortManager -> Host -> Port -> KIO () +addEntry :: PortManager -> Host -> Either Port FilePath -> KIO () addEntry (PortManager f) h p = f $ AddEntry h p -- | Remove an entry from the configuration and reload nginx. removeEntry :: PortManager -> Host -> KIO () removeEntry (PortManager f) h = f $ RemoveEntry h -lookupPort :: PortManager -> S.ByteString -> KIO (Maybe Port) +lookupPort :: PortManager -> S.ByteString -> KIO (Maybe (Either Port FilePath)) lookupPort (PortManager f) h = do x <- newEmptyMVar f $ LookupPort h $ \p -> putMVar x p
Keter/Process.hs view
@@ -9,14 +9,15 @@ import Keter.Prelude import Keter.Logger (Logger, attach, LogPipes (..), mkLogPipe) import Data.Time (diffUTCTime)-import Data.Conduit.Process.Unix (forkExecuteFile, waitForProcess, killProcess)-import System.Posix.Types (ProcessID)+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) -data Status = NeedsRestart | NoRestart | Running ProcessID+data Status = NeedsRestart | NoRestart | Running ProcessHandle -- | Run the given command, restarting if the process dies. run :: FilePath -- ^ executable@@ -42,7 +43,6 @@ (perr, serr) <- mkLogPipe res <- liftIO $ forkExecuteFile (encode exec)- False (map encodeUtf8 args) (Just $ map (encodeUtf8 *** encodeUtf8) env) (Just $ encode dir)@@ -51,14 +51,16 @@ (Just serr) case res of Left e -> do+ $logEx e void $ liftIO $ return () $$ sout void $ liftIO $ return () $$ serr- $logEx e return (NeedsRestart, return ()) Right pid -> do attach logger $ LogPipes pout perr log $ ProcessCreated exec- return (Running pid, liftIO (waitForProcess pid) >> loop (Just now))+ return (Running pid, do+ liftIO $ waitForProcess pid `onException` killProcess pid+ loop (Just now)) next forkKIO $ loop Nothing return $ Process mstatus@@ -71,5 +73,8 @@ terminate (Process mstatus) = do status <- swapMVar mstatus NoRestart case status of- Running pid -> void $ liftIO $ killProcess pid+ Running pid -> do+ void $ liftIO $ terminateProcess pid+ threadDelay 1000000+ void $ liftIO $ killProcess pid _ -> return ()
Keter/Proxy.hs view
@@ -10,7 +10,7 @@ , TLSConfigNoDir ) where -import Keter.Prelude ((++))+import Keter.Prelude ((++), FilePath) import Prelude hiding ((++), FilePath) import Data.Conduit import Data.Conduit.Network@@ -20,11 +20,12 @@ import Blaze.ByteString.Builder (fromByteString, toLazyByteString) import Data.Monoid (mconcat) import Keter.SSL-import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest))+import Network.HTTP.ReverseProxy (rawProxyTo, ProxyDest (ProxyDest), waiToRaw) import Control.Applicative ((<$>))+import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) -- | Mapping from virtual hostname to port number.-type PortLookup = ByteString -> IO (Maybe Port)+type PortLookup = ByteString -> IO (Maybe (Either Port FilePath)) type HostList = IO [ByteString] @@ -44,7 +45,8 @@ mport <- maybe (return Nothing) portLookup $ lookup "host" headers case mport of Nothing -> Left . srcToApp . toResponse <$> hostList- Just port -> return $ Right $ ProxyDest "127.0.0.1" port+ Just (Left port) -> return $ Right $ ProxyDest "127.0.0.1" port+ Just (Right root) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root srcToApp :: Monad m => Source m ByteString -> Application m srcToApp src appdata = src $$ appSink appdata
keter.cabal view
@@ -1,5 +1,5 @@ Name: keter-Version: 0.3.0.1+Version: 0.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> Homepage: http://www.yesodweb.com/@@ -36,9 +36,10 @@ , conduit >= 0.5 && < 0.6 , network-conduit >= 0.6 && < 0.7 , network-conduit-tls >= 0.6 && < 0.7- , http-reverse-proxy >= 0.1 && < 0.2- , unix-process-conduit >= 0.1 && < 0.2+ , http-reverse-proxy >= 0.1.0.2 && < 0.2+ , unix-process-conduit >= 0.2 && < 0.3 , unix >= 2.5 && < 2.7+ , wai-app-static >= 1.3 && < 1.4 Exposed-Modules: Keter.Process Keter.Postgres Keter.TempFolder