diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -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 diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -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 diff --git a/Keter/Process.hs b/Keter/Process.hs --- a/Keter/Process.hs +++ b/Keter/Process.hs @@ -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 ()) diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -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: Homepage: http://www.yesodweb.com/