encapsule 0.4.1 → 0.5
raw patch · 15 files changed
+1721/−782 lines, 15 filesdep +hspecdep +pretty-terminaldep +tasty
Dependencies added: hspec, pretty-terminal, tasty, tasty-bench
Files
- ChangeLog.md +25/−0
- README.md +80/−40
- bench/Bench.hs +72/−0
- encapsule.cabal +40/−1
- src/Backup.hs +91/−0
- src/Config.hs +94/−0
- src/Enter.hs +94/−0
- src/Error.hs +8/−0
- src/Expand.hs +57/−0
- src/Main.hs +56/−719
- src/Run.hs +596/−0
- src/Script.hs +76/−22
- src/ShellQuote.hs +12/−0
- test/EncapsuleTest.hs +149/−0
- test/Spec.hs +271/−0
ChangeLog.md view
@@ -1,5 +1,30 @@ # encapsule releases +## 0.5 (2026-09-14)+- `run`,`create`: now always act on a container image+- `run`,`create`: set `--workdir` only when the path exists at start+- `run`,`create`: `--passwd-entry` so keep-id does not set home to `/`+- `run`,`create`: fall back to `sudo -u` when `runuser` is missing+- `run --debug` now also outputs podman command like `--dryrun`+- `enter`: use `$HOME` as workdir when the container workdir is `/`+- `enter`: use `podman exec --user` instead of `runuser`+- `commit`: add `--name` to set the encapsule image name+- `commit`: replaces `refresh` with simpler logic+- `rmi`: fix --dryrun (0.4.1 logic regression)+- `backup` now excludes local git ignored files+- bind-mount `/etc/localtime`+- export `LANG=C.UTF-8` (override with `-e LANG=C` or another locale)+- check first if runuser and sudo are in the container image+- use image passwd user with the same UID as the host (e.g. support ubuntu)+- container `$HOME` follows the image passwd home when it is a real directory; `--home` mounts there+- simplify setup script: no longer installs sudo and util-linux+- now also setup home if no runuser+- `--no-sudo` no longer attempts to remove sudo+- add `--user` option to override the container user+- dryrun/debug colors podman flag names in cyan (honors `NO_COLOR`)+- add hspec tests (`cabal test`; needs podman and local images)+- add tasty-bench suite (`cabal bench`; needs podman and a local image)+ ## 0.4.1 (2026-08-07) - require volume host paths to exist - drop `-P` for `--path` and add `-H` for `--home`
README.md view
@@ -11,22 +11,23 @@ You can explicitly choose what dir(s) or file(s) to mount or features to enable, selecting user-configured "capabilities" that the encapsule container can access. -```-encapsule COMMAND TOOLBOX [options] [CMD...]-```--if TOOLBOX is a container it will be committed (saved) to an "encapsule" container image from the named toolbox container using buildah.-(Though toolbox containers are recommended, as such it doesn't have to be a toolbox container.)-Your original toolbox container is left untouched: its system configuration and fs are just used as the base fs for the encapsule image.+Most encapsule subcommands act on an image.+- If you wish to use an existing toolbox container as a starting point you can `commit` it to an "encapsule" container image.+ - Note your original toolbox container is left untouched: its system configuration and fs are just used as the base fs for the encapsule image (though its original bind mounts including $HOME will be not be included by default).+- Alternatively you can roll your own image or run a vanilla image like `fedora` (`fedora:latest`), `fedora-toolbox:44` or `ubuntu:latest`, etc.+ - However toolbox images or containers are recommended because they include `sudo` and `runuser`, but as such it doesn't have to be a toolbox container.+ - For example since the fedora base container does not include runuser it runs as `--user root` by default (since as of 0.5 util-linux is no longer+installed by default into encapsule containers: this may be addressed in future). Encapsule images and containers are prefixed by `encapsule-`.+There is no need to use this prefix normally - it is implicit. ## Usage `$ encapsule --version` ```-0.4.1+0.5 ``` `$ encapsule --help`@@ -50,10 +51,9 @@ rmi Remove an encapsule image stop Stop an encapsule container backup Create a tarball backup of a directory+ commit Commit an encapsule image from a container create Create an encapsule container enter Connect to a encapsule container- refresh Re-commit an encapsule image from a (toolbox)- container run Run a temporary encapsule container ``` @@ -68,14 +68,14 @@ `$ encapsule run --help` ```-Usage: encapsule run TOOLBOX [-v|--volume HOST:CONTAINER[:opts]]+Usage: encapsule run IMAGE [-v|--volume HOST:CONTAINER[:opts]] [-e|--env KEY[=VALUE]] [--path DIR] [-i|--init CMD]- [--cap NAME] [--pull]+ [--cap NAME] [--pull] [--user USER] [(-H|--home DIR[:opts]) [--backup-home]] [(-p|--project DIR[:opts]) [--backup-project]] [-n|--name NAME] [--readonly] [--no-network] [--no-sudo] [--no-skel] [--podman-opt OPTION] [--debug] [--dryrun]- [--refresh] [CMD]+ [[--] CMD] Run a temporary encapsule container @@ -88,6 +88,8 @@ container --cap NAME Enable a capability from the config file --pull Pull newer container image+ --user USER Override container user [default: host/image user+ with host UID] -H,--home DIR[:opts] Mount a directory as a writable home (created if missing; use DIR:O to overlay) --backup-home Tarball home directory before starting@@ -103,56 +105,67 @@ --podman-opt OPTION Pass an option directly to podman --debug Show debug output --dryrun Print the podman command instead of running it- --refresh Force re-commit of the toolbox image -h,--help Show this help text ``` ### `create` command-`create` is similar but creates a reusable container for a project and/or tmp home.+`create` is similar but creates a reusable container for a project and/or temp home. ### `enter` command `enter` is used to join an existing (typically running) encapsule container. +### `commit` command+`commit` saves a container as an encapsule image (`encapsule-CONTAINER` by default).+Use `-n/--name NAME` for a custom image name (`encapsule-NAME`, or `^NAME` to skip the prefix).+ ## Examples ```bash # Temporary isolated shell without host fs access-~$ encapsule run my-toolbox+~$ encapsule run fedora-toolbox:44 # Mount current (project) directory path and set it as the working directory-# (also names the container after the project, e.g. encapsule-my-toolbox-myproject)-~/myproj$ encapsule create my-toolbox -p .+# (also names the container after the project, e.g. encapsule-ubuntu-myproj)+~/myproj$ encapsule create ubuntu -p . # Bind mount a volume-$ encapsule run my-toolbox -v ~/data:/data+$ encapsule run fedora -v ~/data:/data -# Mount a temp "home" directory (created if it doesn't exist)-$ encapsule run my-toolbox --home /tmp/somedir+# create a custom "encapsule-fedora-toolbox-45" image from a toolbox container+$ encapsule commit fedora-toolbox-45 +# Mount a temp "home" directory in the committed encapsule image+$ encapsule run fedora-toolbox-45 --home ~/tmp/home++# Save another encapsule image named "encapsule-dev"+$ encapsule commit --name dev fedora-toolbox-45+ # Use capabilities from one's config-$ encapsule create my-toolbox --cap ssh --cap git+$ encapsule create dev --cap ssh --cap git +# Remove encapsule container+$ encapsule rm dev++# create "encapsule-my-toolbox" image+$ encapsule commit fedora-toolbox-45 --name my-toolbox+ # Read-only container filesystem $ encapsule run my-toolbox --readonly -# Remove encapsule container-$ encapsule rm my-toolbox- # Set environment variables and prepend to PATH $ encapsule run my-toolbox -e MY_VAR=hello -e LANG --path ~/.local/bin # Run a specific command $ encapsule run my-toolbox -- ls / +# Run a setup init scriptlet+$ encapsule run fedora-toolbox:45 -p proj --init "dnf install -y gcc make"+ # Dry run: print the full podman command without running it $ encapsule run --dryrun my-toolbox--# run directly from an image-$ encapsule run fedora:44 --home tmphome ``` -Note a saved encapsule image remains cached for next time,-but can be removed with the `rmi` command.+There is a `rmi` command to remove an encapsule image no longer needed. ## Capabilities @@ -189,17 +202,18 @@ ## How it works -1. Commits the named toolbox container to an encapsule image using `buildah commit`- (reuses the existing image unless `--refresh` is passed)-2. Runs `podman run` with `--userns=keep-id` so you are your own user, not root-3. Tries to install runuser (util-linux) and sudo (unless `--no-sudo`) if they are missing with dnf or apt-get.-4. Sets up passwordless `sudo` inside the encapsule container (unless `--no-sudo`)-5. Bind mounts get SELinux `:z` (shared) labels automatically,+0. Commits the named toolbox container to an encapsule image using `buildah commit`.+1. Runs `podman run` with `--userns=keep-id` so you are your own user, not root+2. Drops from root with `runuser` if present, otherwise `sudo -u`+ (`enter` uses `podman exec --user`)+3. Sets up passwordless `sudo` inside the encapsule container (unless `--no-sudo`)+4. Bind mounts get SELinux `:z` (shared) labels automatically, so multiple containers can safely access the same directories-6. When `-p/--project DIR` is used (and `--name` isn't), the container name+5. When `-p/--project DIR` is used (and `--name` isn't), the container name includes the project directory's name (e.g. `encapsule-mytoolbox-myproject`), so you can run the same toolbox against different projects at the same time- in separate encapsule containers+ in separate encapsule containers. Though for different project paths with+ the same directory name the container name will not be differentiated. ## Installation @@ -226,11 +240,35 @@ To build the latest release: `cabal install encapsule` or `stack install encapsule`. +## Tests++`cabal test` runs an hspec suite that drives the `encapsule` CLI+(`--dryrun` against local images, plus an optional live `run`).+It needs podman and skips missing images.++Default images are `ubuntu:latest` and `fedora:latest`.+Override with `ENCAPSULE_TEST_UBUNTU` and `ENCAPSULE_TEST_FEDORA`.+Live tests need a TTY, or set `ENCAPSULE_LIVE=1` to try without one.+`ENCAPSULE` selects a different encapsule binary.++```bash+cabal test+```++`cabal bench` times `encapsule run --dryrun` and a short `run -- true`+against a local image (same env vars as tests). It requires podman and an+image. It measures wall-clock time. To log timings:++```bash+cabal bench --benchmark-options '--csv /tmp/encapsule-bench.csv --time-limit 3'+# later: --baseline /tmp/encapsule-bench.csv+```+ ## Runtime Requirements - [podman](https://podman.io/) and [buildah](https://buildah.io/)-- An existing (toolbox) container (created with `toolbox create`) or image.-- Alternatively some other non-toolbox container/images may also work.+- An existing (toolbox) container (created with `toolbox create`) or an image.+- Alternatively other non-toolbox container/images can also work. ## Related projects @@ -241,6 +279,8 @@ Another somewhat related project is [podenv](https://github.com/podenv/podenv), which "provides a declarative interface to manage containerized applications." For stronger sandboxing and isolation, specially network, consider using [OpenShell](https://github.com/NVIDIA/OpenShell/). At some point this project might move to wrapping or supporting openshell possibly.++There is also [litterbox](https://github.com/Gerharddc/litterbox) which has quite a lot of features and though somewhat opinionated, for example like openshell also supports landlock confinement. ## Disclaimer The simple isolation provided is limited best effort and
+ bench/Bench.hs view
@@ -0,0 +1,72 @@+-- SPDX-License-Identifier: Apache-2.0++module Main (main) where++import Control.Exception (IOException, try)+import Data.IORef (atomicModifyIORef', newIORef)+import Data.Maybe (fromMaybe)+import System.Environment (lookupEnv)+import System.Exit (ExitCode(..), exitSuccess)+import System.Process (readProcessWithExitCode)+import Test.Tasty (localOption)+import Test.Tasty.Bench++main :: IO ()+main = do+ mimg <- pickImage+ case mimg of+ Nothing -> do+ putStrLn "skipping benches: no podman or usable image"+ exitSuccess+ Just img -> do+ nref <- newIORef (0 :: Int)+ -- Wall-clock: CPU time ignores time spent in encapsule/podman.+ defaultMain+ [ localOption WallTime $+ bgroup "encapsule"+ [ bench "dryrun" $+ nfIO $ runEnc ["run", "--dryrun", "--no-skel", img]+ , bench "run true" $ nfIO $ do+ n <- atomicModifyIORef' nref (\i -> (i + 1, i))+ let name = "^encap-bench-" ++ show n+ runEnc ["run", "--no-skel", "--name", name, img, "--", "true"]+ ]+ ]++runEnc :: [String] -> IO ()+runEnc args = do+ exe <- fromMaybe "encapsule" <$> lookupEnv "ENCAPSULE"+ (code, out, err) <- readProcessWithExitCode exe args ""+ case code of+ ExitSuccess -> return ()+ ExitFailure n ->+ fail $ "encapsule failed (" ++ show n ++ "): " ++ out ++ err++pickImage :: IO (Maybe String)+pickImage = do+ ok <- hasPodman+ if not ok+ then return Nothing+ else do+ u <- fromMaybe "ubuntu:latest" <$> lookupEnv "ENCAPSULE_TEST_UBUNTU"+ f <- fromMaybe "fedora:latest" <$> lookupEnv "ENCAPSULE_TEST_FEDORA"+ mu <- imageExists u+ mf <- imageExists f+ return $+ case (mu, mf) of+ (True, _) -> Just u+ (_, True) -> Just f+ _ -> Nothing++hasPodman :: IO Bool+hasPodman = do+ r <- try (readProcessWithExitCode "podman" ["--version"] "")+ :: IO (Either IOException (ExitCode, String, String))+ case r of+ Left _ -> return False+ Right (code, _, _) -> return $ code == ExitSuccess++imageExists :: String -> IO Bool+imageExists img = do+ (code, _, _) <- readProcessWithExitCode "podman" ["image", "exists", img] ""+ return $ code == ExitSuccess
encapsule.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: encapsule-version: 0.4.1+version: 0.5 synopsis: Run isolated toolbox containers with podman description: This tool (originally based on the toolbox-constrained project)@@ -37,7 +37,14 @@ executable encapsule main-is: Main.hs other-modules: Paths_encapsule+ Backup+ Config+ Enter+ Error+ Expand+ Run Script+ ShellQuote autogen-modules: Paths_encapsule hs-source-dirs: src build-depends: base < 5@@ -46,6 +53,7 @@ , filepath , containers , process+ , pretty-terminal , safe , shell-monad , simple-cmd >= 0.2.3@@ -69,5 +77,36 @@ if impl(ghc >= 8.4) ghc-options: -Wmissing-export-lists -Wpartial-fields+ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages++test-suite test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: EncapsuleTest+ hs-source-dirs: test+ build-depends: base < 5+ , directory+ , filepath+ , hspec+ , process+ , unix+ build-tool-depends: encapsule:encapsule+ default-language: Haskell2010+ ghc-options: -Wall -threaded+ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ hs-source-dirs: bench+ build-depends: base < 5+ , process+ , tasty+ , tasty-bench+ build-tool-depends: encapsule:encapsule+ default-language: Haskell2010+ ghc-options: -Wall -threaded if impl(ghc >= 8.10) ghc-options: -Wunused-packages
+ src/Backup.hs view
@@ -0,0 +1,91 @@+-- SPDX-License-Identifier: Apache-2.0++module Backup (backupCmd)++where++import Control.Monad.Extra (unless, when, whenM)+import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (defaultTimeLocale, formatTime)++import Safe (readMay)+import SimpleCmd ((+-+), cmd, cmd_, cmdLines, cmdN, warning)+import SimplePrompt (yesNo)+import System.Directory (canonicalizePath,+ doesDirectoryExist, doesFileExist, doesPathExist,+ getHomeDirectory)+import System.FilePath (dropTrailingPathSeparator, takeDirectory, takeFileName,+ (</>))+import System.IO.Extra (withTempFile)++import Error+import Expand+import ShellQuote++backupCmd :: Bool -> Bool -> Maybe FilePath -> FilePath -> IO ()+backupCmd dryrun yes moutput dir = do+ homedir <- getHomeDirectory >>= canonicalizePath+ src <- expandPath homedir dir >>= canonicalizePath+ exists <- doesDirectoryExist src+ unless exists $+ error' $ "directory not found:" +-+ src+ tarball <-+ case moutput of+ Just o -> expandPath homedir o+ Nothing -> do+ now <- getCurrentTime+ let stamp = formatTime defaultTimeLocale "%Y-%m-%d_%H-%M-%SZ" now+ return $ src ++ "-" ++ stamp ++ ".tar.gz"+ whenM (doesFileExist tarball) $+ if yes+ then warning $ "overwriting" +-+ tarball+ else error' $ "output already exists:" +-+ tarball +-+ "(use -y to overwrite)"+ isgit <- doesPathExist $ src </> ".git"+ let parent = takeDirectory src+ base = takeFileName src+ args = ["czf", tarball, "-C", parent]+ if isgit+ then do+ withTempFile $ \ignorefile -> do+ out <- cmdLines "git" ["-C", src, "ls-files", "--cached", "--others", "--exclude-per-directory=.gitignore", "--directory", "--ignored"]+ writeFile ignorefile $ unlines $ map dropTrailingPathSeparator out+ checkSize yes (Just ignorefile) src+ (if dryrun then cmdN else cmd_) "tar" $+ map shellQuote $ args ++ ["--exclude-from=" ++ ignorefile, base]+ else do+ checkSize yes Nothing src+ (if dryrun then cmdN else cmd_) "tar" $ map shellQuote args ++ [base]+ putStrLn $ "Wrote" +-+ tarball++-- Prompt when backing up more than this many bytes.+largeBackupBytes :: Integer+largeBackupBytes = 100 * 1024 * 1024++checkSize :: Bool -> Maybe FilePath -> FilePath -> IO ()+checkSize yes mignorefile src = do+ size <- dirSizeBytes mignorefile src+ let sizeStr = humanSize size+ putStrLn $ src +-+ "(" ++ sizeStr ++ ")"+ when (not yes && size >= largeBackupBytes || size == 0) $ do+ ok <- yesNo $ "Directory is" +-+ sizeStr ++ ", continue?"+ unless ok $+ error' "aborted"++dirSizeBytes :: Maybe FilePath -> FilePath -> IO Integer+dirSizeBytes mignorefile path = do+ let ignore = maybe [] (\i -> ["--exclude-from=" ++ i]) mignorefile+ out <- cmd "du" $ "-sb" : ignore ++ [path]+ case words out of+ (n:_) | Just i <- readMay n -> return i+ _ -> error' $ "could not determine size of" +-+ path++humanSize :: Integer -> String+humanSize n+ | n >= g = show (n `div` g) ++ "G"+ | n >= m = show (n `div` m) ++ "M"+ | n >= k = show (n `div` k) ++ "K"+ | otherwise = show n ++ "B"+ where+ k = 1024+ m = k * 1024+ g = m * 1024
+ src/Config.hs view
@@ -0,0 +1,94 @@+-- SPDX-License-Identifier: Apache-2.0++module Config (+ listCapsCmd,+ loadConfig,+ getCapabilities,+ progname,+ resolveCapabilities+ )+where++import Data.List (intercalate)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import SimpleCmd (error', (+-+))+import System.Directory (doesFileExist)+import System.Environment.XDG.BaseDir (getUserConfigFile)+import TOML (Value(..), Table, renderTOMLError, decodeFile)++progname :: String+progname = "encapsule"++loadConfig :: IO (Maybe Table)+loadConfig = do+ path <- getUserConfigFile progname "config.toml"+ exists <- doesFileExist path+ if not exists+ then return Nothing+ else do+ result <- decodeFile path+ case result of+ Left e -> error' $ "config parse error:" +-+ T.unpack (renderTOMLError e)+ Right table -> return (Just table)++getCapabilities :: Maybe Table -> Table+getCapabilities Nothing = Map.empty+getCapabilities (Just table) =+ case Map.lookup (T.pack "capabilities") table of+ Just (Table t) -> t+ _ -> Map.empty++resolveCapabilities :: Table -> [String] -> IO ([String], [String], [String], [String], [String])+resolveCapabilities caps capNames = do+ results <- mapM (resolveCap caps) capNames+ let (vs, es, ps, is, ss) = unzip5 results+ return (concat vs, concat es, concat ps, concat is, concat ss)+ where+ unzip5 = foldr (\(a,b,c,d,e) (as,bs,cs,ds,es) -> (a:as,b:bs,c:cs,d:ds,e:es))+ ([],[],[],[],[])++resolveCap :: Table -> String -> IO ([String], [String], [String], [String], [String])+resolveCap caps name =+ case Map.lookup (T.pack name) caps of+ Just (Table cap) ->+ return ( getStringList "volumes" cap+ , getStringList "env" cap+ , getStringList "path" cap+ , case getStringVal "init" cap of+ Just s -> [s]+ Nothing -> []+ , getStringList "security_opts" cap+ )+ _ -> do+ let available = if Map.null caps+ then "(none defined)"+ else intercalate ", " $ map T.unpack $ Map.keys caps+ error' $ "unknown capability '" ++ name ++ "'. Available:" +-+ available++getStringList :: String -> Table -> [String]+getStringList key table =+ case Map.lookup (T.pack key) table of+ Just (Array arr) -> mapMaybe valueToString arr+ _ -> []++getStringVal :: String -> Table -> Maybe String+getStringVal key table =+ case Map.lookup (T.pack key) table of+ Just (String t) -> Just (T.unpack t)+ _ -> Nothing++valueToString :: Value -> Maybe String+valueToString (String t) = Just (T.unpack t)+valueToString _ = Nothing++listCapsCmd :: IO ()+listCapsCmd = do+ config <- loadConfig+ let capabilities = getCapabilities config+ if Map.null capabilities+ then putStrLn "No capabilities defined"+ else do+ putStrLn "Available capabilities:"+ mapM_ (putStrLn . (" " ++) . T.unpack) $ Map.keys capabilities
+ src/Enter.hs view
@@ -0,0 +1,94 @@+-- SPDX-License-Identifier: Apache-2.0++module Enter (+ enterContainer,+ passwdEntryForUidSh,+ passwdEntryForNameSh,+ usablePasswdHome,+ langEnvArgs,+ )+where++import Control.Monad (unless, when)+import Data.Maybe (fromMaybe, isNothing)+import SimpleCmd (cmd, cmd_, cmdFull)+import System.Directory (canonicalizePath, getHomeDirectory)+import System.Exit (exitWith)+import System.FilePath (isAbsolute)+import System.Process (rawSystem)+import System.Posix.User (getEffectiveUserID, getEffectiveUserName)++import ShellQuote++enterContainer :: Bool -> Bool -> Bool -> String -> [String] -> IO ()+enterContainer dryrun debug running container command = do+ hostHome <- getHomeDirectory >>= canonicalizePath+ unless running $ do+ putStr "start "+ cmd_ "podman" ["start", container]+ (username, mPasswdHome) <- lookupContainerUser container+ wd <- containerWorkdir container+ let userCmd = if null command then ["bash"] else command+ homeDir = fromMaybe hostHome mPasswdHome+ -- If inspect reports "/" then --workdir was omitted at create+ -- (host $HOME was not in the image), then fallback to $HOME+ workdir =+ case wd of+ "" -> homeDir+ "/" -> homeDir+ d -> d+ homeEnv =+ if isNothing mPasswdHome then ["env", "HOME=" ++ homeDir] else []+ execArgs = ["exec", "-it", "--user", username,+ "--workdir", workdir, container]+ ++ langEnvArgs ++ homeEnv ++ userCmd+ when (dryrun || debug) $+ putStrLn $ unwords ("podman" : map shellQuote execArgs)+ unless dryrun $ do+ ret <- rawSystem "podman" execArgs+ exitWith ret++-- POSIX lookup: print passwd name and home (two lines) for a numeric UID.+passwdEntryForUidSh :: String -> String+passwdEntryForUidSh uid =+ passwdEntrySh $ "[ \"$id\" = " ++ shellQuote uid ++ " ]"++-- POSIX lookup: print passwd name and home (two lines) for a user name.+passwdEntryForNameSh :: String -> String+passwdEntryForNameSh user =+ passwdEntrySh $ "[ \"$name\" = " ++ shellQuote user ++ " ]"++passwdEntrySh :: String -> String+passwdEntrySh match =+ "while IFS=: read name _ id _ _ home _; do " ++ match +++ " && echo \"$name\" && echo \"$home\" && break; done < /etc/passwd"++-- Empty, "/", or non-absolute passwd homes are dummy+-- (keep-id copies --workdir, which defaults to "/").+usablePasswdHome :: String -> Maybe FilePath+usablePasswdHome h+ | null h || h == "/" = Nothing+ | isAbsolute h = Just h+ | otherwise = Nothing++lookupContainerUser :: String -> IO (String, Maybe FilePath)+lookupContainerUser container = do+ hostName <- getEffectiveUserName+ uid <- getEffectiveUserID+ let uidStr = show (fromIntegral uid :: Integer)+ sh = passwdEntryForUidSh uidStr+ (_, out, _) <- cmdFull "podman" ["exec", container, "/bin/sh", "-c", sh] ""+ case lines out of+ (n:h:_) | not (null n) -> return (n, usablePasswdHome h)+ (n:_) | not (null n) -> return (n, Nothing)+ _ -> return (hostName, Nothing)++containerWorkdir :: String -> IO String+containerWorkdir container =+ cmd "podman"+ ["container", "inspect", "-f", "{{.Config.WorkingDir}}", container]++-- Base images typically only ship C.UTF-8 (plus C/POSIX). Override with+-- -e LANG=C or -e LANG=en_US.UTF-8 if the image has that locale.+langEnvArgs :: [String]+langEnvArgs = ["-e", "LANG=C.UTF-8"]
+ src/Error.hs view
@@ -0,0 +1,8 @@+module Error (error') where++import System.Exit (exitFailure)++error':: String -> IO a+error' err = do+ putStrLn err+ exitFailure
+ src/Expand.hs view
@@ -0,0 +1,57 @@+-- SPDX-License-Identifier: Apache-2.0++module Expand (+ expandPath,+ expandContainerPath,+ )+where++import System.Directory (canonicalizePath)+import System.FilePath ((</>))+import System.Posix.Env (getEnvDefault)++-- | Expand ~ and $VARS; canonicalize (host paths).+expandPath :: FilePath -- homedir+ -> String -- path string+ -> IO FilePath+expandPath = expandHome canonicalizePath++-- | Expand ~ and $VARS without canonicalize (container paths need not exist on the host).+expandContainerPath :: FilePath -- homedir+ -> String -- path string+ -> IO FilePath+expandContainerPath = expandHome return++expandHome :: (FilePath -> IO FilePath) -> FilePath -> String -> IO FilePath+expandHome finish homedir ('~':'/':rest) = do+ rest' <- expandEnvVars rest+ finish $ homedir </> rest'+expandHome finish homedir "~" = finish homedir+expandHome _ _ s = expandEnvVars s++expandEnvVars :: String -> IO String+expandEnvVars [] = return []+expandEnvVars ('$':'{':rest) =+ case break (== '}') rest of+ (var, '}':after) -> do+ val <- getEnvDefault var ""+ rest' <- expandEnvVars after+ return (val ++ rest')+ _ -> do+ rest' <- expandEnvVars rest+ return ("${" ++ rest')+expandEnvVars ('$':rest) =+ let (var, after) = span isVarChar rest+ in if null var+ then do+ rest' <- expandEnvVars rest+ return ('$' : rest')+ else do+ val <- getEnvDefault var ""+ rest' <- expandEnvVars after+ return (val ++ rest')+ where+ isVarChar c = c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_")+expandEnvVars (c:rest) = do+ rest' <- expandEnvVars rest+ return (c : rest')
src/Main.hs view
@@ -1,42 +1,19 @@ -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE RecordWildCards #-}- module Main (main) where -import Control.Monad.Extra (unless, void, when, whenJust, (>=>))-import Data.List.Extra (intercalate, isPrefixOf, splitOn)-import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe, isNothing, mapMaybe)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (defaultTimeLocale, formatTime)-import Safe (headMay, lastMay, readMay)-import SimpleCmd (cmd, cmd_, cmdBool, cmdFull, cmdLines, cmdN, warning, (+-+))+import Control.Monad.Extra (unless, when)+import Data.Maybe (fromMaybe)+import SimpleCmd (cmd_, cmdBool, cmdFull, cmdLines, cmdN, warning, (+-+)) import SimpleCmdArgs-import SimplePrompt (yesNo)-import System.Directory (canonicalizePath, createDirectoryIfMissing,- doesDirectoryExist, doesFileExist, doesPathExist,- getHomeDirectory)-import System.Environment.XDG.BaseDir (getUserConfigFile)-import System.Exit (exitWith, exitFailure)-import System.FilePath ((</>), makeRelative, takeDirectory, takeFileName) import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)-import System.Posix.Process (getProcessID)-import System.Posix.Env (getEnvDefault)-import System.Posix.Files (fileOwner, getFileStatus, isSocket)-import System.Posix.User (getEffectiveUserID, getEffectiveUserName)-import System.Process (rawSystem)-import TOML (Value(..), Table, renderTOMLError, decodeFile) +import Backup+import Config+import Error import Paths_encapsule (version)-import Script--progname :: String-progname = "encapsule"--data ProjectName = Project FilePath | Name String+import qualified Run+import Run hiding (RunOpts(..)) main :: IO () main = do@@ -53,36 +30,38 @@ pure listCapsCmd , Subcommand "rm" "Remove an encapsule container" $ removeCmd- <$> toolboxArg+ <$> strArg "TOOLBOX" <*> optional projectNameOpt , Subcommand "rmi" "Remove an encapsule image" $ removeImageCmd <$> dryrunOpt- <*> toolboxArg+ <*> strArg "TOOLBOX" , Subcommand "stop" "Stop an encapsule container" $ stopCmd- <$> toolboxArg+ <$> strArg "TOOLBOX" <*> optional projectNameOpt , Subcommand "backup" "Create a tarball backup of a directory" $ backupCmd <$> dryrunOpt <*> switchWith 'y' "yes" "Don't prompt for large directories" <*> optional (strOptionWith 'o' "output" "FILE" "Output tarball (default: DIR-<timestamp>.tar.gz)")- <*> argumentWith str "DIR"+ <*> strArg "DIR"+ , Subcommand "commit" "Commit an encapsule image from a container" $+ commitCmd+ <$> dryrunOpt+ <*> optional (strOptionWith 'n' "name" "NAME" "Optional image name (prefix with '^' to skip 'encapsule-' prefix)")+ <*> strArg "TOOLBOX" , Subcommand "create" "Create an encapsule container" $- runCmd <$> runOpts True False False+ runCmd <$> runOpts True False , Subcommand "enter" "Connect to a encapsule container" $ enterCmd <$> dryrunOpt+ <*> debugOpt <*> pure True- <*> optional toolboxArg+ <*> optional (strArg "TOOLBOX") <*> optional projectNameOpt- , Subcommand "refresh" "Re-commit an encapsule image from a (toolbox) container" $- refreshCmd- <$> dryrunOpt- <*> toolboxArg , Subcommand "run" "Run a temporary encapsule container" $- runCmd <$> runOpts False True True+ runCmd <$> runOpts False True ] where dryrunOpt = switchLongWith "dryrun" "Print the podman command instead of running it"@@ -94,23 +73,24 @@ projectNameOpt = Project <$> projectOpt "Project name or path" <|> Name <$> nameOpt - toolboxArg = argumentWith str "TOOLBOX"- backupDirOpt s l m h = let pair fs sn = (fs,sn) in pair <$> strOptionWith s l m h <*> switchLongWith ("backup-" ++ l) ("Tarball" +-+ l +-+ "directory before starting") - runOpts keep unique refresh' =- RunOpts- <$> toolboxArg+ debugOpt = switchLongWith "debug" "Show debug output"++ runOpts keep unique =+ Run.RunOpts+ <$> strArg "IMAGE" <*> many (strOptionWith 'v' "volume" "HOST:CONTAINER[:opts]" "Bind mount (user's files default to selinux :z)") <*> many (strOptionWith 'e' "env" "KEY[=VALUE]" "Set or pass through an environment variable") <*> many (strOptionLongWith "path" "DIR" "Prepend a directory to PATH inside the container") <*> many (strOptionWith 'i' "init" "CMD" "A bash snippet run when creating the encapsule container") <*> many (strOptionLongWith "cap" "NAME" "Enable a capability from the config file") <*> switchLongWith "pull" "Pull newer container image"+ <*> optional (strOptionLongWith "user" "USER" "Override container user [default: host/image user with host UID]") <*> optional (backupDirOpt 'H' "home" "DIR[:opts]" "Mount a directory as a writable home (created if missing; use DIR:O to overlay)") <*> optional (backupDirOpt 'p' "project" "DIR[:opts]" "Mount a (project) directory as workdir (use DIR:O to overlay)") <*> optional nameOpt@@ -121,16 +101,13 @@ <*> switchLongWith "no-skel" "Don't copy /etc/skel into an empty home" <*> pure unique <*> many (strOptionLongWith "podman-opt" "OPTION" "Pass an option directly to podman")- <*> switchLongWith "debug" "Show debug output"+ <*> debugOpt <*> dryrunOpt- <*> (if refresh'- then switchLongWith "refresh" "Force re-commit of the toolbox image"- else pure False)- <*> many (argumentWith str "CMD")-+ <*> many (strArg "[--] CMD") listCmd :: IO () listCmd = do+ needPodman cmd_ "podman" ["images", "--filter", "reference=" ++ progname ++ "-*", "--format", "{{.Repository}}:{{.Tag}} {{.Size}} {{.Created}}"]@@ -139,19 +116,10 @@ "--filter", "name=^" ++ progname +=+ "", "--format", "{{.Names}} {{.Status}}"] -listCapsCmd :: IO ()-listCapsCmd = do- config <- loadConfig- let capabilities = getCapabilities config- if Map.null capabilities- then putStrLn "No capabilities defined"- else do- putStrLn "Available capabilities:"- mapM_ (putStrLn . (" " ++) . T.unpack) $ Map.keys capabilities- removeCmd :: String -> Maybe ProjectName -> IO () removeCmd toolbox mprojectname = do containerName <- mkContainerName toolbox mprojectname+ needPodman exists <- cmdBool "podman" ["container", "exists", containerName] if exists then do@@ -164,15 +132,22 @@ cmd_ "podman" ["rm", containerName] else warning $ "container" +-+ containerName +-+ "not found" +-- FIXME check image exists? removeImageCmd :: Bool -> String -> IO () removeImageCmd dryrun name =- when dryrun $- removeImage (progname +=+ name)+ let image = progname +=+ name in+ if dryrun+ then putStrLn $ "would rmi" +-+ image+ else do+ needPodman+ putStr "rmi "+ cmd_ "podman" ["rmi", image] -- FIXME dryrun stopCmd :: String -> Maybe ProjectName -> IO () stopCmd name mprojectname = do containerName <- mkContainerName name mprojectname+ needPodman exists <- cmdBool "podman" ["container", "exists", containerName] if exists then do@@ -180,8 +155,8 @@ cmd_ "podman" ["stop", containerName] else warning $ "container" +-+ containerName +-+ "not found" -enterCmd :: Bool -> Bool -> Maybe String -> Maybe ProjectName -> IO ()-enterCmd dryrun running mbase mprojectname = do+enterCmd :: Bool -> Bool -> Bool -> Maybe String -> Maybe ProjectName -> IO ()+enterCmd dryrun debug running mbase mprojectname = do regexp <- case mprojectname of Nothing -> return $ progname +=+ fromMaybe "" mbase@@ -189,6 +164,7 @@ Just (Project p) -> do projectDir <- resolveProject p return $ progname ++ '-' : fromMaybe ".*" mbase ++ '-' : workProjectName projectDir+ needPodman ps <- cmdLines "podman" $ "ps" : ["-a" | not running] ++ ["--filter", "name=" ++ '^' : regexp,@@ -197,670 +173,31 @@ [] -> if running then do- enterCmd dryrun False mbase mprojectname+ enterCmd dryrun debug False mbase mprojectname else error' "encapsule container not found" [c] -> do unless running $ warning "no running encapsule container found"- enterContainer dryrun True c []+ enterContainer dryrun debug True c [] _ -> error' $ "multiple" +-+ (if running then "running" else "") +-+ "containers match:\n" ++ unlines ps -enterContainer :: Bool -> Bool -> String -> [String] -> IO ()-enterContainer dryrun running container command = do- homedir <- getHomeDirectory >>= canonicalizePath- username <- getEffectiveUserName- unless running $ do- putStr "start "- cmd_ "podman" ["start", container]- let userCmd = if null command then ["bash"] else command- execCmd = ["podman", "exec", "-it", container,- "runuser", "-u", username, "--",- "env", "HOME=" ++ homedir] ++ userCmd- if dryrun- then putStrLn $ unwords (map shellQuote execCmd)- else do- ret <- rawSystem "podman" (drop 1 execCmd)- exitWith ret--data RunOpts = RunOpts- { toolbox :: String- , vols :: [String]- , envs :: [String]- , paths :: [String]- , inits :: [String]- , caps :: [String]- , pull :: Bool- , mhome :: Maybe (FilePath, Bool)- , mproject :: Maybe (FilePath, Bool)- , mname :: Maybe String- , keep :: Bool- , readonly :: Bool- , nonetwork :: Bool- , nosudo :: Bool- , noskel :: Bool- , unique :: Bool- , podmanopts :: [String]- , debugging :: Bool- , dryrun :: Bool- , refresh :: Bool- , command :: [String]- }--runCmd :: RunOpts -> IO ()-runCmd (RunOpts {..}) = do- let (mhomeDir, homeMountOpts, backupHome) = splitDirOptsMaybe mhome- (mprojectPath, projectMountOpts, backupProject) = splitDirOptsMaybe mproject- mprojectDir <- traverse resolveProject mprojectPath- containerName <-- mkContainerName toolbox $- maybe (Project <$> mprojectPath) (Just . Name) mname- debug containerName- exists <- cmdBool "podman" ["container", "exists", containerName]- when (keep && not unique && exists) $- error' $ "container" +-+ containerName +-+ "already exists"- container <-- -- FIXME Coderabbit pointed out this could lead to race with 2 invocations- if unique && exists- then do- pid <- getProcessID- return $ containerName +=+ show pid- else return containerName- debug $ "container:" +-+ container- running <-- if unique- then return False- else- if exists- then do- (_, out, _) <- cmdFull "podman"- ["container", "inspect", "-f", "{{.State.Running}}", container] ""- if take 4 out == "true"- then return True- else do- putStr "start "- cmd_ "podman" ["start", container]- return True- else return False- debug $ "running:" +-+ show running- homedir <- getHomeDirectory >>= canonicalizePath- debug $ "HOME:" +-+ homedir- if running- then do- let noopts = and- [ null vols- , null envs- , null paths- , null inits- , null caps- , isNothing mproject || isNothing mname- , isNothing mhome- , not keep- , not readonly- , not nonetwork- , not nosudo- , not noskel- , null podmanopts- , not refresh- ]- unless noopts $- error' "cannot give options for an existing container!"- warning "Entering existing container"- enterContainer dryrun True container command- else do- when backupHome $- whenJust mhomeDir $ backupCmd dryrun False Nothing- when backupProject $- whenJust mprojectDir $ backupCmd dryrun False Nothing- createContainer homedir mhomeDir homeMountOpts mprojectDir- projectMountOpts container- where- createContainer homedir mhomeDir homeMountOpts mprojectDir- projectMountOpts container = do- mtemphome <- traverse (expandPath homedir >=> canonicalizePath) mhomeDir- case (mtemphome, mprojectDir) of- (Just h, Just p) | h == p ->- error' "--home and --project must be different directories"- _ -> return ()- let isImage = ':' `elem` toolbox- debug $ if isImage- then "image:" +-+ toolbox- -- FIXME handling of unique is kind of broken: not container- else "toolbox:" +-+ toolbox- image <-- if isImage- then do- when pull $- cmd_ "podman" ["pull", toolbox]- return toolbox- else commitToolbox dryrun toolbox refresh- config <- loadConfig- let capabilities = getCapabilities config-- (extraVols, extraEnvs, extraPaths, extraInits, extraSecurityOpts) <-- resolveCapabilities capabilities caps-- homeVol <-- case mtemphome of- Just temphome -> do- createDirectoryIfMissing True temphome- -- Mount targets under $HOME land inside the temp home volume;- -- create them as the user so podman does not leave root-owned paths.- case mprojectDir of- Just p -> ensureTempHomeMountPoint homedir temphome p p- Nothing -> return ()- mapM_ (ensureTempHomeVol homedir temphome) (vols ++ extraVols)- return [temphome ++ ":" ++ homedir ++ maybeOpts homeMountOpts]- Nothing -> return []-- username <- getEffectiveUserName-- projectVol <-- case mprojectDir of- Just d -> do- exists <- doesDirectoryExist d- if exists- then return [d ++ ':' : d ++ maybeOpts projectMountOpts]- else error' $ "project dir not found:" +-+ d- Nothing -> return []- -- mounting real $HOME needs label=disable (no :z) on Fedora/SELinux- let mountsRealHome =- Just homedir == mtemphome || Just homedir == mprojectDir- securityOpts =- extraSecurityOpts ++- ["label=disable" | mountsRealHome,- "label=disable" `notElem` extraSecurityOpts]- volumes = homeVol ++ vols ++ extraVols ++ projectVol- envVars = envs ++ extraEnvs- allpaths = paths ++ extraPaths- allinits = inits ++ extraInits-- runuserCmd =- let envParts = ("HOME=" ++ homedir) : pathEnvPart allpaths- userCmdParts = mkUserCmd command allinits- in "env" +-+ unwords (envParts ++ map shellQuote userCmdParts)-- sudoers = "/etc/sudoers.d" </> progname- installSetup =- [TL.unpack $ installScript debugging (not nosudo) | isImage]- sudoSetup =- if nosudo- then ["rm -f /usr/bin/sudo"]- else ["echo" +-+ shellQuote (username +-+ "ALL=(ALL) NOPASSWD:ALL")- +-+ ">" +-+ sudoers,- "chmod 440" +-+ sudoers]- homeSetup =- if isNothing mhome- then ["mkdir -p" +-+ homedir,- "chown" +-+ username +-+ homedir]- else []- skelSetup =- [ "if [ ! -e " ++ shellQuote (homedir </> ".bashrc") ++- " ] && [ -d /etc/skel ]; then " ++- "runuser -u" +-+ username +-+ "-- cp -an /etc/skel/." +-+- shellQuote (homedir ++ "/") ++ "; fi"- | not noskel ]- -- podman --workdir requires the path to exist at start; for no- -- --workdir/--project, mkdir home first then cd (see workdirPart)- cdHome = ["cd" +-+ shellQuote homedir | isNothing mprojectDir]- fallback =- if isImage- then " || exec" +-+ runuserCmd- else ""- trace = ["set -x" | debugging]- setup = intercalate " && "- (trace ++ installSetup ++ sudoSetup ++ homeSetup ++ skelSetup ++- cdHome ++- [mkInitSetup allinits | not (null allinits)] ++- ["exec runuser -u" +-+ username +-+ "--" +-+ runuserCmd])- ++ fallback-- when ("label=disable" `elem` securityOpts) $- warning "SELinux labeling disabled for this container (label=disable)"- unless dryrun $ debug $ "setup:" +-+ setup- mounts <- mapM (addSelinuxLabel homedir) volumes-- let workdirPart =- case mprojectDir of- Just d -> ["--workdir", d]- Nothing -> []- args = "run" :- [ "--rm" | not keep] ++- [ "-it",- "--userns=keep-id",- "--name", container,- "--hostname", hostnameFromName container,- "--user", "root",- "-e", "HOME=" ++ homedir,- "-e", "TERM",- "-e", "COLORTERM"]- ++ workdirPart- ++ (if readonly- then ["--read-only", "--tmpfs", "/tmp", "--tmpfs", "/run"]- ++ case mtemphome of- Nothing -> ["--tmpfs", homedir]- Just _ -> []- else [])- ++ (if nonetwork then ["--net", "none"] else [])- ++ concatMap (\s -> ["--security-opt", s]) securityOpts- ++ concatMap (\m -> ["-v", m]) mounts- ++ concatMap (\e -> ["-e", e]) envVars- ++ podmanopts- ++ [image, "sh", "-c", setup]-- if dryrun- then cmdN "podman" $ map shellQuote args- else do- ret <- rawSystem "podman" args- exitWith ret-- debug msg = when debugging $ warning $ "debug:" +-+ msg- -- image management -refreshCmd :: Bool -> String -> IO ()-refreshCmd dryrun toolbox = do+commitCmd :: Bool -> Maybe String -> String -> IO ()+commitCmd dryrun mname toolbox = do+ needPodman containerExists <- cmdBool "podman" ["container", "exists", toolbox] unless containerExists $ error' $ "container '" ++ toolbox ++ "' not found"- let image = progname +=+ toolbox+ let image = maybe (progname +=+ toolbox) encapsuleName mname+ encapsuleName ('^':n) = n+ encapsuleName n = progname +=+ n imageExists <- cmdBool "podman" ["image", "exists", image] unless imageExists $- error' $ "image" +-+ image +-+ "not found (create or run first)"- void $ commitToolbox dryrun toolbox True---- Prompt when backing up more than this many bytes.-largeBackupBytes :: Integer-largeBackupBytes = 100 * 1024 * 1024--backupCmd :: Bool -> Bool -> Maybe FilePath -> FilePath -> IO ()-backupCmd dryrun yes moutput dir = do- homedir <- getHomeDirectory >>= canonicalizePath- src <- expandPath homedir dir >>= canonicalizePath- exists <- doesDirectoryExist src- unless exists $- error' $ "directory not found:" +-+ src- size <- dirSizeBytes src- let sizeStr = humanSize size- putStrLn $ src +-+ "(" ++ sizeStr ++ ")"- when (not yes && size >= largeBackupBytes || size == 0) $ do- ok <- yesNo $ "Directory is" +-+ sizeStr ++ ", continue?"- unless ok $- error' "aborted"- out <-- case moutput of- Just o -> expandPath homedir o- Nothing -> do- now <- getCurrentTime- let stamp = formatTime defaultTimeLocale "%Y-%m-%d_%H:%M:%SZ" now- return $ src ++ "-" ++ stamp ++ ".tar.gz"- outExists <- doesFileExist out- when outExists $- if yes- then warning $ "overwriting" +-+ out- else error' $ "output already exists:" +-+ out +-+ "(use -y to overwrite)"- let parent = takeDirectory src- base = takeFileName src- args = ["czf", out, "-C", parent, base]+ putStrLn $ "creating new image:" +-+ image+ let buildah_args = ["commit", "--disable-compression", toolbox, image] if dryrun- then putStrLn $ unwords $ "tar" : map shellQuote args- else do- putStrLn $ "Writing" +-+ out- cmd_ "tar" args--dirSizeBytes :: FilePath -> IO Integer-dirSizeBytes path = do- out <- cmd "du" ["-sb", path]- case words out of- (n:_) | Just i <- readMay n -> return i- _ -> error' $ "could not determine size of" +-+ path--humanSize :: Integer -> String-humanSize n- | n >= g = show (n `div` g) ++ "G"- | n >= m = show (n `div` m) ++ "M"- | n >= k = show (n `div` k) ++ "K"- | otherwise = show n ++ "B"- where- k = 1024- m = k * 1024- g = m * 1024--commitToolbox :: Bool -> String -> Bool -> IO String-commitToolbox dryrun toolbox refresh = do- let image = progname +=+ toolbox- imageExists <- cmdBool "podman" ["image", "exists", image]- if imageExists && not refresh- then return image- else do- containerExists <- cmdBool "podman" ["container", "exists", toolbox]- if containerExists- then do- let buildah_args = ["commit", "--disable-compression", toolbox, image]- ok <-- if dryrun- then do- cmdN "buildah" buildah_args- return True- else do- putStr "writing image "- cmdBool "buildah" buildah_args- if ok- then return image- else error' $ "could not commit image of container" +-+ toolbox- else error' $ "container '" ++ toolbox ++ "' not found"--removeImage :: String -> IO ()-removeImage image = do- putStr "rmi "- cmd_ "podman" ["rmi", image]---- config--configPath :: IO FilePath-configPath = getUserConfigFile progname "config.toml"--loadConfig :: IO (Maybe Table)-loadConfig = do- path <- configPath- exists <- doesFileExist path- if not exists- then return Nothing+ then cmdN "buildah" buildah_args else do- result <- decodeFile path- case result of- Left e -> error' $ "config parse error:" +-+ T.unpack (renderTOMLError e)- Right table -> return (Just table)--getCapabilities :: Maybe Table -> Table-getCapabilities Nothing = Map.empty-getCapabilities (Just table) =- case Map.lookup (T.pack "capabilities") table of- Just (Table t) -> t- _ -> Map.empty--resolveCapabilities :: Table -> [String] -> IO ([String], [String], [String], [String], [String])-resolveCapabilities caps capNames = do- results <- mapM (resolveCap caps) capNames- let (vs, es, ps, is, ss) = unzip5 results- return (concat vs, concat es, concat ps, concat is, concat ss)- where- unzip5 = foldr (\(a,b,c,d,e) (as,bs,cs,ds,es) -> (a:as,b:bs,c:cs,d:ds,e:es))- ([],[],[],[],[])--resolveCap :: Table -> String -> IO ([String], [String], [String], [String], [String])-resolveCap caps name =- case Map.lookup (T.pack name) caps of- Just (Table cap) ->- return ( getStringList "volumes" cap- , getStringList "env" cap- , getStringList "path" cap- , case getStringVal "init" cap of- Just s -> [s]- Nothing -> []- , getStringList "security_opts" cap- )- _ -> do- let available = if Map.null caps- then "(none defined)"- else intercalate ", " $ map T.unpack $ Map.keys caps- error' $ "unknown capability '" ++ name ++ "'. Available:" +-+ available--getStringList :: String -> Table -> [String]-getStringList key table =- case Map.lookup (T.pack key) table of- Just (Array arr) -> mapMaybe valueToString arr- _ -> []--getStringVal :: String -> Table -> Maybe String-getStringVal key table =- case Map.lookup (T.pack key) table of- Just (String t) -> Just (T.unpack t)- _ -> Nothing--valueToString :: Value -> Maybe String-valueToString (String t) = Just (T.unpack t)-valueToString _ = Nothing---- SELinux labeling---- FIXME rather return Mount type or triple?-addSelinuxLabel :: FilePath -> String -> IO String-addSelinuxLabel homedir spec =- case break (== ':') spec of- (hostPart, []) -> do- hostExp <- expandPath homedir hostPart- requireVolumeHost hostExp- skipLabel <- shouldSkipLabel hostExp- return $ hostExp ++ ":" ++ hostExp ++ if skipLabel then "" else ":z"- (hostPart, _:rest') -> do- hostExp <- expandPath homedir hostPart- requireVolumeHost hostExp- let (containerPart, optsPart)- | isVolumePathStart rest' =- case break (== ':') rest' of- (c, []) -> (c, Nothing)- (c, _:o) -> (c, Just o)- | otherwise = (hostExp, if null rest' then Nothing else Just rest')- containerExp <- expandPath homedir containerPart- skipLabel <- shouldSkipLabel hostExp- let labeled = case optsPart of- Nothing ->- if skipLabel- then hostExp ++ ":" ++ containerExp- else hostExp ++ ":" ++ containerExp ++ ":z"- Just o ->- let flags = splitOn "," o- in if skipLabel || "z" `elem` flags || "Z" `elem` flags- || "O" `elem` flags- then hostExp ++ ":" ++ containerExp ++ ":" ++ o- else hostExp ++ ":" ++ containerExp ++ ":" ++ o ++ ",z"- return labeled- where- -- Skip auto :z for sockets, real $HOME (uses label=disable), and paths we- -- cannot relabel (rootless lsetxattr fails on files owned by another user).- shouldSkipLabel hostExp = do- sockFile <- isSocketFile hostExp- selfOwned <- ownedBySelf hostExp- return $ sockFile || hostExp == homedir || not selfOwned--requireVolumeHost :: FilePath -> IO ()-requireVolumeHost path = do- exists <- doesPathExist path- unless exists $- error' $ "volume host path not found:" +-+ path--isSocketFile :: FilePath -> IO Bool-isSocketFile path = isSocket <$> getFileStatus path---- Rootless podman cannot lsetxattr on files owned by another uid (e.g. /etc/*).-ownedBySelf :: FilePath -> IO Bool-ownedBySelf path = do- uid <- getEffectiveUserID- st <- getFileStatus path- return $ fileOwner st == uid---- DIR[:opts] for --home/--project (opts must not look like a path).-splitDirOpts :: String -> (FilePath, Maybe String)-splitDirOpts spec =- case break (== ':') spec of- (dir, []) -> (dir, Nothing)- (dir, _:rest)- | isVolumePathStart rest -> (spec, Nothing)- | otherwise -> (dir, Just rest)--splitDirOptsMaybe :: Maybe (String,Bool)- -> (Maybe FilePath, Maybe String, Bool)-splitDirOptsMaybe Nothing = (Nothing, Nothing, False)-splitDirOptsMaybe (Just (s,backup)) =- let (dir, opts) = splitDirOpts s- in (Just dir, opts, backup)--maybeOpts :: Maybe String -> String-maybeOpts Nothing = ""-maybeOpts (Just o) = ':' : o--isVolumePathStart :: String -> Bool-isVolumePathStart ('/':_) = True-isVolumePathStart ('~':_) = True-isVolumePathStart ('$':_) = True-isVolumePathStart _ = False---- path and env expansion--expandPath :: FilePath -> String -> IO FilePath-expandPath homedir ('~':'/':rest) = do- rest' <- expandEnvVars rest- canonicalizePath $ homedir </> rest'-expandPath homedir "~" = return homedir-expandPath _ s = expandEnvVars s--expandEnvVars :: String -> IO String-expandEnvVars [] = return []-expandEnvVars ('$':'{':rest) =- case break (== '}') rest of- (var, '}':after) -> do- val <- getEnvDefault var ""- rest' <- expandEnvVars after- return (val ++ rest')- _ -> do- rest' <- expandEnvVars rest- return ("${" ++ rest')-expandEnvVars ('$':rest) =- let (var, after) = span isVarChar rest- in if null var- then do- rest' <- expandEnvVars rest- return ('$' : rest')- else do- val <- getEnvDefault var ""- rest' <- expandEnvVars after- return (val ++ rest')- where- isVarChar c = c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_")-expandEnvVars (c:rest) = do- rest' <- expandEnvVars rest- return (c : rest')--resolveProject :: FilePath -> IO FilePath-resolveProject dir = do- homedir <- getHomeDirectory >>= canonicalizePath- finaldir <- expandPath homedir dir >>= canonicalizePath- when (finaldir == homedir) $- warning "mounting $HOME as project (consider a subdirectory)"- return finaldir---- True if path is base or a subdirectory of base (avoids /home/foo vs /home/foobar).-isUnderDir :: FilePath -> FilePath -> Bool-isUnderDir base path =- path == base || (base ++ "/") `isPrefixOf` path---- Pre-create a bind mount point under temp home when the container path is--- inside $HOME (directories, or empty files for file/socket mounts).-ensureTempHomeMountPoint :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()-ensureTempHomeMountPoint homedir temphome hostPath containerPath =- when (isUnderDir homedir containerPath) $ do- let dest = temphome </> makeRelative homedir containerPath- hostIsFile <- doesFileExist hostPath- hostIsSock <- isSocketFile hostPath- if hostIsFile || hostIsSock- then do- createDirectoryIfMissing True (takeDirectory dest)- destExists <- doesPathExist dest- unless destExists $ writeFile dest ""- else createDirectoryIfMissing True dest--ensureTempHomeVol :: FilePath -> FilePath -> String -> IO ()-ensureTempHomeVol homedir temphome spec = do- (hostPath, containerPath) <- volumePaths homedir spec- ensureTempHomeMountPoint homedir temphome hostPath containerPath---- Resolve host and container paths from a volume spec (before SELinux opts).-volumePaths :: FilePath -> String -> IO (FilePath, FilePath)-volumePaths homedir spec =- case break (== ':') spec of- (hostPart, []) -> do- p <- expandPath homedir hostPart- return (p, p)- (hostPart, _:rest') -> do- hostExp <- expandPath homedir hostPart- if isVolumePathStart rest'- then do- let containerPart = takeWhile (/= ':') rest'- containerExp <- expandPath homedir containerPart- return (hostExp, containerExp)- else return (hostExp, hostExp)---- container naming--sanitizeName :: String -> String-sanitizeName = map (\c -> if c `elem` nameChars then c else '-')- where- nameChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.-"---- Dots separate DNS labels in hostnames, so replace them for --hostname.-hostnameFromName :: String -> String-hostnameFromName = map (\c -> if c == '.' then '-' else c)--workProjectName :: FilePath -> String-workProjectName = sanitizeName . takeFileName--mkContainerName :: String -> Maybe ProjectName -> IO String-mkContainerName base mprojectname = do- case mprojectname of- Nothing -> return $ progname +=+ sanebase- Just mp ->- case mp of- Name ('^':n) -> return n- Name n -> return $ progname +=+ n- Project p -> do- projectDir <- resolveProject p- return $ progname ++ '-' : sanebase +=+ workProjectName projectDir- where- sanebase = sanitizeName base---- shell command construction--pathEnvPart :: [String] -> [String]-pathEnvPart [] = []-pathEnvPart ps =- let prefix = intercalate ":" ps- in ["PATH=\"" ++ prefix ++ ":$PATH\""]--mkInitSetup :: [String] -> String-mkInitSetup [] = ""-mkInitSetup snippets =- let content = intercalate "\\n" snippets- in "printf" +-+ shellQuote content +-+ "> /tmp" </> progname ++ "-init.sh"--mkUserCmd :: [String] -> [String] -> [String]-mkUserCmd [] inits = mkUserCmd ["bash"] inits-mkUserCmd ["bash"] (_:_) =- ["bash", "--rcfile", "/tmp" </> progname ++ "-init.sh"]-mkUserCmd com inits@(_:_) =- let initChain = intercalate " && " inits- cmdStr = initChain +-+ "&& exec" +-+ unwords (map shellQuote com)- in ["sh", "-c", cmdStr]-mkUserCmd com [] = com---- utilities--shellQuote :: String -> String-shellQuote s- | all isSafe s = s- | otherwise = "'" ++ concatMap escSQ s ++ "'"- where- isSafe c = c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_./=:@,+")- escSQ '\'' = "'\\''"- escSQ c = [c]---- | Combine two strings with a single space-infixr 4 +=+-(+=+) :: String -> String -> String-s +=+ t | lastMay s == Just '-' = s ++ t- | headMay t == Just '-' = s ++ t-s +=+ t = s ++ '-' : t--error':: String -> IO a-error' err = do- putStrLn err- exitFailure+ putStr "writing image "+ cmd_ "buildah" buildah_args
+ src/Run.hs view
@@ -0,0 +1,596 @@+{-# LANGUAGE RecordWildCards #-}++-- SPDX-License-Identifier: Apache-2.0++module Run (+ ProjectName(..),+ RunOpts(..),+ runCmd,+ (+=+),+ enterContainer,+ mkContainerName,+ resolveProject,+ workProjectName,+ needPodman+ )+where++import Control.Monad.Extra (unless, unlessM, when, whenJust, (>=>))+import Data.List.Extra (intercalate, isPrefixOf, splitOn)+import Data.Maybe (fromMaybe, isJust, isNothing)+import qualified Data.Text.Lazy as TL+import Safe (headMay, lastMay)+import SimpleCmd+import SimplePrompt (promptEnter)+import System.Console.Pretty (Color(..), color, supportsPretty)+import System.Directory (canonicalizePath, createDirectoryIfMissing,+ doesDirectoryExist, doesFileExist, doesPathExist,+ getHomeDirectory)+import System.Environment (lookupEnv)+import System.Exit (exitWith)+import System.FilePath ((</>), makeRelative, takeDirectory, takeFileName)+import System.Posix.Files (fileOwner, getFileStatus, isSocket)+import System.Posix.Process (getProcessID)+import System.Posix.Types (UserID)+import System.Posix.User (getEffectiveGroupID, getEffectiveUserID,+ getEffectiveUserName)+import System.Process (rawSystem)+++import Backup+import Config (getCapabilities, loadConfig, progname, resolveCapabilities)+import Enter+import Expand+import Script+import ShellQuote++data ProjectName = Project FilePath | Name String++data RunOpts = RunOpts+ { toolbox :: String+ , vols :: [String]+ , envs :: [String]+ , paths :: [String]+ , inits :: [String]+ , caps :: [String]+ , pull :: Bool+ , muser :: Maybe String+ , mhome :: Maybe (FilePath, Bool)+ , mproject :: Maybe (FilePath, Bool)+ , mname :: Maybe String+ , keep :: Bool+ , readonly :: Bool+ , nonetwork :: Bool+ , nosudo :: Bool+ , noskel :: Bool+ , unique :: Bool+ , podmanopts :: [String]+ , debugging :: Bool+ , dryrun :: Bool+ , command :: [String]+ }++runCmd :: RunOpts -> IO ()+runCmd (RunOpts {..}) = do+ let (mhomeDir, homeMountOpts, backupHome) = splitDirOptsMaybe mhome+ (mprojectPath, projectMountOpts, backupProject) = splitDirOptsMaybe mproject+ mprojectDir <- traverse resolveProject mprojectPath+ containerName <-+ mkContainerName toolbox $+ maybe (Project <$> mprojectPath) (Just . Name) mname+ debug containerName+ needPodman+ exists <- cmdBool "podman" ["container", "exists", containerName]+ when (keep && not unique && exists) $+ error' $ "container" +-+ containerName +-+ "already exists"+ container <-+ -- FIXME Coderabbit pointed out this could lead to race with 2 invocations+ if unique && exists+ then do+ pid <- getProcessID+ return $ containerName +=+ show pid+ else return containerName+ debug $ "container:" +-+ container+ running <-+ if unique+ then return False+ else+ if exists+ then do+ (_, out, _) <- cmdFull "podman"+ ["container", "inspect", "-f", "{{.State.Running}}", container] ""+ if take 4 out == "true"+ then return True+ else do+ putStr "start "+ cmd_ "podman" ["start", container]+ return True+ else return False+ debug $ "running:" +-+ show running+ hostHome <- getHomeDirectory >>= canonicalizePath+ debug $ "HOME:" +-+ hostHome+ if running+ then do+ let noopts = and+ [ null vols+ , null envs+ , null paths+ , null inits+ , null caps+ , isNothing mproject || isNothing mname+ , isNothing mhome+ , isNothing muser+ , not keep+ , not readonly+ , not nonetwork+ , not nosudo+ , not noskel+ , null podmanopts+ ]+ unless noopts $+ error' "cannot give options for an existing container!"+ warning "Entering existing container"+ enterContainer dryrun debugging True container command+ else do+ when backupHome $+ whenJust mhomeDir $ backupCmd dryrun False Nothing+ when backupProject $+ whenJust mprojectDir $ backupCmd dryrun False Nothing+ -- * createContainer+ mtemphome <- traverse (expandPath hostHome >=> canonicalizePath) mhomeDir+ case (mtemphome, mprojectDir) of+ (Just h, Just p) | h == p ->+ error' "--home and --project must be different directories"+ _ -> return ()+ when pull $+ cmd_ "podman" ["pull", toolbox]+ image <- do+ let eimg = progname +=+ toolbox+ exists' <- cmdBool "podman" ["image", "exists", eimg]+ if exists'+ then return eimg+ else do+ debug $ "no" +-+ eimg +-+ "image"+ exists'' <- cmdBool "podman" ["image", "exists", toolbox]+ if exists''+ then do+ debug $ "using" +-+ toolbox +-+ "image"+ return toolbox+ else error' $+ show toolbox +-+ "image not found\n" +++ "Create an image from a container with 'commit', or build/pull one"+ debug $ "image:" +-+ image+ config <- loadConfig+ let capabilities = getCapabilities config++ (extraVols, extraEnvs, extraPaths, extraInits, extraSecurityOpts) <-+ resolveCapabilities capabilities caps++ -- FIXME perhaps add --no-runuser?+ uid <- getEffectiveUserID+ gid <- getEffectiveGroupID+ let uidStr = show (fromIntegral uid :: Integer)+ gidStr = show (fromIntegral gid :: Integer)+ (haveRunuser, haveSudo, mImageUser, mPasswdHome) <-+ probeImage debugging image uid muser+ debug $ "runuser:" +-+ show haveRunuser+ debug $ "sudo:" +-+ show haveSudo+ debug $ "image user:" +-+ fromMaybe "(none)" mImageUser+ debug $ "passwd home:" +-+ fromMaybe "(none)" mPasswdHome++ username <-+ case muser of+ Just user -> return user+ Nothing -> maybe getEffectiveUserName return mImageUser+ debug $ "user:" +-+ username++ let switch = chooseSwitchUser haveRunuser haveSudo+ startAsRoot =+ canSwitchUser switch+ || isNothing mhome && isNothing muser && isNothing mImageUser+ stayAsRoot = startAsRoot && not (canSwitchUser switch)+ (containerHome, overrideHome) =+ if stayAsRoot+ then ("/root", False)+ else (fromMaybe hostHome mPasswdHome, isNothing mPasswdHome)+ debug $ "switch:" +-+ switchLabel switch+ debug $ "container home:" +-+ containerHome++ homeVol <-+ case mtemphome of+ Just temphome -> do+ unlessM (doesDirectoryExist temphome) $ do+ warning $ temphome +-+ "does not exist"+ promptEnter "Press Enter to create it and continue"+ createDirectoryIfMissing True temphome+ -- Mount targets under container $HOME land inside the temp home+ -- volume; create them as the user so podman does not leave+ -- root-owned paths.+ case mprojectDir of+ Just p -> ensureTempHomeMountPoint containerHome temphome p p+ Nothing -> return ()+ mapM_ (ensureTempHomeVol hostHome containerHome temphome)+ (vols ++ extraVols)+ return [temphome ++ ":" ++ containerHome ++ maybeOpts homeMountOpts]+ Nothing -> return []++ projectVol <-+ case mprojectDir of+ Just d -> do+ exists' <- doesDirectoryExist d+ if exists'+ then return [d ++ ':' : d ++ maybeOpts projectMountOpts]+ else error' $ "project dir not found:" +-+ d+ Nothing -> return []+ -- mounting real $HOME needs label=disable (no :z) on Fedora/SELinux.+ -- --home DIR still uses :z (shared type); pin MCS to s0 so podman does+ -- not stamp the container's private categories on the host tree.+ let mountsRealHome =+ Just hostHome == mtemphome || Just hostHome == mprojectDir+ securityOpts =+ extraSecurityOpts +++ ["label=disable" | mountsRealHome,+ "label=disable" `notElem` extraSecurityOpts] +++ ["label=level:s0" | isJust mtemphome && not mountsRealHome,+ "label=level:s0" `notElem` extraSecurityOpts,+ "label=disable" `notElem` extraSecurityOpts]+ volumes = homeVol ++ vols ++ extraVols ++ projectVol+ envVars = envs ++ extraEnvs+ allinits = inits ++ extraInits+ allpaths <- mapM (expandContainerPath containerHome) (paths ++ extraPaths)+ let userCmd =+ let envParts =+ (if overrideHome then (("HOME=" ++ containerHome) :) else id) $+ pathEnvPart allpaths+ userCmdParts = mkUserCmd command allinits+ in+ (if null envParts then id else (("env" +-+ unwords envParts) +-+)) $+ unwords $ map shellQuote userCmdParts++ -- mkdir+chown when not bind-mounting --home. A passwd home may+ -- already exist but not be writable (committed toolbox image).+ setupArgs =+ Setup nosudo noskel (TL.pack username) progname (isNothing mhome) (TL.pack containerHome) mprojectDir++ setupParts =+ let setup = setupScript debugging switch haveSudo setupArgs+ in [setup | not (null setup)] +++ [mkInitSetup allinits | not (null allinits)]+ finalCmd =+ case switchUserArgs switch username of+ [] -> "exec" +-+ userCmd+ args -> "exec" +-+ unwords args +-+ userCmd+ execScript =+ (if debugging then ("set -x &&" +-+) else id) $+ if null setupParts+ then finalCmd+ else intercalate " && " $ setupParts ++ [finalCmd]++ when ("label=disable" `elem` securityOpts) $+ warning "SELinux labeling disabled for this container (label=disable)"+ unless dryrun $ debug $ "setup:" +-+ execScript+ mounts <- mapM (addSelinuxLabel hostHome containerHome) volumes+ tzMounts <- hostTimezoneMount+ debug $ "timezone:" +-+ show tzMounts+ -- C.UTF-8 is in base images; host LANG (e.g. en_US.UTF-8) often is not.+ -- -e LANG=C or another locale overrides.+ let langPart =+ let userLang =+ any (\e -> e == "LANG" || "LANG=" `isPrefixOf` e) envVars+ in if userLang then [] else langEnvArgs++ -- Only pass --workdir when that path already exists at start:+ -- crun will not create it, and podman then fails.+ -- Existing: --project/--home mounts, /root, the image passwd home,+ -- or a --read-only tmpfs on $HOME. Host $HOME is mkdir'd later.+ let workdirTarget = fromMaybe containerHome mprojectDir+ workdirReady =+ isJust mprojectDir+ || isJust mhome+ || stayAsRoot+ || isJust mPasswdHome+ || (readonly && isNothing mtemphome)+ workdirPart =+ if workdirReady+ then ["--workdir", workdirTarget]+ else []+ args = "run" :+ [ "--rm" | not keep] +++ [ "-it",+ "--userns=keep-id",+ "--name", container,+ "--hostname", hostnameFromName container,+ "-e", "TERM",+ "-e", "COLORTERM"]+ ++ langPart+ ++ ["-e=HOME=" ++ containerHome | overrideHome]+ -- keep-id copies --workdir into the passwd home, defaulting+ -- to "/" ; set the real home when the image has no passwd dir+ ++ (if overrideHome+ then ["--passwd-entry",+ intercalate ":"+ [username, "*", uidStr, gidStr, "",+ containerHome, "/bin/sh"]]+ else [])+ ++ (if startAsRoot+ then ["--user=root"]+ else ["--user=" ++ username])+ ++ workdirPart+ ++ (if readonly+ then ["--read-only", "--tmpfs", "/tmp", "--tmpfs", "/run"]+ ++ case mtemphome of+ Nothing -> ["--tmpfs", containerHome]+ Just _ -> []+ else [])+ ++ (if nonetwork then ["--net", "none"] else [])+ ++ concatMap (\s -> ["--security-opt", s]) securityOpts+ ++ concatMap (\m -> ["-v", m]) (tzMounts ++ mounts)+ ++ concatMap (\e -> ["-e", e]) envVars+ ++ podmanopts+ ++ [image, "sh", "-c", execScript]++ when (dryrun || debugging) $ do+ useColor <- do+ pretty <- supportsPretty+ noColor <- lookupEnv "NO_COLOR"+ return $ pretty && maybe True null noColor+ cmdN "podman" $ map (colorizeOpt useColor) args+ unless dryrun $ do+ ret <- rawSystem "podman" args+ exitWith ret+ where+ debug msg = when debugging $ warning $ "debug:" +-+ msg++colorizeOpt :: Bool -> String -> String+colorizeOpt useColor arg+ | "-" `isPrefixOf` arg =+ case break (== '=') arg of+ (flag, '=':val) -> tint flag ++ '=' : shellQuote val+ (flag, _) -> tint flag+ | otherwise = shellQuote arg+ where+ tint s = if useColor then color Cyan s else s++resolveProject :: FilePath -> IO FilePath+resolveProject dir = do+ homedir <- getHomeDirectory >>= canonicalizePath+ finaldir <- expandPath homedir dir >>= canonicalizePath+ when (finaldir == homedir) $+ warning "mounting $HOME as project (consider a subdirectory)"+ return finaldir++mkContainerName :: String -> Maybe ProjectName -> IO String+mkContainerName base mprojectname = do+ case mprojectname of+ Nothing -> return $ progname +=+ sanebase+ Just mp ->+ case mp of+ Name ('^':n) -> return n+ Name n -> return $ progname +=+ n+ Project p -> do+ projectDir <- resolveProject p+ return $ progname ++ '-' : sanebase +=+ workProjectName projectDir+ where+ sanebase = sanitizeName base++-- DIR[:opts] for --home/--project (opts must not look like a path).+splitDirOpts :: String -> (FilePath, Maybe String)+splitDirOpts spec =+ case break (== ':') spec of+ (dir, []) -> (dir, Nothing)+ (dir, _:rest)+ | isVolumePathStart rest -> (spec, Nothing)+ | otherwise -> (dir, Just rest)++splitDirOptsMaybe :: Maybe (String,Bool)+ -> (Maybe FilePath, Maybe String, Bool)+splitDirOptsMaybe Nothing = (Nothing, Nothing, False)+splitDirOptsMaybe (Just (s,backup)) =+ let (dir, opts) = splitDirOpts s+ in (Just dir, opts, backup)++maybeOpts :: Maybe String -> String+maybeOpts Nothing = ""+maybeOpts (Just o) = ':' : o++isVolumePathStart :: String -> Bool+isVolumePathStart ('/':_) = True+isVolumePathStart ('~':_) = True+isVolumePathStart ('$':_) = True+isVolumePathStart _ = False++-- | Combine two strings with a dash+infixr 4 +=++(+=+) :: String -> String -> String+s +=+ t | lastMay s == Just '-' = s ++ t+ | headMay t == Just '-' = s ++ t+s +=+ t = s ++ '-' : t++probeImage :: Bool -> String -> UserID -> Maybe String+ -> IO ( Bool -- runuser?+ , Bool -- sudo?+ , Maybe String -- image passwd username+ , Maybe FilePath -- image passwd homedir+ )+probeImage dbg image uid muser = do+ let uidStr = show (fromIntegral uid :: Integer)+ lookupSh = maybe (passwdEntryForUidSh uidStr) passwdEntryForNameSh muser+ when dbg $ warning $ "checking for runuser, sudo and" +-++ maybe ("uid" +-+ uidStr) ("user" +-+) muser+ let sh = unlines+ [ cmdPresentSh "runuser"+ , cmdPresentSh "sudo"+ , lookupSh+ ]+ -- Probe image's /etc/passwd (without keep-id to avoid host-injection)+ args = ["run", "--rm", "--pull=never", "--entrypoint", "/bin/sh", image, "-c", sh]+ when dbg $ putStrLn $ unwords ("podman" : map shellQuote args)+ (_, out, _) <- cmdFull "podman" args ""+ return $+ case lines out of+ (r:s:n:h:_) -> (r == "1", s == "1", nonEmpty n, usablePasswdHome h)+ (r:s:n:_) -> (r == "1", s == "1", nonEmpty n, Nothing)+ (r:s:_) -> (r == "1", s == "1", Nothing, Nothing)+ (r:_) -> (r == "1", False, Nothing, Nothing)+ [] -> (False, False, Nothing, Nothing)+ where+ nonEmpty s = if null s then Nothing else Just s++cmdPresentSh :: String -> String+cmdPresentSh c =+ "command -v " ++ shellQuote c ++ " >/dev/null 2>&1 && echo 1 || echo 0"++-- Pre-create a bind mount point under temp home when the container path is+-- inside $HOME (directories, or empty files for file/socket mounts).+ensureTempHomeMountPoint :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()+ensureTempHomeMountPoint homedir temphome hostPath containerPath =+ when (isUnderDir homedir containerPath) $ do+ let dest = temphome </> makeRelative homedir containerPath+ hostIsFile <- doesFileExist hostPath+ hostIsSock <- isSocketFile hostPath+ if hostIsFile || hostIsSock+ then do+ -- FIXME maybe confirm?+ createDirectoryIfMissing True (takeDirectory dest)+ destExists <- doesPathExist dest+ unless destExists $ writeFile dest ""+ else+ -- FIXME confirm?+ createDirectoryIfMissing True dest++ensureTempHomeVol :: FilePath -> FilePath -> FilePath -> String -> IO ()+ensureTempHomeVol hostHome containerHome temphome spec = do+ (hostPath, containerPath) <- volumePaths hostHome containerHome spec+ ensureTempHomeMountPoint containerHome temphome hostPath containerPath++-- Resolve host and container paths from a volume spec (before SELinux opts).+volumePaths :: FilePath -> FilePath -> String -> IO (FilePath, FilePath)+volumePaths hostHome containerHome spec =+ case break (== ':') spec of+ (hostPart, []) -> do+ hostExp <- expandPath hostHome hostPart+ containerExp <- expandContainerPath containerHome hostPart+ return (hostExp, containerExp)+ (hostPart, _:rest') -> do+ hostExp <- expandPath hostHome hostPart+ if isVolumePathStart rest'+ then do+ let containerPart = takeWhile (/= ':') rest'+ containerExp <- expandContainerPath containerHome containerPart+ return (hostExp, containerExp)+ else do+ containerExp <- expandContainerPath containerHome hostPart+ return (hostExp, containerExp)++-- shell command construction++pathEnvPart :: [String] -> [String]+pathEnvPart [] = []+pathEnvPart ps =+ let prefix = intercalate ":" ps+ in ["PATH=\"" ++ prefix ++ ":$PATH\""]++mkInitSetup :: [String] -> String+mkInitSetup [] = ""+mkInitSetup snippets =+ let content = intercalate "\\n" snippets+ in "printf" +-+ shellQuote content +-+ "> /tmp" </> progname ++ "-init.sh"++mkUserCmd :: [String] -> [String] -> [String]+mkUserCmd [] inits = mkUserCmd ["bash"] inits+mkUserCmd ["bash"] (_:_) =+ ["bash", "--rcfile", "/tmp" </> progname ++ "-init.sh"]+mkUserCmd com inits@(_:_) =+ let initChain = intercalate " && " inits+ cmdStr = initChain +-+ "&& exec" +-+ unwords (map shellQuote com)+ in ["sh", "-c", cmdStr]+mkUserCmd com [] = com++-- SELinux labeling++-- Rootless podman cannot lsetxattr on files owned by another uid (e.g. /etc/*)+-- FIXME rather return Mount type or triple?+addSelinuxLabel :: FilePath -> FilePath -> String -> IO String+addSelinuxLabel hostHome containerHome spec =+ case break (== ':') spec of+ (hostPart, []) -> do+ hostExp <- expandPath hostHome hostPart+ containerExp <- expandContainerPath containerHome hostPart+ requireVolumeHost hostExp+ skipLabel <- shouldSkipLabel hostExp+ return $ hostExp ++ ":" ++ containerExp ++ if skipLabel then "" else ":z"+ (hostPart, _:rest') -> do+ hostExp <- expandPath hostHome hostPart+ requireVolumeHost hostExp+ let (containerPart, optsPart)+ | isVolumePathStart rest' =+ case break (== ':') rest' of+ (c, []) -> (c, Nothing)+ (c, _:o) -> (c, Just o)+ | otherwise = (hostPart, if null rest' then Nothing else Just rest')+ containerExp <- expandContainerPath containerHome containerPart+ skipLabel <- shouldSkipLabel hostExp+ let labeled = case optsPart of+ Nothing ->+ if skipLabel+ then hostExp ++ ":" ++ containerExp+ else hostExp ++ ":" ++ containerExp ++ ":z"+ Just o ->+ let flags = splitOn "," o+ in if skipLabel || "z" `elem` flags || "Z" `elem` flags+ || "O" `elem` flags+ then hostExp ++ ":" ++ containerExp ++ ":" ++ o+ else hostExp ++ ":" ++ containerExp ++ ":" ++ o ++ ",z"+ return labeled+ where+ -- Skip auto :z for sockets, real $HOME (uses label=disable), and paths we+ -- cannot relabel (rootless lsetxattr fails on files owned by another user)+ shouldSkipLabel hostExp = do+ sockFile <- isSocketFile hostExp+ selfOwned <- ownedBySelf hostExp+ return $ sockFile || hostExp == hostHome || not selfOwned++-- later possibly also support /etc/timezone+hostTimezoneMount :: IO [String]+hostTimezoneMount = do+ let localtime = "/etc/localtime"+ found <- doesFileExist localtime+ return $+ [localtime ++ ':' : localtime ++ ":ro" | found]++-- # Naming++-- Dots separate DNS labels in hostnames, so replace them for --hostname.+hostnameFromName :: String -> String+hostnameFromName = map (\c -> if c == '.' then '-' else c)++workProjectName :: FilePath -> String+workProjectName = sanitizeName . takeFileName++sanitizeName :: String -> String+sanitizeName = map (\c -> if c `elem` nameChars then c else '-')+ where+ nameChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.-"++-- True if path is base or a subdirectory of base (avoids /home/foo vs /home/foobar).+isUnderDir :: FilePath -> FilePath -> Bool+isUnderDir base path =+ path == base || (base ++ "/") `isPrefixOf` path++requireVolumeHost :: FilePath -> IO ()+requireVolumeHost path = do+ exists <- doesPathExist path+ unless exists $+ error' $ "volume host path not found:" +-+ path++isSocketFile :: FilePath -> IO Bool+isSocketFile path = isSocket <$> getFileStatus path++ownedBySelf :: FilePath -> IO Bool+ownedBySelf path = do+ uid <- getEffectiveUserID+ st <- getFileStatus path+ return $ fileOwner st == uid++needPodman :: IO ()+needPodman = needProgram "podman"
src/Script.hs view
@@ -1,39 +1,93 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules #-} module Script (- installScript+ SwitchUser(..),+ chooseSwitchUser,+ canSwitchUser,+ switchUserArgs,+ switchLabel,+ setupScript,+ Setup(..) ) where +import Control.Monad (unless, when) import Control.Monad.Shell+import Data.Maybe (isNothing) import qualified Data.Text.Lazy as T+import System.FilePath ((</>)) import System.Posix.IO default (T.Text) -installScript :: Bool -> Bool -> T.Text-installScript dbg sudo =- T.replace "\t" " " . linearScript $ do- unlessCmd (haveCmd "runuser") $ do- let pkgs = "util-linux" : ["sudo" | sudo]- installargs = ["install", "-y"] ++ pkgs- run "echo" $ T.pack "installing:" : pkgs- ifCmd (haveCmd "dnf")- (runHide "dnf" installargs- -||-- run "true" [])- (whenCmd (haveCmd "apt-get") $- runHide "apt-get" ["update"]- -&&-- runHide "apt-get" installargs- -||-- run "true" [])+data SwitchUser = Runuser | Sudo | None++chooseSwitchUser :: Bool -> Bool -> SwitchUser+chooseSwitchUser True _ = Runuser+chooseSwitchUser False True = Sudo+chooseSwitchUser _ _ = None++canSwitchUser :: SwitchUser -> Bool+canSwitchUser None = False+canSwitchUser _ = True++-- argv prefix; empty for None+switchUserArgs :: SwitchUser -> String -> [String]+switchUserArgs Runuser u = ["runuser", "-u", u, "--"]+switchUserArgs Sudo u = ["sudo", "-n", "--preserve-env", "-u", u, "--"]+switchUserArgs None _ = []++switchLabel :: SwitchUser -> String+switchLabel Runuser = "runuser"+switchLabel Sudo = "sudo"+switchLabel None = "none"++data Setup = Setup+ { nosudo :: Bool+ , noskel :: Bool+ , username :: T.Text+ , program :: String+ , createhome :: Bool+ , homedir :: T.Text+ , mprojectDir :: Maybe FilePath+ }++setupScript :: Bool -> SwitchUser -> Bool -> Setup -> String+setupScript dbg switch haveSudo (Setup {..}) =+ T.unpack . T.replace "\t" " " . linearScript $+ sudoSetup >> homeSetup where redir s dest =- if dbg then s else s |> (dest :: String) &stdError>&stdOutput-+ if dbg then s else s |> (dest :: String) &stdError>&stdOutput runHide c args = run c args `redir` "/dev/null"+ -- haveCmd c = runHide "command" ["-v",c] - haveCmd c = runHide "command" ["-v",c]+ sudoSetup =+ when haveSudo $+ unless nosudo $+ let sudoers = "/etc/sudoers.d" in+ whenCmd (test $ TDirExists sudoers) $ do+ runHide "echo" [username, "ALL=(ALL) NOPASSWD:ALL"] `redir` (sudoers </> program)+ runHide "chmod" ["440", T.pack sudoers]++ homeSetup = do+ when createhome $ do+ runHide "mkdir" ["-p", homedir]+ runHide "chown" [username, homedir]+ unless noskel $+ when (canSwitchUser switch) $+ whenCmd+ (test (TDirExists homedir)+ -&&-+ test (TDirExists (T.pack "/etc/skel"))) $+ let cpArgs = ["-a", "--update=none", "/etc/skel/.", homedir <> "/"]+ in case map T.pack $ switchUserArgs switch (T.unpack username) of+ prog:args -> runHide prog $ args ++ "cp" : cpArgs+ [] -> return ()+ when (isNothing mprojectDir && createhome) $+ runHide "cd" [homedir]
+ src/ShellQuote.hs view
@@ -0,0 +1,12 @@+-- SPDX-License-Identifier: Apache-2.0++module ShellQuote (shellQuote) where++shellQuote :: String -> String+shellQuote s+ | all isSafe s = s+ | otherwise = "'" ++ concatMap escSQ s ++ "'"+ where+ isSafe c = c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_./=:@,+")+ escSQ '\'' = "'\\''"+ escSQ c = [c]
+ test/EncapsuleTest.hs view
@@ -0,0 +1,149 @@+-- SPDX-License-Identifier: Apache-2.0++module EncapsuleTest (+ encapsule,+ encapsuleChecked,+ dryrun,+ debugField,+ commandOutputLines,+ hasTTY,+ liveEnabled,+ requireLive,+ ubuntuImg,+ fedoraImg,+ hostUid,+ hostUser,+ requireImage,+ withGenericImage,+ ) where++import Control.Exception (IOException, try)+import Control.Monad (unless)+import Data.List (isInfixOf, isPrefixOf)+import Data.Maybe (fromMaybe, listToMaybe)+import System.Environment (lookupEnv)+import System.Exit (ExitCode(..))+import System.Posix.IO (stdInput)+import System.Posix.Terminal (queryTerminal)+import System.Posix.User (getEffectiveUserID, getEffectiveUserName)+import System.Process (readProcessWithExitCode)+import Test.Hspec (pendingWith)++-- | Run encapsule with args; combined stdout and stderr.+encapsule :: [String] -> IO String+encapsule args = do+ exe <- fromMaybe "encapsule" <$> lookupEnv "ENCAPSULE"+ (_, out, err) <- readProcessWithExitCode exe args ""+ return $ out ++ err++-- | Like 'encapsule', but fail if the process exits non-zero.+encapsuleChecked :: [String] -> IO String+encapsuleChecked args = do+ exe <- fromMaybe "encapsule" <$> lookupEnv "ENCAPSULE"+ (code, out, err) <- readProcessWithExitCode exe args ""+ let combined = out ++ err+ case code of+ ExitSuccess -> return combined+ ExitFailure n ->+ fail $ "encapsule failed (" ++ show n ++ "): " ++ combined++dryrun :: [String] -> IO String+dryrun args = encapsule $ ["run", "--dryrun", "--debug", "--no-skel"] ++ args++-- | Non-empty output lines that are not podman/log noise (e.g. "not a TTY").+commandOutputLines :: String -> [String]+commandOutputLines out =+ [ l+ | l <- map (filter (/= '\r')) (lines out)+ , not (null l)+ , not (isNoise l)+ ]+ where+ isNoise l =+ "level=warning" `isInfixOf` l+ || "not a TTY" `isInfixOf` l+ || "msg=" `isInfixOf` l++debugField :: String -> String -> Maybe String+debugField out key =+ let prefix = "debug: " ++ key ++ ": "+ in listToMaybe+ [ filter (/= '\r') rest+ | l <- lines out+ , Just rest <- [afterInfix prefix l]+ ]++afterInfix :: String -> String -> Maybe String+afterInfix p s+ | p `isPrefixOf` s = Just $ drop (length p) s+ | p `isInfixOf` s =+ let n = length p+ go i+ | i + n > length s = Nothing+ | take n (drop i s) == p = Just (drop (i + n) s)+ | otherwise = go (i + 1)+ in go 0+ | otherwise = Nothing++hasPodman :: IO Bool+hasPodman = do+ r <- try (readProcessWithExitCode "podman" ["--version"] "")+ :: IO (Either IOException (ExitCode, String, String))+ case r of+ Left _ -> return False+ Right (code, _, _) -> return $ code == ExitSuccess++imageExists :: String -> IO Bool+imageExists img = do+ (code, _, _) <- readProcessWithExitCode "podman" ["image", "exists", img] ""+ return $ code == ExitSuccess++hasTTY :: IO Bool+hasTTY = queryTerminal stdInput++liveEnabled :: IO Bool+liveEnabled = do+ env <- lookupEnv "ENCAPSULE_LIVE"+ return $ env == Just "1"++requireLive :: IO ()+requireLive = do+ tty <- hasTTY+ forced <- liveEnabled+ unless (tty || forced) $+ pendingWith "not a TTY (set ENCAPSULE_LIVE=1 to force)"++ubuntuImg :: IO String+ubuntuImg = fromMaybe "ubuntu:latest" <$> lookupEnv "ENCAPSULE_TEST_UBUNTU"++fedoraImg :: IO String+fedoraImg = fromMaybe "fedora:latest" <$> lookupEnv "ENCAPSULE_TEST_FEDORA"++hostUid :: IO String+hostUid = show . toInteger <$> getEffectiveUserID++hostUser :: IO String+hostUser = getEffectiveUserName++requirePodman :: IO ()+requirePodman = do+ ok <- hasPodman+ unless ok $ pendingWith "podman not found"++requireImage :: String -> IO ()+requireImage img = do+ requirePodman+ ok <- imageExists img+ unless ok $ pendingWith $ "no " ++ img ++ " image"++withGenericImage :: (String -> IO ()) -> IO ()+withGenericImage act = do+ requirePodman+ u <- ubuntuImg+ f <- fedoraImg+ mu <- imageExists u+ mf <- imageExists f+ case (mu, mf) of+ (True, _) -> act u+ (_, True) -> act f+ _ -> pendingWith $ "no " ++ u ++ " or " ++ f ++ " image"
+ test/Spec.hs view
@@ -0,0 +1,271 @@+-- SPDX-License-Identifier: Apache-2.0++module Main (main) where++import Control.Exception (finally)+import Control.Monad (unless)+import Data.List (isInfixOf)+import Data.Maybe (fromMaybe)+import System.Directory (canonicalizePath, createDirectoryIfMissing,+ removeDirectoryRecursive)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.Posix.Process (getProcessID)+import System.Posix.Temp (mkdtemp)+import System.Process (readProcessWithExitCode)+import Test.Hspec++import EncapsuleTest++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "dryrun" $ do+ it "podman run has keep-id, TERM & LANG" $+ withGenericImage $ \img -> do+ out <- dryrun [img]+ out `shouldContain` "podman run"+ out `shouldContain` "--userns=keep-id"+ out `shouldContain` "-e TERM"+ out `shouldContain` "-e LANG=C.UTF-8"++ it "applies --name" $+ withGenericImage $ \img -> do+ pid <- getProcessID+ let n = "testhost" ++ show pid+ out <- dryrun ["--name", n, img]+ out `shouldContain` ("--name encapsule-" ++ n)++ it "applies --name ^ without encapsule- prefix" $+ withGenericImage $ \img -> do+ out <- dryrun ["--name", "^bare-encap-test", img]+ out `shouldContain` "--name bare-encap-test"++ it "sets --project workdir and container name" $+ withGenericImage $ \img ->+ withTestDir $ \tmp -> do+ let proj = tmp </> "proj"+ createDirectoryIfMissing True proj+ out <- dryrun ["--project", proj, img]+ out `shouldContain` "--workdir"+ out `shouldContain` "--name encapsule-"+ out `shouldContain` "-proj"++ it "uses runuser or sudo to switch with --user root" $+ withGenericImage $ \img -> do+ out <- dryrun [img]+ case debugField out "switch" of+ Just "none" -> pendingWith $ img ++ " has no runuser or sudo"+ _ -> do+ out' <- dryrun ["--user", "root", img]+ assertUserSwitch out' "root"++ describe "ubuntu" $ do+ it "uses ubuntu user and passwd home for UID 1000" $ do+ img <- ubuntuImg+ requireImage img+ uid <- hostUid+ unless (uid == "1000") $+ pendingWith $ "host uid is " ++ uid ++ ", not 1000"+ user <- hostUser+ out <- dryrun [img]+ case debugField out "image user" of+ Just "ubuntu" -> do+ assertUserSwitch out "ubuntu"+ out `shouldNotContain` ("runuser -u " ++ user)+ out `shouldContain` "--workdir /home/ubuntu"+ case debugField out "HOME" of+ Just hosthome ->+ out `shouldNotContain` ("-e=HOME=" ++ hosthome)+ Nothing -> expectationFailure "ubuntu debug HOME line"+ debugField out "container home" `shouldBe` Just "/home/ubuntu"+ other ->+ pendingWith $ "image user is " ++ fromMaybe "unknown" other ++ ", not ubuntu"++ it "mounts --home on /home/ubuntu" $ do+ img <- ubuntuImg+ requireImage img+ uid <- hostUid+ unless (uid == "1000") $+ pendingWith $ "host uid is " ++ uid ++ ", not 1000"+ out0 <- dryrun [img]+ unless (debugField out0 "image user" == Just "ubuntu") $+ pendingWith "image user is not ubuntu"+ withTestDir $ \tmp -> do+ let homeTmp = tmp </> "home"+ createDirectoryIfMissing True homeTmp+ homeAbs <- canonicalizePath homeTmp+ let mHost = debugField out0 "HOME"+ out <- dryrun ["--home", homeTmp, img]+ out `shouldContain` (homeAbs ++ ":/home/ubuntu")+ out `shouldContain` "label=level:s0"+ case mHost of+ Just h -> out `shouldNotContain` (homeAbs ++ ":" ++ h)+ Nothing -> return ()++ it "live $HOME is /home/ubuntu" $ do+ img <- ubuntuImg+ requireImage img+ uid <- hostUid+ unless (uid == "1000") $+ pendingWith $ "host uid is " ++ uid ++ ", not 1000"+ out0 <- dryrun [img]+ unless (debugField out0 "image user" == Just "ubuntu") $+ pendingWith "image user is not ubuntu"+ assertLiveHome "ubuntu" img "/home/ubuntu"++ describe "fedora" $ do+ it "falls back to host user and HOME when passwd has no UID" $ do+ img <- fedoraImg+ requireImage img+ user <- hostUser+ out <- dryrun [img]+ case debugField out "image user" of+ Just "(none)" -> do+ debugField out "user" `shouldBe` Just user+ debugField out "passwd home" `shouldBe` Just "(none)"+ case (debugField out "switch", debugField out "HOME") of+ (Just "none", _) ->+ pendingWith "fedora image has no runuser or sudo"+ (_, Just hosthome) -> do+ assertUserSwitch out user+ out `shouldContain` ("-e=HOME=" ++ hosthome)+ out `shouldNotContain` ("--workdir " ++ hosthome)+ out `shouldContain` "--passwd-entry"+ out `shouldContain` (":" ++ hosthome ++ ":/bin/sh")+ (_, Nothing) ->+ expectationFailure "fedora debug HOME line"+ other ->+ pendingWith $ "image has uid user " ++ fromMaybe "unknown" other++ it "live $HOME is the host home" $ do+ img <- fedoraImg+ requireImage img+ out0 <- dryrun [img]+ case debugField out0 "image user" of+ Just "(none)" ->+ case (debugField out0 "switch", debugField out0 "container home") of+ (Just "none", _) ->+ pendingWith "fedora image has no runuser or sudo"+ (_, Just home) ->+ assertLiveHome "fedora" img home+ (_, Nothing) ->+ expectationFailure "fedora debug container home line"+ other ->+ pendingWith $ "image has uid user " ++ fromMaybe "unknown" other++ describe "sudo" $ do+ it "writes sudoers when sudo is present, skips when not" $+ withGenericImage $ \img -> do+ out <- dryrun [img]+ case debugField out "sudo" of+ Just "True" -> do+ out `shouldContain` "NOPASSWD:ALL"+ outNo <- dryrun ["--no-sudo", img]+ outNo `shouldNotContain` "NOPASSWD:ALL"+ Just "False" -> do+ out `shouldNotContain` "NOPASSWD:ALL"+ outNo <- dryrun ["--no-sudo", img]+ outNo `shouldNotContain` "NOPASSWD:ALL"+ other ->+ expectationFailure $+ "debug sudo line for " ++ img ++ " (got: " +++ show other ++ ")"++ describe "commit" $ do+ it "offers --name" $ do+ out <- encapsule ["commit", "--help"]+ out `shouldContain` "-n,--name NAME"++ it "names the image encapsule-CONTAINER by default" $+ withScratchContainer $ \cname -> do+ out <- encapsule ["commit", "--dryrun", cname]+ out `shouldContain` "buildah commit"+ out `shouldContain` ("encapsule-" ++ cname)++ it "applies --name to the encapsule image" $+ withScratchContainer $ \cname -> do+ pid <- getProcessID+ let n = "commitname" ++ show pid+ out <- encapsule ["commit", "--dryrun", "--name", n, cname]+ out `shouldContain` ("encapsule-" ++ n)++ it "applies --name ^ without encapsule- prefix" $+ withScratchContainer $ \cname -> do+ out <- encapsule ["commit", "--dryrun", "--name", "^bare-encap-img", cname]+ out `shouldContain` "bare-encap-img"+ out `shouldNotContain` "encapsule-bare-encap-img"++ describe "live" $ do+ it "runs id -un in the container" $+ withGenericImage $ \img -> do+ requireLive+ pid <- getProcessID+ let name = "^encap-live-" ++ show pid+ out <- encapsule+ ["run", "--no-skel", "--name", name, img, "--", "id", "-un"]+ let names = commandOutputLines out+ ttyWarn = "not a TTY" `isInfixOf` out+ uid <- hostUid+ uimg <- ubuntuImg+ let mUser+ | img == uimg && uid == "1000" = Just "ubuntu"+ | otherwise = Nothing+ case (names, mUser) of+ ([], _)+ | ttyWarn -> pendingWith "not a TTY"+ | otherwise -> expectationFailure "live run produced no command output"+ (ns, Just u) -> ns `shouldContain` [u]+ (ns, Nothing) -> last ns `shouldSatisfy` (not . null)++withTestDir :: (FilePath -> IO a) -> IO a+withTestDir act = do+ d <- mkdtemp "/tmp/encapsule-test-XXXXXX"+ act d `finally` removeDirectoryRecursive d++withScratchContainer :: (String -> IO ()) -> IO ()+withScratchContainer act =+ withGenericImage $ \img -> do+ (code, out, err) <- readProcessWithExitCode "podman"+ ["create", img, "true"] ""+ unless (code == ExitSuccess) $+ pendingWith $ "podman create failed: " ++ err+ case lines out of+ cid:_ | not (null cid) ->+ act cid `finally` do+ _ <- readProcessWithExitCode "podman" ["rm", "-f", cid] ""+ return ()+ _ -> pendingWith "podman create produced no id"++assertLiveHome :: String -> String -> String -> IO ()+assertLiveHome tag img expected = do+ requireLive+ pid <- getProcessID+ let name = "^encap-home-" ++ tag ++ "-" ++ show pid+ out <- encapsuleChecked+ ["run", "--name", name, img, "--",+ "sh", "-c", "printf '%s\\n%s\\n' \"$HOME\" \"$(pwd)\""]+ let got = commandOutputLines out+ ttyWarn = "not a TTY" `isInfixOf` out+ case got of+ []+ | ttyWarn -> pendingWith "not a TTY"+ | otherwise -> expectationFailure "live run produced no command output"+ _ -> do+ got `shouldContain` [expected]+ last got `shouldBe` expected++assertUserSwitch :: String -> String -> Expectation+assertUserSwitch out user =+ case debugField out "switch" of+ Just "runuser" -> do+ out `shouldContain` ("runuser -u " ++ user)+ out `shouldContain` "--user=root"+ Just "sudo" -> do+ out `shouldContain` ("sudo -n --preserve-env -u " ++ user)+ out `shouldContain` "--user=root"+ Just "none" -> pendingWith "image has no runuser or sudo"+ other ->+ expectationFailure $ "debug switch line (got: " ++ show other ++ ")"