diff --git a/Keter/App.hs b/Keter/App.hs index 2804902..0923b5e 100644 --- a/Keter/App.hs +++ b/Keter/App.hs @@ -16,30 +16,17 @@ import Keter.TempFolder import Keter.Process import Keter.Types 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 qualified Filesystem as F import Data.Yaml import Control.Applicative ((<$>), (<*>), (<|>), pure) import qualified Network import Data.Maybe (fromMaybe, mapMaybe) -import Control.Exception (onException, throwIO, bracket) +import Control.Exception (throwIO) 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 (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 (setOwnerAndGroup, setFdOwnerAndGroup) -import Control.Monad (unless) import Data.Conduit.Process.Unix (ProcessTracker, RotatingLog) data AppConfig = AppConfig @@ -107,30 +94,20 @@ unpackBundle :: TempFolder -> Appname -> KIO (Either SomeException (FilePath, Config)) unpackBundle tf muid bundle appname = do - elbs <- readFileLBS bundle - case elbs of - Left e -> return $ Left e - Right lbs -> do - edir <- getFolder muid tf appname - case edir of - Left e -> return $ Left e - Right dir -> do - log $ UnpackingBundle bundle dir - let rest = do - unpackTar muid dir $ Tar.read $ decompress lbs - let configFP = dir F. "config" F. "keter.yaml" - mconfig <- decodeFile $ F.encodeString configFP - config <- - case mconfig of - Just config -> return config - Nothing -> throwIO InvalidConfigFile - return (dir, config - { configStaticHosts = Set.fromList - $ mapMaybe (fixStaticHost dir) - $ Set.toList - $ configStaticHosts config - }) - liftIO $ rest `onException` removeTree dir + log $ UnpackingBundle bundle + liftIO $ unpackTempTar muid tf bundle appname $ \dir -> do + let configFP = dir F. "config" F. "keter.yaml" + mconfig <- decodeFile $ F.encodeString configFP + config <- + case mconfig of + Just config -> return config + Nothing -> throwIO InvalidConfigFile + return (dir, config + { configStaticHosts = Set.fromList + $ mapMaybe (fixStaticHost dir) + $ Set.toList + $ configStaticHosts config + }) -- | Ensures that the given path does not escape the containing folder and sets -- the pathname based on config file location. @@ -143,50 +120,6 @@ fixStaticHost dir sh = fp0 = shRoot sh fp = F.collapse $ dir F. "config" F. fp0 --- | Create a directory tree, setting the uid and gid of all newly created --- folders. -createTreeUID :: UserID -> GroupID -> FilePath -> IO () -createTreeUID uid gid = - go - where - go fp = do - exists <- F.isDirectory fp - unless exists $ do - go $ F.parent fp - F.createDirectory False fp - setOwnerAndGroup (F.encodeString fp) uid gid - -unpackTar :: Maybe (UserID, GroupID) - -> FilePath -> Tar.Entries Tar.FormatError -> IO () -unpackTar muid 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 - case muid of - Nothing -> createTree $ F.directory fp - Just (uid, gid) -> createTreeUID uid gid $ F.directory fp - let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do - _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len) - return () - bracket - (do - fd <- createFile (F.encodeString 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)) -> ProcessTracker diff --git a/Keter/Main.hs b/Keter/Main.hs index 904861c..ffec5a5 100644 --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -106,7 +106,7 @@ keter (F.decodeString -> input) mkPlugins = do processTracker <- initProcessTracker portman <- runThrow $ PortMan.start configPortMan - tf <- runThrow $ TempFolder.setup $ configDir "temp" + tf <- runThrow $ liftIO $ TempFolder.setup $ configDir "temp" plugins <- runThrow $ loadPlugins $ map ($ configDir) mkPlugins mainlog <- runThrow $ liftIO $ LogFile.openRotatingLog (F.encodeString $ configDir "log" "keter") diff --git a/Keter/Prelude.hs b/Keter/Prelude.hs index bb67d75..2c91970 100644 --- a/Keter/Prelude.hs +++ b/Keter/Prelude.hs @@ -157,7 +157,7 @@ data LogMessage | ProcessDidNotStart F.FilePath | ExceptionThrown T.Text E.SomeException | RemovingPort P.Int - | UnpackingBundle F.FilePath F.FilePath + | UnpackingBundle F.FilePath | TerminatingApp T.Text | FinishedReloading T.Text | TerminatingOldProcess T.Text @@ -183,11 +183,10 @@ instance P.Show LogMessage where , P.show e ] show (RemovingPort p) = "Port in use, removing from port pool: " ++ P.show p - show (UnpackingBundle b dir) = P.concat + show (UnpackingBundle b) = P.concat [ "Unpacking bundle '" , F.encodeString b - , "' into folder: " - , F.encodeString dir + , "'" ] show (TerminatingApp t) = "Shutting down app: " ++ T.unpack t show (FinishedReloading t) = "App finished reloading: " ++ T.unpack t diff --git a/Keter/TempFolder.hs b/Keter/TempFolder.hs index 871d39a..9394fa6 100644 --- a/Keter/TempFolder.hs +++ b/Keter/TempFolder.hs @@ -1,41 +1,113 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | Handles allocation of temporary directories and unpacking of bundles into +-- them. Sets owner and group of all created files and directories as +-- necessary. module Keter.TempFolder ( TempFolder , setup - , getFolder + , unpackTempTar ) where -import Keter.Prelude -import Data.Word (Word) -import Keter.Types (Appname) -import qualified Data.IORef as I -import System.Posix.Files (setOwnerAndGroup) -import System.Posix.Types (UserID, GroupID) +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 Control.Exception (bracket, bracketOnError, throwIO) +import Control.Monad (unless) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import qualified Data.IORef as I +import Data.Word (Word) +import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F +import Foreign.Ptr (castPtr) +import Keter.Prelude +import Keter.Types (Appname) +import Prelude (IO) +import System.Posix.Files (setFdOwnerAndGroup, + setOwnerAndGroup) +import System.Posix.IO (FdOption (CloseOnExec), closeFd, + createFile, fdWriteBuf, setFdOption) +import System.Posix.Types (GroupID, UserID) data TempFolder = TempFolder - { tfRoot :: FilePath + { tfRoot :: FilePath , tfCounter :: IORef Word } -setup :: FilePath -> KIO (Either SomeException TempFolder) -setup fp = liftIO $ do +setup :: FilePath -> IO TempFolder +setup fp = do e <- isDirectory fp when e $ removeTree fp createTree fp c <- I.newIORef minBound return $ TempFolder fp c -getFolder :: Maybe (UserID, GroupID) -> TempFolder -> Appname -> KIO (Either SomeException FilePath) +getFolder :: Maybe (UserID, GroupID) -> TempFolder -> Appname -> IO FilePath getFolder muid TempFolder {..} appname = do - !i <- atomicModifyIORef tfCounter $ \i -> (succ i, i) + !i <- I.atomicModifyIORef tfCounter $ \i -> (succ i, i) let fp = tfRoot fromText (appname ++ "-" ++ show i) - liftIO $ do - createTree fp - case muid of - Nothing -> return () - Just (uid, gid) -> setOwnerAndGroup (F.encodeString fp) uid gid - return fp + createTree fp + case muid of + Nothing -> return () + Just (uid, gid) -> setOwnerAndGroup (F.encodeString fp) uid gid + return fp + +unpackTempTar :: Maybe (UserID, GroupID) + -> TempFolder + -> FilePath -- ^ bundle + -> Appname + -> (F.FilePath -> IO a) + -> IO a +unpackTempTar muid tf bundle appname withDir = do + lbs <- L.readFile $ F.encodeString bundle + bracketOnError (getFolder muid tf appname) removeTree $ \dir -> do + unpackTar muid dir $ Tar.read $ decompress lbs + withDir dir + +unpackTar :: Maybe (UserID, GroupID) + -> FilePath -> Tar.Entries Tar.FormatError -> IO () +unpackTar muid 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 + case muid of + Nothing -> createTree $ F.directory fp + Just (uid, gid) -> createTreeUID uid gid $ F.directory fp + let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do + _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len) + return () + bracket + (do + fd <- createFile (F.encodeString 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_ (write fd) (L.toChunks lbs)) + _ -> return () + +-- | Create a directory tree, setting the uid and gid of all newly created +-- folders. +createTreeUID :: UserID -> GroupID -> FilePath -> IO () +createTreeUID uid gid = + go + where + go fp = do + exists <- F.isDirectory fp + unless exists $ do + go $ F.parent fp + F.createDirectory False fp + setOwnerAndGroup (F.encodeString fp) uid gid