diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -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 diff --git a/Keter/PortManager.hs b/Keter/PortManager.hs --- a/Keter/PortManager.hs +++ b/Keter/PortManager.hs @@ -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 diff --git a/Keter/Process.hs b/Keter/Process.hs --- a/Keter/Process.hs +++ b/Keter/Process.hs @@ -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 () diff --git a/Keter/Proxy.hs b/Keter/Proxy.hs --- a/Keter/Proxy.hs +++ b/Keter/Proxy.hs @@ -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 diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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: 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