keter 0.3.2 → 0.3.3
raw patch · 4 files changed
+53/−14 lines, 4 files
Files
- Keter/App.hs +20/−8
- Keter/Main.hs +20/−1
- Keter/Process.hs +12/−4
- keter.cabal +1/−1
Keter/App.hs view
@@ -10,7 +10,7 @@ , Keter.App.terminate ) where -import Prelude (IO, Eq, Ord)+import Prelude (IO, Eq, Ord, fst, snd) import Keter.Prelude import Keter.TempFolder import Keter.Postgres@@ -37,6 +37,8 @@ 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) data Config = Config { configExec :: F.FilePath@@ -89,10 +91,11 @@ newtype App = App (Command -> KIO ()) unpackBundle :: TempFolder+ -> Maybe (UserID, GroupID) -> F.FilePath -> Appname -> KIO (Either SomeException (FilePath, Config))-unpackBundle tf bundle appname = do+unpackBundle tf muid bundle appname = do elbs <- readFileLBS bundle case elbs of Left e -> return $ Left e@@ -103,7 +106,7 @@ Right dir -> do log $ UnpackingBundle bundle dir let rest = do- unpackTar dir $ Tar.read $ decompress lbs+ unpackTar muid dir $ Tar.read $ decompress lbs let configFP = dir F.</> "config" F.</> "keter.yaml" mconfig <- decodeFile $ F.encodeString configFP config <-@@ -129,8 +132,9 @@ fp0 = shRoot sh fp = F.collapse $ dir F.</> "config" F.</> fp0 -unpackTar :: FilePath -> Tar.Entries Tar.FormatError -> IO ()-unpackTar dir =+unpackTar :: Maybe (UserID, GroupID)+ -> FilePath -> Tar.Entries Tar.FormatError -> IO ()+unpackTar muid dir = loop . Tar.checkSecurity where loop Tar.Done = return ()@@ -142,6 +146,9 @@ case Tar.entryContent e of Tar.NormalFile lbs _ -> do createTree $ F.directory fp+ case muid of+ Nothing -> return ()+ Just (uid, gid) -> setOwnerAndGroup (F.encode $ F.directory fp) uid gid let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len) return ()@@ -149,12 +156,16 @@ (do fd <- createFile (F.encode fp) $ Tar.entryPermissions e setFdOption fd CloseOnExec True+ case muid of+ Nothing -> return ()+ Just (uid, gid) -> setFdOwnerAndGroup fd uid gid return fd) closeFd (\fd -> mapM_ yield (L.toChunks lbs) $$ CL.mapM_ (write fd)) _ -> return () start :: TempFolder+ -> Maybe (Text, (UserID, GroupID)) -> PortManager -> Postgres -> Logger@@ -162,7 +173,7 @@ -> F.FilePath -- ^ app bundle -> KIO () -- ^ action to perform to remove this App from list of actives -> KIO (App, KIO ())-start tf portman postgres logger appname bundle removeFromList = do+start tf muid portman postgres logger appname bundle removeFromList = do chan <- newChan return (App $ writeChan chan, rest chan) where@@ -191,6 +202,7 @@ : ("APPROOT", (if configSsl config then "https://" else "http://") ++ configHost config) : otherEnv run+ (fst <$> muid) ("config" </> configExec config) dir (configArgs config)@@ -198,7 +210,7 @@ logger rest chan = forkKIO $ do- mres <- unpackBundle tf bundle appname+ mres <- unpackBundle tf (snd <$> muid) bundle appname case mres of Left e -> do $logEx e@@ -237,7 +249,7 @@ terminateOld detach logger Reload -> do- mres <- unpackBundle tf bundle appname+ mres <- unpackBundle tf (snd <$> muid) bundle appname case mres of Left e -> do log $ InvalidBundle bundle e
Keter/Main.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} module Keter.Main ( keter ) where@@ -23,7 +24,7 @@ import Control.Monad (forever, mzero) import qualified Filesystem.Path.CurrentOS as F import qualified Filesystem as F-import Control.Exception (throwIO)+import Control.Exception (throwIO, try) import qualified Prelude as P import Data.Text.Encoding (encodeUtf8) import Data.Time (getCurrentTime)@@ -32,6 +33,8 @@ import Data.Yaml (decodeFile, FromJSON (parseJSON), Value (Object), (.:), (.:?), (.!=)) import Control.Applicative ((<$>), (<*>)) import Data.String (fromString)+import System.Posix.User (userID, userGroupID, getUserEntryForName, getUserEntryForID, userName)+import qualified Data.Text.Read data Config = Config { configDir :: F.FilePath@@ -39,6 +42,7 @@ , configHost :: HostPreference , configPort :: PortMan.Port , configSsl :: Maybe Proxy.TLSConfigNoDir+ , configSetuid :: Maybe Text } instance Default Config where def = Config@@ -47,6 +51,7 @@ , configHost = "*" , configPort = 80 , configSsl = Nothing+ , configSetuid = Nothing } instance FromJSON Config where@@ -56,6 +61,7 @@ <*> (fmap fromString <$> o .:? "host") .!= configHost def <*> o .:? "port" .!= configPort def <*> o .:? "ssl"+ <*> o .:? "setuid" parseJSON _ = mzero keter :: P.FilePath -- ^ root directory or config file@@ -68,6 +74,18 @@ else return def { configDir = input } let dir = F.directory input F.</> configDir + muid <-+ case configSetuid of+ Nothing -> return Nothing+ Just t -> do+ x <- try $+ case Data.Text.Read.decimal t of+ Right (i, "") -> getUserEntryForID i+ _ -> getUserEntryForName $ T.unpack t+ case x of+ Left (_ :: SomeException) -> P.error $ T.unpack $ "Invalid user ID: " ++ t+ Right ue -> return $ Just (T.pack $ userName ue, (userID ue, userGroupID ue))+ portman <- runThrow $ PortMan.start configPortMan tf <- runThrow $ TempFolder.setup $ dir </> "temp" postgres <- runThrow $ Postgres.load def $ dir </> "etc" </> "postgres.yaml"@@ -124,6 +142,7 @@ let logger = fromMaybe Logger.dummy mlogger (app, rest) <- App.start tf+ muid portman postgres logger
Keter/Process.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-} module Keter.Process ( run , terminate@@ -20,13 +21,14 @@ data Status = NeedsRestart | NoRestart | Running ProcessHandle -- | Run the given command, restarting if the process dies.-run :: FilePath -- ^ executable+run :: Maybe Text -- ^ setuid+ -> FilePath -- ^ executable -> FilePath -- ^ working directory -> [String] -- ^ command line parameter -> [(String, String)] -- ^ environment -> Logger -> KIO Process-run exec dir args env logger = do+run msetuid exec dir args env logger = do mstatus <- newMVar NeedsRestart let loop mlast = do next <- modifyMVar mstatus $ \status ->@@ -41,9 +43,15 @@ _ -> return () (pout, sout) <- mkLogPipe (perr, serr) <- mkLogPipe+ let cmd0 = encode exec+ args0 = map encodeUtf8 args+ (cmd, args') =+ case msetuid of+ Nothing -> (cmd0, args0)+ Just setuid -> ("sudo", "-E" : "-u" : encodeUtf8 setuid : "--" : cmd0 : args0) res <- liftIO $ forkExecuteFile- (encode exec)- (map encodeUtf8 args)+ cmd+ args' (Just $ map (encodeUtf8 *** encodeUtf8) env) (Just $ encode dir) (Just $ return ())
keter.cabal view
@@ -1,5 +1,5 @@ Name: keter-Version: 0.3.2+Version: 0.3.3 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/