diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,47 @@ +# encapsule releases + +## 0.3 (2026-07-20) +- project renamed from constrained-toolbox +- rename `--persistent` to `--keep` +- add `--list` command to show encapsule containers and images +- add `--no-sudo` to remove sudo from the container +- check toolbox container exists before buildah commit +- support running container images directly (name:tag) +- add `--name` option +- add `--debug` flag for verbose startup output +- use `--name ^...` to reference a full container name explicitly +- export TERM and COLORTERM +- `--delete` and commit image now respect --dryrun +- use shell-monad for installSetup Script +- installScript now respects `--no-sudo` and outputs "installing" +- use xdg-basedir for config file +- error for `--project`/`--home` on HOME +- `--project` now names the container after the project directory too, + so different projects can run concurrently in separate containers +- add `--podman-opt` to pass options directly to podman + +## 0.2.1 (2026-07-17) +- add --delete container command +- handle missing container gracefully in --stop and --remove +- default to ephemeral containers again, use --persistent to keep + +## 0.2 (2026-07-16) +- add `--home` option to mount a directory as a writable home +- name the container and exec into it if already running +- add `--unique` option to run a separate container instance +- make home directory writable and workdir by default +- change `--delete` to `--delete-image` standalone command +- add `--ephemeral`, restart stopped containers +- error for unused options when joining running container +- add --stop command + +## 0.1 (2026-07-03) +- initial release with `--delete` and `--project` options +- defaults to :z shared bind mounts +- `--caps` to list user's defined capabilities +- wayland: fix socket handling in SELinux labeling +- add `security_opts` capability field +- support PATH[:opts] shorthand for same host/container mount path + (makes config incompatible with toolbox-constrained) +- add `--no-network` option to disable network access +- exit cleanly on shell error instead of throwing an exception diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to the Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by the Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding any notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,191 @@ +# encapsule + +CLI tool to run developer containers, isolating your home directory and host from container side effects: +"encapsules" a project and/or temp home dir together with select "capabilities". + +Originally derived from [toolbox-constrained](https://github.com/swick/toolbox-constrained) tool. + +Run a ([toolbox](https://containertoolbx.org/)) container or image as +an isolated podman container. Unlike with `toolbox enter`, this does *not* +bind-mount your home directory or integrate with the host by default. +You can explicitly choose what dir(s) to mount or features to enable, +selecting user-configured "capabilities" that the encapsule container can access. + +``` +encapsule 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. + +## Examples + +```bash +# Isolated shell without host fs access +$ encapsule my-toolbox + +# Mount current (project) directory in / and set it as the working directory +# (also names the container after the project, e.g. encapsule-my-toolbox-myproject) +$ encapsule my-toolbox -p . + +# Bind mount a volume +$ encapsule my-toolbox -v ~/data:/data + +# Mount a temp "home" directory (created if it doesn't exist) +$ encapsule my-toolbox --home /tmp/somedir + +# Use capabilities from config +$ encapsule my-toolbox --cap ssh --cap git + +# Read-only container filesystem +$ encapsule my-toolbox --readonly + +# Remove the saved image +$ encapsule my-toolbox --delete-image + +# Set environment variables and prepend to PATH +$ encapsule my-toolbox -e MY_VAR=hello -P ~/.local/bin + +# Run a specific command +$ encapsule my-toolbox -- ls / + +# Dry run: print the full podman command without running it +$ encapsule my-toolbox --dryrun + +# run directly from an image +$ encapsule fedora:44 --home tmphome +``` + +Encapsule containers are ephemeral by default: use `--keep` to leave the encapsule container around for reuse. Note the saved image will be reused next time unless using `--refresh`. + +### Usage + +`$ encapsule --version` + +``` +0.3 +``` + +`$ encapsule --help` + +``` +encapsule + +Usage: encapsule [--version] [TOOLBOX] [-v|--volume HOST:CONTAINER[:opts]] + [-e|--env KEY[=VALUE]] [-P|--path DIR] [-i|--init CMD] + [--cap NAME] [--home DIR] [-p|--project DIR] [-n|--name NAME] + [--caps | --list | --remove | --delete-image | --stop] [--keep] + [--readonly] [--no-network] [--no-sudo] [--unique] + [--podman-opt OPTION] [--debug] [--dryrun] [--refresh] [CMD] + + Run a toolbox image in an isolated podman container + +Available options: + -h,--help Show this help text + --version Show version + -v,--volume HOST:CONTAINER[:opts] + Bind mounts (default to selinux :z) + -e,--env KEY[=VALUE] Set or pass through an environment variable + -P,--path DIR Prepend a directory to PATH inside the container + -i,--init CMD A bash snippet run when creating the encapsule + container + --cap NAME Enable a capability from the config file + --home DIR Mount a directory as a writable home (created if + missing) + -p,--project DIR Mount a project directory and set as workdir + -n,--name NAME Container name (for creating or actions) + --caps List available capabilities from the config file + --list List encapsule images and containers + --remove Remove encapsule container + --delete-image Remove encapsule image + --stop Stop encapsule container + --keep Keep the encapsule container after exiting + --readonly Make the encapsule container filesystem read-only + --no-network Disable network access + --no-sudo Skip passwordless sudo setup + --unique Run a new encapsule container even if one is already + running + --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 +``` + +## Capabilities + +Define reusable groups of volumes, environment variables, PATH entries, +and init commands in `~/.config/encapsule/config.toml`: + +```toml +[capabilities.ssh] +volumes = ["~/.ssh:~/.ssh:ro"] + +[capabilities.git] +volumes = ["~/.gitconfig:ro"] + +[capabilities.wayland] +env = ["WAYLAND_DISPLAY", "XDG_RUNTIME_DIR"] +volumes = ["$XDG_RUNTIME_DIR/$WAYLAND_DISPLAY"] +security_opts = ["label=disable"] + +[capabilities.rust] +path = ["~/.cargo/bin"] +``` + +Each capability can define: + +- `volumes` — list of bind mount specs +- `env` — list of environment variables to set or pass through +- `path` — list of directories to prepend to `$PATH` +- `init` — a bash snippet to run on encapsule container creation +- `security_opts` — list of `--security-opt` values passed to podman + +`~` and envvars are expanded in volume and path specs. +If the host and container paths are the same, you can use the shorthand +`PATH[:opts]` instead of `PATH:PATH[:opts]`. + +## 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 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, + so multiple containers can safely access the same directories +6. 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 + +## Installation + +A copr repo is available for Fedora and Epel 10: + + + +## Building from source + +```bash +cabal install +``` + +or `stack install`. + +## Requirements + +- [podman](https://podman.io/) and [buildah](https://buildah.io/) +- An existing (toolbox) container (created with `toolbox create`) or image. +- Alternatively some non-toolbox other container/images may also work. + +## Related projects + +I already mentioned [toolbox-constrained](https://github.com/swick/toolbox-constrained) from which the initial code was derived. + +There is also similarly [schupfn](https://github.com/whot/schupfn/) which uses QEMU to run a toolbox container image in a VM with a direct private ssh connection. + +For stronger sandboxing and isolation, specially network, consider using [OpenShell](https://github.com/NVIDIA/OpenShell/). + +## Contribute + +`encapsule` is at and distributed +under the Apache-2.0 license. diff --git a/encapsule.cabal b/encapsule.cabal new file mode 100644 --- /dev/null +++ b/encapsule.cabal @@ -0,0 +1,70 @@ +cabal-version: 2.2 +name: encapsule +version: 0.3 +synopsis: Run isolated toolbox containers with podman +description: + This tool (originally based on the toolbox-constrained project) + allows running isolated toolbox containers with podman. + Mounting of home and host integration are not enabled by default, + but one can choose options to do so including capabilities + specified in a toml configuration file. +license: Apache-2.0 +license-file: LICENSE +author: Jens Petersen +maintainer: Jens Petersen +copyright: 2026 Jens Petersen +category: Utility +homepage: https://github.com/juhp/encapsule +bug-reports: https://github.com/juhp/encapsule/issues +build-type: Simple +extra-doc-files: README.md + ChangeLog.md + example/config.toml +tested-with: GHC == 8.10.7 + || == 9.0.2 + || == 9.2.8 + || == 9.4.8 + || == 9.6.7 + || == 9.8.4 + || == 9.10.3 + || == 9.12.4 + || == 9.14.1 + +source-repository head + type: git + location: https://github.com/juhp/encapsule.git + +executable encapsule + main-is: Main.hs + other-modules: Paths_encapsule + Script + autogen-modules: Paths_encapsule + hs-source-dirs: src + build-depends: base < 5 + , directory + , extra + , filepath + , containers + , process + , shell-monad + , simple-cmd >= 0.2.3 + , simple-cmd-args >= 0.1.8 + , text + , toml-reader + , unix + , xdg-basedir + default-language: Haskell2010 + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages diff --git a/example/config.toml b/example/config.toml new file mode 100644 --- /dev/null +++ b/example/config.toml @@ -0,0 +1,22 @@ +[capabilities.ssh] +volumes = ["~/.ssh:~/.ssh:ro"] + +[capabilities.git] +volumes = ["~/.gitconfig:ro"] + +[capabilities.wayland] +env = ["WAYLAND_DISPLAY", "XDG_RUNTIME_DIR"] +volumes = ["$XDG_RUNTIME_DIR/$WAYLAND_DISPLAY"] +security_opts = ["label=disable"] + +[capabilities.rust] +path = ["~/.cargo/bin"] + +[capabilities.claude] +volumes = [ + "~/.claude", + "~/.claude.json", +] + +[capabilities.default] +volumes = ["~/.config/isolation:~:rw"] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,556 @@ +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import Control.Monad (unless, when) +import Data.List.Extra (intercalate, splitOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust, isNothing, mapMaybe) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist, doesPathExist, getHomeDirectory) +import System.Environment.XDG.BaseDir (getUserConfigFile) +import System.Exit (exitWith) +import System.FilePath ((), takeFileName) +import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) +import System.Posix.Process (getProcessID) +import System.Posix.Env (getEnvDefault) +import System.Posix.Files (getFileStatus, isSocket) +import System.Posix.User (getEffectiveUserName) +import System.Process (rawSystem) +import SimpleCmd (cmd_, cmdBool, cmdFull, error', warning, (+-+)) +import SimpleCmdArgs +import TOML (Value(..), Table, renderTOMLError, decodeFile) + +import Paths_encapsule (version) +import Script + +progname :: String +progname = "encapsule" + +encapsule :: String -> String -> String +encapsule before after = before +-+ progname +-+ after + +data Mode = Caps | DeleteImage | List | Remove | Run | Stop + deriving Eq + +data Opts = Opts + { mtoolbox :: Maybe String + , vols :: [String] + , envs :: [String] + , paths :: [String] + , inits :: [String] + , caps :: [String] + , mhome :: Maybe FilePath + , mproject :: Maybe FilePath + , mname :: Maybe String + , mode :: Mode + , keep :: Bool + , readonly :: Bool + , nonetwork :: Bool + , nosudo :: Bool + , unique :: Bool + , podmanopts :: [String] + , debugging :: Bool + , dryrun :: Bool + , refresh :: Bool + , command :: [String] + } + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + simpleCmdArgs (Just version) + progname + "Run a toolbox image in an isolated podman container" $ + run <$> + (Opts + <$> optional (argumentWith str "TOOLBOX") + <*> many (strOptionWith 'v' "volume" "HOST:CONTAINER[:opts]" "Bind mounts (default to selinux :z)") + <*> many (strOptionWith 'e' "env" "KEY[=VALUE]" "Set or pass through an environment variable") + <*> many (strOptionWith 'P' "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") + <*> optional (strOptionLongWith "home" "DIR" "Mount a directory as a writable home (created if missing)") + <*> optional (strOptionWith 'p' "project" "DIR" "Mount a project directory and set as workdir") + <*> optional (strOptionWith 'n' "name" "NAME" "Container name (for creating or actions)") + <*> (flagLongWith' Caps "caps" "List available capabilities from the config file" <|> + flagLongWith' List "list" ("List" `encapsule` "images and containers") <|> + flagLongWith' Remove "remove" ("Remove" `encapsule` "container") <|> + flagLongWith' DeleteImage "delete-image" ("Remove" `encapsule` "image") <|> + flagLongWith Run Stop "stop" ("Stop" `encapsule` "container")) + <*> switchLongWith "keep" ("Keep the" `encapsule` "container after exiting") + <*> switchLongWith "readonly" ("Make the" `encapsule` "container filesystem read-only") + <*> switchLongWith "no-network" "Disable network access" + <*> switchLongWith "no-sudo" "Skip passwordless sudo setup" + <*> switchLongWith "unique" ("Run a new" `encapsule` "container even if one is already running") + <*> many (strOptionLongWith "podman-opt" "OPTION" "Pass an option directly to podman") + <*> switchLongWith "debug" "Show debug output" + <*> switchLongWith "dryrun" "Print the podman command instead of running it" + <*> switchLongWith "refresh" "Force re-commit of the toolbox image" + <*> many (argumentWith str "CMD")) + +run :: Opts -> IO () +run (Opts {..}) + | mode == Caps = 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 + | mode == List = do + cmd_ "podman" ["images", + "--filter", "reference=" ++ progname ++ "-*", + "--format", "{{.Repository}} {{.Size}} {{.Created}}"] + cmd_ "podman" ["ps", "-a", + "--filter", "name=^" ++ progname ++ "-", + "--format", "{{.Names}} {{.Status}}"] + | mode == DeleteImage = + when dryrun $ + removeImage (progname ++ "-" ++ containerBase) + | mode == Remove = do + mprojectDir <- resolveProjectDir mproject + let containerName = mkContainerName mname containerBase mprojectDir + exists <- cmdBool "podman" ["container", "exists", containerName] + if exists + then do + (_, out, _) <- cmdFull "podman" + ["container", "inspect", "-f", "{{.State.Running}}", containerName] "" + when (take 4 out == "true") $ do + putStr "stopping " + cmd_ "podman" ["stop", containerName] + putStr "rm " + cmd_ "podman" ["rm", containerName] + else warning $ "container" +-+ containerName +-+ "not found" + | mode == Stop = do + mprojectDir <- resolveProjectDir mproject + let containerName = mkContainerName mname containerBase mprojectDir + exists <- cmdBool "podman" ["container", "exists", containerName] + if exists + then do + putStr "stop " + cmd_ "podman" ["stop", containerName] + else warning $ "container" +-+ containerName +-+ "not found" + | otherwise = do + mprojectDir <- resolveProjectDir mproject + let containerName = mkContainerName mname containerBase mprojectDir + container <- + if unique + then do + pid <- getProcessID + return $ containerName ++ "-" ++ show pid + else return containerName + debug $ "container:" +-+ container + running <- + if unique + then return False + else do + exists <- cmdBool "podman" ["container", "exists", container] + debug $ container +-+ "exists" + 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 + home <- getHomeDirectory >>= canonicalizePath + debug $ "HOME:" +-+ home + 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 + , null podmanopts + , not refresh + ] + unless noopts $ + error' "cannot give options for an existing container!" + warning "Joining existing container" + username <- getEffectiveUserName + let userCmd = if null command then ["bash"] else command + execCmd = ["podman", "exec", "-it", container, + "runuser", "-u", username, "--", + "env", "HOME=" ++ home] ++ userCmd + if dryrun + then putStrLn $ unwords (map shellQuote execCmd) + else do + ret <- rawSystem "podman" (drop 1 execCmd) + exitWith ret + else do + case mtoolbox of + Nothing -> + when (isNothing mtoolbox) $ + error' $ "TOOLBOX argument needed to create a container" +-+ + if isJust mname then "(use '--name ^...' to reference a full container name)" else "" + Just toolbox -> createContainer home mprojectDir toolbox container + where + createContainer home mprojectDir toolbox container = do + mhomeDir <- + case mhome of + Just dir -> Just <$> checkMountPoint home dir + Nothing -> return Nothing + let isImage = ':' `elem` toolbox + debug $ if isImage then "image:" +-+ toolbox + else "toolbox:" +-+ toolbox + image <- if isImage + then return toolbox + else commitToolbox dryrun toolbox refresh + config <- loadConfig + let capabilities = getCapabilities config + + (extraVols, extraEnvs, extraPaths, extraInits, extraSecurityOpts) <- + resolveCapabilities capabilities caps + + homeVol <- + case mhomeDir of + Just d -> do + createDirectoryIfMissing True d + return [d ++ ":" ++ home] + Nothing -> return [] + + username <- getEffectiveUserName + + let projectVol = + case mprojectDir of + Just d -> [d ++ ":" ++ rootDest d] + Nothing -> [] + volumes = homeVol ++ vols ++ extraVols ++ projectVol + envVars = envs ++ extraEnvs + allpaths = paths ++ extraPaths + allinits = inits ++ extraInits + + envParts = ("HOME=" ++ shellQuote home) : pathEnvPart allpaths + initSetup = mkInitSetup allinits + userCmdParts = mkUserCmd command allinits + runuserCmd = "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" +-+ shellQuote home, + "chown" +-+ username +-+ shellQuote home] + else [] + fallback = + if isImage + then " || exec" +-+ runuserCmd + else "" + trace = ["set -x" | debugging] + setup = intercalate " && " + (trace ++ installSetup ++ sudoSetup ++ homeSetup ++ + [initSetup | not (null allinits)] ++ + ["exec runuser -u" +-+ username +-+ "--" +-+ runuserCmd]) + ++ fallback + + debug $ "setup:" +-+ setup + mounts <- mapM (addSelinuxLabel home) volumes + + let workdirPart = + case mprojectDir of + Just d -> ["--workdir", rootDest d] + Nothing | not isImage -> ["--workdir", home] + | otherwise -> [] + args = "run" : + [ "--rm" | not keep] ++ + [ "-it", "--userns=keep-id", + "--name", container, "--hostname", container, + "--user", "root", "-e", "HOME=" ++ home, + "-e", "TERM", "-e", "COLORTERM"] + ++ workdirPart + ++ (if readonly + then ["--read-only", "--tmpfs", "/tmp", "--tmpfs", "/run"] + ++ case mhomeDir of + Nothing -> ["--tmpfs", home] + Just _ -> [] + else []) + ++ (if nonetwork then ["--net", "none"] else []) + ++ concatMap (\s -> ["--security-opt", s]) extraSecurityOpts + ++ concatMap (\m -> ["-v", m]) mounts + ++ concatMap (\e -> ["-e", e]) envVars + ++ podmanopts + ++ [image, "sh", "-c", setup] + + if dryrun + then putStrLn $ unwords $ "podman" : map shellQuote args + else do + ret <- rawSystem "podman" args + exitWith ret + + containerBase = + case mtoolbox of + Just toolbox -> + map (\c -> if c == ':' then '-' else c) toolbox + Nothing -> error' "no TOOLBOX arg given" + + debug msg = when debugging $ warning $ "debug:" +-+ msg + +-- image management + +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 + ok <- + if dryrun then return True + else do + putStr "writing image " + cmdBool "buildah" + ["commit", "--disable-compression", toolbox, image] + 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 + 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 + +addSelinuxLabel :: FilePath -> String -> IO String +addSelinuxLabel home spec = + case break (== ':') spec of + (hostPart, []) -> do + hostExp <- expandPath home hostPart + sockFile <- isSocketFile hostExp + return $ hostExp ++ ":" ++ hostExp ++ if sockFile then "" else ":z" + (hostPart, _:rest') -> do + hostExp <- expandPath home hostPart + let (containerPart, optsPart) + | isPathStart 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 home containerPart + sockFile <- isSocketFile hostExp + let labeled = case optsPart of + Nothing -> + if sockFile + then hostExp ++ ":" ++ containerExp + else hostExp ++ ":" ++ containerExp ++ ":z" + Just o -> + let flags = splitOn "," o + in if sockFile || "z" `elem` flags || "Z" `elem` flags + then hostExp ++ ":" ++ containerExp ++ ":" ++ o + else hostExp ++ ":" ++ containerExp ++ ":" ++ o ++ ",z" + return labeled + where + isPathStart ('/':_) = True + isPathStart ('~':_) = True + isPathStart ('$':_) = True + isPathStart _ = False + +isSocketFile :: FilePath -> IO Bool +isSocketFile path = do + exists <- doesPathExist path + if exists + then isSocket <$> getFileStatus path + else return False + +-- path and env expansion + +rootDest :: FilePath -> FilePath +rootDest dir = '/' : takeFileName dir + +expandPath :: FilePath -> String -> IO String +expandPath home ('~':'/':rest) = do + rest' <- expandEnvVars rest + return $ home rest' +expandPath home "~" = return home +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') + +checkMountPoint :: FilePath -> FilePath -> IO FilePath +checkMountPoint home dir = do + finaldir <- expandPath home dir >>= canonicalizePath + when (finaldir == home) $ + error' "mounting $HOME not supported!" + return finaldir + +resolveProjectDir :: Maybe FilePath -> IO (Maybe FilePath) +resolveProjectDir Nothing = return Nothing +resolveProjectDir (Just dir) = do + home <- getHomeDirectory >>= canonicalizePath + Just <$> checkMountPoint home dir + +-- container naming + +sanitizeName :: String -> String +sanitizeName = map (\c -> if c `elem` nameChars then c else '-') + where + nameChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.-" + +projectSuffix :: Maybe FilePath -> String +projectSuffix Nothing = "" +projectSuffix (Just dir) = + case sanitizeName (takeFileName dir) of + "" -> "" + name -> "-" ++ name + +mkContainerName :: Maybe String -> String -> Maybe FilePath -> String +mkContainerName mname base mprojectDir = + case mname of + Just ('^':n) -> n + Just n -> progname ++ "-" ++ n + Nothing -> progname ++ "-" ++ base ++ projectSuffix mprojectDir + +-- 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 cmd inits@(_:_) = + let initChain = intercalate " && " inits + cmdStr = initChain +-+ "&& exec" +-+ unwords (map shellQuote cmd) + in ["sh", "-c", cmdStr] +mkUserCmd cmd [] = cmd + +-- 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] diff --git a/src/Script.hs b/src/Script.hs new file mode 100644 --- /dev/null +++ b/src/Script.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules #-} + +module Script ( + installScript + ) +where + +import Control.Monad.Shell +import qualified Data.Text.Lazy as T +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" []) + where + redir s dest = + 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]