diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 diff --git a/encapsule.cabal b/encapsule.cabal --- a/encapsule.cabal +++ b/encapsule.cabal @@ -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 diff --git a/src/Backup.hs b/src/Backup.hs new file mode 100644 --- /dev/null +++ b/src/Backup.hs @@ -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 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -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 diff --git a/src/Enter.hs b/src/Enter.hs new file mode 100644 --- /dev/null +++ b/src/Enter.hs @@ -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"] diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,8 @@ +module Error (error') where + +import System.Exit (exitFailure) + +error':: String -> IO a +error' err = do + putStrLn err + exitFailure diff --git a/src/Expand.hs b/src/Expand.hs new file mode 100644 --- /dev/null +++ b/src/Expand.hs @@ -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') diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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-.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 diff --git a/src/Run.hs b/src/Run.hs new file mode 100644 --- /dev/null +++ b/src/Run.hs @@ -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" diff --git a/src/Script.hs b/src/Script.hs --- a/src/Script.hs +++ b/src/Script.hs @@ -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] diff --git a/src/ShellQuote.hs b/src/ShellQuote.hs new file mode 100644 --- /dev/null +++ b/src/ShellQuote.hs @@ -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] diff --git a/test/EncapsuleTest.hs b/test/EncapsuleTest.hs new file mode 100644 --- /dev/null +++ b/test/EncapsuleTest.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 ++ ")"