packages feed

podenv 0.1.0 → 0.2.0

raw patch · 21 files changed

+296/−225 lines, 21 filesdep ~linux-capabilities

Dependency ranges changed: linux-capabilities

Files

.git/modules/hub/HEAD view
@@ -1,1 +1,1 @@-0cb06f35180a047ec98c30fb5fc14da7ea39cfc1+93ea716e709fd3eff049d49d11ee45cac51cadfc
CHANGELOG.md view
@@ -1,5 +1,16 @@ # Changelog +## 0.3.0 (next)++## 0.2.0 (2022-07-26)++- restrict ssh capability to the agent socket.+- home volume is set to the namespace name if a namespace is defined.+- allow passing args directly to a command: `podenv nix:github:podenv/devenv#emacs --version`+- fix syscaps argument for bwrap.+- use system chcon to set label.+- add --manifest argument to show every configuration context.+ ## 0.1.0 (2022-05-02)  - Initial release
README.md view
@@ -1,5 +1,8 @@ # podenv: a container wrapper +[![Hackage](https://img.shields.io/hackage/v/podenv.svg?logo=haskell)](https://hackage.haskell.org/package/podenv)+[![Apache-2.0 license](https://img.shields.io/badge/license-Apache--2.0-blue.svg)](LICENSE)+ > Note that this is a work in progress, please get in touch if you are interested.  Podenv provides a declarative interface to manage containerized applications.@@ -38,12 +41,12 @@ - `--volume web:~` use a volume named `web` for the container home. - `--hostfile ./document.pdf` share a single file. -### <a name="runtimes"></a>Runtimes+### <a name="runtimes"></a>Container Runtimes -Podenv works with multiple runtimes:+Podenv works with multiple container runtimes: -- Podman for container image and Containerfile.-- Bubblewrap for local rootfs and Nix Flakes. Checkout the [Howto use Nix tutorial](./docs/tutorials/nix.md).+- Podman for image and Containerfile.+- Bubblewrap for local rootfs and Nix Flakes.  The runtime integration is decoupled from the application description so that more options can be added in the future.@@ -61,12 +64,12 @@ #### Firefox with a fedora container  ```dhall-Application::{+(env:PODENV).Application::{ , name = "firefox" , description = Some "Mozilla Firefox"-, runtime = (./fedora.dhall).latest.useGraphic [ "firefox" ]+, runtime = (env:PODENV).Hub.fedora.useGraphic [ "firefox" ] , command = [ "firefox", "--no-remote" ]-, capabilities = Capabilities::{ wayland = True, network = True }+, capabilities = (env:PODENV).Capabilities::{ wayland = True, network = True } } ``` @@ -74,11 +77,10 @@  ```dhall \(pkgs : List Text) ->-ContainerBuild::{+(env:PODENV).ContainerBuild::{ , containerfile =     ''     FROM fedora:latest-    RUN ${./mkUser.dhall "fedora"}     RUN dnf install -y mesa-dri-drivers pipewire-libs     RUN dnf update -y     RUN dnf install -y ${concatSep " " pkgs}@@ -95,11 +97,11 @@ Podenv support the [Nix installables syntax](https://nixos.org/manual/nix/stable/command-ref/new-cli/nix.html#installables):  ```dhall-Application::{+(env:PODENV).Application::{ , name = "polyglot" , description = Some "Tool to count lines of source code."-, runtime = Nix Flakes::{ installables = [ "github:podenv/polyglot.nix" ]}-, capabilities = Capabilities::{ cwd = True }+, runtime = (env:PODENV).Hub.nix.useInstallables [ "github:podenv/polyglot.nix" ]+, capabilities = (env:PODENV).Capabilities::{ cwd = True } } ``` @@ -112,53 +114,7 @@ ## <a name="usages"></a>Usage  Podenv provides a simple command line: `podenv [--caps] application-name [args]`.--Here are some common use cases:--### Applications--```ShellSession-$ podenv gimp ./image.png-```--… runs the following command: `podman run [wayland args] --volume $(pwd)/image.png:/data/image.png localhost/gimp /data/image.png`--If necessary, podenv builds a local image using the Containerfile defined by the application.--### Container image--```ShellSession-$ podenv --rw --network --root --cwd --shell image:ubi8-```--… runs the following command: `podman run --rm -it --detach-keys '' --volume $(pwd):/data:Z --workdir /data --volume ~/.local/share/podenv/volumes/image-ubi8-home:/root ubi8 /bin/bash`--By default podenv mounts a local volumes for the home directory.--### Bubblewrap chroot--Extract a container image and execute it with bubblewrap:--```ShellSession-$ podenv --volume rawhide:/mnt image:fedora:rawhide bash -c "tar --one-file-system -cf - / | tar -C /mnt -xf -"-$ podenv --network --rw --root rootfs:rawhide-```--… extracts the rootfs with: `podman run --rm --read-only=true --network none --volume ~/.local/share/podenv/volumes/rawhide:/mnt fedora:rawhide bash -c "tar ..."`--… and, runs the following command: `bwrap [unshare args] --bind ~/.local/share/podenv/volumes/rawhide / --bind ~/.local/share/podenv/volumes/rootfs-7e08b7-home /root /bin/sh`--This is useful to avoid polluting the container storage.--### Nix flakes--```ShellSession-$ podenv nixpkgs#hello-```--… runs the installable using bubblewrap: `bwrap [unshare args] --bind ~/.local/share/podenv/volumes/nix-store /nix --bind ~/.local/share/podenv/volumes/nix-cache ~/.cache/nix --clearenv --setenv NIX_SSL_CERT_FILE /etc/pki/tls/certs/ca-bundle.crt nix --extra-experimental-features "nix-command flakes" run nixpkgs#hello`--If necessary, podenv automatically installs the Nix toolchain using bubblewrap with the [nix.setup application](https://github.com/podenv/hub/blob/main/Builders/nix.dhall).+Checkout the tutorials for examples.   # Documentation@@ -175,6 +131,7 @@ * [Use an application](./docs/tutorials/use.md) * [Create an application](./docs/tutorials/create.md) * [Howto use Nix](./docs/tutorials/nix.md)+* [Work with rawhide](./docs/tutorials/rawhide.md)  ## Howtos
+ hub/Applications/chroot.dhall view
@@ -0,0 +1,16 @@+let Podenv = ../Podenv.dhall++in  \(rootfs : Text) ->+      Podenv.Application::{+      , description = Some "Start a privileged shell with a rootfs"+      , runtime = Podenv.Rootfs rootfs+      , syscaps = [ "CHOWN", "DAC_OVERRIDE" ]+      , command = [ "bash", "--rcfile", "/etc/profile" ]+      , capabilities = Podenv.Capabilities::{+        , terminal = True+        , interactive = True+        , network = True+        , rw = True+        , root = True+        }+      }
+ hub/Applications/gscan2pdf.dhall view
@@ -0,0 +1,3 @@+./_graphicEditor.dhall+  "gscan2pdf"+  "GUI for producing a multipage PDF from a scan"
hub/Applications/package.dhall view
@@ -1,5 +1,6 @@ { audacity = ./audacity.dhall , ardour = ./ardour.dhall+, chroot = ./chroot.dhall , blender = ./blender.dhall , brave = ./brave.dhall , centos = ./centos.dhall@@ -14,6 +15,7 @@ , ffmpeg = ./ffmpeg.dhall , gimp = ./gimp.dhall , google-chrome = ./google-chrome.dhall+, gscan2pdf = ./gscan2pdf.dhall , gworldclock = ./gworldclock.dhall , hydrogen = ./hydrogen.dhall , inkscape = ./inkscape.dhall
hub/Builders/debian.dhall view
@@ -17,6 +17,7 @@             RUN ${./mkUser.dhall "debian"}             RUN apt-get update             RUN apt-get install -y ${Prelude.Text.concatSep " " pkgs}+            ENV USER=debian             ''         , image_volumes = mkVolumes ver         , image_home = Some "/home/debian"
hub/Builders/fedora.dhall view
@@ -20,6 +20,7 @@             ${pre-task}             RUN dnf update -y             RUN dnf install -y ${Prelude.Text.concatSep " " pkgs}+            ENV USER=fedora             ''         , image_volumes = mkVolumes ver         , image_home = Some "/home/fedora"
hub/Builders/nix.dhall view
@@ -32,9 +32,9 @@                   , "/tmp/nix-${version}-x86_64-linux/install"                   , "rm -r /tmp/nix-*-x86_64-linux*"                   , "cp -P /nix/var/nix/profiles/per-user/\$(id -nu)/profile-1-link /nix/var/nix/profiles/nix-install"-                  , "/nix/var/nix/profiles/default/bin/nix-collect-garbage --delete-old"-                  , "/nix/var/nix/profiles/default/bin/nix-store --optimise"-                  , "/nix/var/nix/profiles/default/bin/nix-store --verify --check-contents"+                  , "/nix/var/nix/profiles/nix-install/bin/nix-collect-garbage --delete-old"+                  , "/nix/var/nix/profiles/nix-install/bin/nix-store --optimise"+                  , "/nix/var/nix/profiles/nix-install/bin/nix-store --verify --check-contents"                   ]               , "); test -f ~/.config/nix/nix.conf || ("               , "echo -en ${Text/show default-config} > ~/.config/nix/nix.conf"
podenv.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               podenv-version:            0.1.0+version:            0.2.0 synopsis:           A container wrapper description:     Podenv provides a declarative interface to manage containerized applications.@@ -63,7 +63,7 @@                   , gitrev                   , lens-family-core                   , lens-family-th-                  , linux-capabilities+                  , linux-capabilities >= 0.1.1.0                   , optparse-applicative                   , relude >= 0.7                   , text@@ -81,6 +81,7 @@                   , Podenv.Prelude                   , Podenv.Runtime                   , Podenv.Version+                  , Podenv   other-modules:    Paths_podenv   autogen-modules:  Paths_podenv
+ src/Podenv.hs view
@@ -0,0 +1,36 @@+-- | The podenv library entry point+module Podenv+  ( -- * Config+    Application (..),+    Capabilities (..),++    -- * Import+    loadConfig,+    decodeExpr,+    select,++    -- * Context+    appToContext,++    -- * Runtime+    RuntimeEnv (..),+    defaultRuntimeEnv,+    execute,+    getPodmanPodStatus,+    deletePodmanPod,+  )+where++import Podenv.Application+import Podenv.Config+import Podenv.Context+import Podenv.Dhall+import Podenv.Env+import Podenv.Prelude+import Podenv.Runtime++appToContext :: AppEnv -> Application -> Name -> IO Context+appToContext = preparePure Regular++loadConfig :: Text -> IO Config+loadConfig = Podenv.Config.load Nothing . Just
src/Podenv/Application.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -21,27 +22,27 @@   ) where -import qualified Data.Map-import qualified Data.Text as Text-import qualified Data.Text.IO as Text-import qualified Podenv.Build+import Data.Map qualified+import Data.Set qualified as Set+import Data.Text qualified as Text+import Podenv.Build qualified import Podenv.Dhall import Podenv.Env import Podenv.Prelude-import qualified Podenv.Runtime as Ctx-import qualified System.Posix.Files+import Podenv.Runtime qualified as Ctx+import System.Posix.Files qualified  data Mode = Regular | Shell  -- | Converts an Application into a Context-prepare :: Application -> Mode -> Ctx.Name -> IO Ctx.Context-prepare app mode ctxName = do+prepare :: Mode -> Application -> Ctx.Name -> IO Ctx.Context+prepare mode app ctxName = do   appEnv <- Podenv.Env.new-  preparePure appEnv app mode ctxName+  preparePure mode appEnv app ctxName  -- TODO: make this stricly pure using a PodenvMonad similar to the PandocMonad-preparePure :: AppEnv -> Application -> Mode -> Ctx.Name -> IO Ctx.Context-preparePure envBase app mode ctxName = do+preparePure :: Mode -> AppEnv -> Application -> Ctx.Name -> IO Ctx.Context+preparePure mode envBase app ctxName = do   home <- getContainerHome   runReaderT (doPrepare app mode ctxName home) (appEnv home)   where@@ -91,7 +92,9 @@     modifiers = disableSelinux . setRunAs . addSysCaps . addEnvs . setEnv . ensureWorkdir . ensureHome      ensureHome = case appHome of-      Just fp -> Ctx.addMount (toString fp) (Ctx.MkVolume Ctx.RW (Ctx.Volume $ (Ctx.unName ctxName <> "-home")))+      Just fp ->+        let volumeName = fromMaybe (Ctx.unName ctxName) (app ^. appNamespace)+         in Ctx.addMount (toString fp) (Ctx.MkVolume Ctx.RW (Ctx.Volume $ volumeName <> "-home"))       Nothing -> id      -- Check if path is part of a mount point@@ -132,7 +135,7 @@     addSysCap :: Text -> Ctx.Context -> Ctx.Context     addSysCap syscap = case readMaybe (toString $ "CAP_" <> syscap) of       Nothing -> error $ "Can't read syscap: " <> show syscap-      Just c -> Ctx.syscaps %~ (c :)+      Just c -> Ctx.syscaps %~ (Set.insert c)      addEnvs ctx = foldr addEnv ctx (app ^. appEnviron)     addEnv :: Text -> Ctx.Context -> Ctx.Context@@ -298,33 +301,10 @@     Nothing -> id     Just path -> Ctx.addEnv (toText var) (toText path) . Ctx.directMount (takeDirectory path) -setSshControlPath :: AppEnvT (Ctx.Context -> Ctx.Context)-setSshControlPath = do-  config <- readConfig-  uid <- asks _hostUid-  pure $ case getControlPath (words config) of-    Just cp ->-      case takeDirectory $ toString $ Text.replace "%i" (show uid) cp of-        "/tmp" -> id-        d -> Ctx.directMount d-    Nothing -> id-  where-    readConfig = do-      homeDir <- fromMaybe (error "Need HOME for ssh") <$> asks _hostHomeDir-      let configPath = homeDir </> ".ssh" </> "config"-      exist <- liftIO $ doesFileExist configPath-      bool (pure "") (liftIO $ Text.readFile configPath) exist-    getControlPath = \case-      ("ControlPath" : x : _) -> Just x-      (_ : xs) -> getControlPath xs-      [] -> Nothing- setSsh :: Ctx.Context -> AppEnvT Ctx.Context setSsh ctx = do-  shareConfig <- mountHomeConfig "ssh" ".ssh"   shareAgent <- liftIO $ setAgent "SSH_AUTH_SOCK"-  shareControlPath <- setSshControlPath-  pure $ ctx & shareAgent . shareConfig . shareControlPath+  pure $ ctx & shareAgent  setGpg :: Ctx.Context -> AppEnvT Ctx.Context setGpg ctx = do
src/Podenv/Build.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -11,18 +12,18 @@   ) where -import qualified Control.Monad-import qualified Data.Digest.Pure.SHA as SHA-import qualified Data.Text as Text-import qualified Data.Text.IO as Text-import qualified Podenv.Config+import Control.Monad qualified+import Data.Digest.Pure.SHA qualified as SHA+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import Podenv.Config qualified import Podenv.Dhall import Podenv.Prelude import Podenv.Runtime (ImageName (..))-import qualified Podenv.Runtime+import Podenv.Runtime qualified import System.Directory (doesDirectoryExist, renameFile) import System.Exit (ExitCode (ExitSuccess))-import qualified System.Process.Typed as P+import System.Process.Typed qualified as P  -- | Helper function to run a standalone app, usefull for local build type AppRunner = Application -> IO ()@@ -45,10 +46,12 @@ -- | Create the build env prepare :: Podenv.Runtime.RuntimeEnv -> Application -> IO (BuildEnv, Application) prepare re app = case runtime app of-  Image name -> pure (defaultBuildEnv name, app)-  Container cb -> pure (prepareContainer cb, app)-  Rootfs fp -> pure (defaultBuildEnv fp, app)+  Image name -> pure (defaultBuildEnv name, addArgs app)+  Container cb -> pure (prepareContainer cb, addArgs app)+  Rootfs fp -> pure (defaultBuildEnv fp, addArgs app)   Nix expr -> prepareNix re app expr+  where+    addArgs = appCommand %~ (<> Podenv.Runtime.extraArgs re)  containerBuildRuntime :: ContainerBuild -> Podenv.Runtime.RuntimeContext containerBuildRuntime = Podenv.Runtime.Container . mkImageName@@ -93,8 +96,14 @@ nixRuntime = Podenv.Runtime.Bubblewrap "/"  getCertLocation :: IO (Maybe FilePath)-getCertLocation = runMaybeT $ Control.Monad.msum $ checkPath <$> paths+getCertLocation = runMaybeT $ Control.Monad.msum $ [checkEnv] <> (checkPath <$> paths)   where+    checkEnv :: MaybeT IO FilePath+    checkEnv = do+      env <- lift $ lookupEnv "NIX_SSL_CERT_FILE"+      case env of+        Just fp -> checkPath fp+        Nothing -> mzero     checkPath :: FilePath -> MaybeT IO FilePath     checkPath fp = do       exist <- lift $ doesPathExist fp@@ -178,10 +187,13 @@      runCommand =       [toText nixCommandPath] <> nixFlags <> case app ^. appCommand of-        [] -> ["run"] <> nixArgs-        appArgs -> ["shell"] <> nixArgs <> ["--command"] <> appArgs+        [] ->+          ["run"] <> nixArgs <> case Podenv.Runtime.extraArgs re of+            [] -> []+            xs -> ["--"] <> xs+        appArgs -> ["shell"] <> nixArgs <> ["--command"] <> appArgs <> Podenv.Runtime.extraArgs re     addCommand = appCommand .~ runCommand-    addVolumes = appVolumes %~ mappend ["nix-store:/nix", "nix-cache:~/.cache/nix"]+    addVolumes = appVolumes %~ mappend ["nix-store:/nix", "nix-cache:~/.cache/nix", "nix-config:~/.config/nix"]     addEnvirons certs =       appEnviron         %~ mappend
src/Podenv/Config.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}  -- | This module contains the logic to load the dhall configuration module Podenv.Config   ( load,+    decodeExpr,     select,     Config (..),     Atom (..),@@ -18,23 +20,23 @@ where  import Control.Exception (bracket_)-import qualified Data.Digest.Pure.SHA as SHA+import Data.Digest.Pure.SHA qualified as SHA import Data.Either.Validation-import qualified Data.Text as Text-import qualified Data.Text.IO as Text (readFile)-import qualified Dhall-import qualified Dhall.Core as Dhall-import qualified Dhall.Import-import qualified Dhall.Map as DM+import Data.Text qualified as Text+import Data.Text.IO qualified as Text (readFile)+import Dhall qualified+import Dhall.Core qualified as Dhall+import Dhall.Import qualified+import Dhall.Map qualified as DM import Dhall.Marshal.Decode (DhallErrors (..), extractError)-import qualified Dhall.Parser-import qualified Dhall.Src+import Dhall.Parser qualified+import Dhall.Src qualified import Podenv.Dhall hiding (name) import Podenv.Prelude import System.Directory import System.Environment (setEnv, unsetEnv) import System.FilePath.Posix (dropExtension, isExtensionOf, splitPath)-import qualified Text.Show+import Text.Show qualified  data Config   = -- | A standalone application, e.g. defaultSelector@@ -69,7 +71,7 @@ load :: Maybe Text -> Maybe Text -> IO Config load selectorM configTxt = case selectorM >>= defaultSelector of   Just c -> pure $ ConfigDefault (ApplicationRecord c)-  Nothing -> load' . Dhall.normalize <$> loadExpr configTxt+  Nothing -> decodeExpr . Dhall.normalize <$> loadExpr configTxt  defaultSelector :: Text -> Maybe Application defaultSelector s@@ -161,8 +163,8 @@ podenvImportTxt = Text.replace "\n " "" $ Dhall.pretty podenvImport  -- | Pure config load-load' :: DhallExpr -> Config-load' expr = case loadConfig "" expr of+decodeExpr :: DhallExpr -> Config+decodeExpr expr = case loadConfig "" expr of   Success [(selector, Lit app)] -> ConfigApplication $ Lit (ensureName selector app)   Success [(_, x)] -> ConfigApplication x   Success [] -> error "No application found"@@ -184,10 +186,10 @@   Dhall.RecordLit kv     | -- When the node has a "runtime" attribute, assume it is an app.       DM.member "runtime" kv ->-      (\app -> [(baseSelector, app)]) <$> loadApp expr+        (\app -> [(baseSelector, app)]) <$> loadApp expr     | -- Otherwise, traverse each attributes       otherwise ->-      concat <$> traverse (uncurry loadCollection) (DM.toList kv)+        concat <$> traverse (uncurry loadCollection) (DM.toList kv)     where       loadCollection n e         -- Skip leaf starting with `use`, otherwise they can be used and likely fail with:@@ -323,7 +325,7 @@   Dhall.Lam _ fb1 (Dhall.Lam _ fb2 _) -> LamArg2 (getArgName fb1) (getArgName fb2) <$> Dhall.extract Dhall.auto expr   Dhall.Lam _ fb _     | Dhall.denote (Dhall.functionBindingAnnotation fb) == appType ->-      LamApp <$> Dhall.extract Dhall.auto expr+        LamApp <$> Dhall.extract Dhall.auto expr     | otherwise -> LamArg (getArgName fb) <$> Dhall.extract Dhall.auto expr   _ -> Lit <$> Dhall.extract Dhall.auto expr   where
src/Podenv/Context.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -17,8 +18,8 @@ -- | Runtime Context data types and lenses module Podenv.Context where -import qualified Data.Map.Strict as Map-import qualified Data.Set as Set+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set import Lens.Family.TH (makeLenses) import Podenv.Prelude import System.Linux.Capabilities (Capability)@@ -72,7 +73,7 @@     _environ :: Map Text Text,     -- | container volumes     _mounts :: Map FilePath Volume,-    _syscaps :: [Capability],+    _syscaps :: Set.Set Capability,     _ro :: Bool,     -- | container devices     _devices :: Set FilePath,
src/Podenv/Dhall.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}@@ -15,7 +16,7 @@ import Data.Char (toUpper) import Data.Void import Dhall.Core (Expr ())-import qualified Dhall.TH+import Dhall.TH qualified import Lens.Family.TH (makeLensesBy)  -- | The hub submodule commit, this is only used for the PODENV environment value
src/Podenv/Env.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-missing-signatures #-}@@ -6,9 +7,9 @@ -- | The platform environment module Podenv.Env where -import qualified Data.List.NonEmpty-import qualified Data.Maybe-import qualified Data.Text+import Data.List.NonEmpty qualified+import Data.Maybe qualified+import Data.Text qualified import Lens.Family.TH (makeLenses) import Podenv.Prelude
src/Podenv/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -25,30 +26,31 @@   ) where -import qualified Data.Text+import Data.Text qualified import Data.Version (showVersion) import Options.Applicative hiding (command) import Paths_podenv (version)-import qualified Podenv.Application-import qualified Podenv.Build-import qualified Podenv.Config+import Podenv.Application qualified+import Podenv.Build qualified+import Podenv.Config qualified import Podenv.Dhall import Podenv.Prelude import Podenv.Runtime (Context, Name (..), RuntimeEnv (..))-import qualified Podenv.Runtime-import qualified Podenv.Version (version)+import Podenv.Runtime qualified+import Podenv.Version qualified (version)  -- | podenv entrypoint main :: IO () main = do   cli@CLI {..} <- usage =<< getArgs+  when showManifest (printManifest configExpr >> exitSuccess)   when showDhallEnv (putTextLn Podenv.Config.podenvImportTxt >> exitSuccess)   when listCaps (printCaps >> exitSuccess)   when listApps (printApps configExpr >> exitSuccess)    (baseApp, mode, ctxName, re) <- cliConfigLoad cli   (be, app) <- Podenv.Build.prepare re baseApp-  ctx <- Podenv.Application.prepare app mode ctxName+  ctx <- Podenv.Application.prepare mode app ctxName    if showApplication     then putTextLn $ showApp app ctx be re@@ -60,13 +62,13 @@ -- | helper function to run a Application. runApp :: Podenv.Runtime.RuntimeEnv -> Application -> IO () runApp re app = do-  ctx <- Podenv.Application.prepare app Podenv.Application.Regular (Name $ app ^. appName)+  ctx <- Podenv.Application.prepare Podenv.Application.Regular app (Name $ app ^. appName)   Podenv.Runtime.execute re ctx  usage :: [String] -> IO CLI usage args = do   cli <- handleParseResult $ execParserPure defaultPrefs cliInfo cliArgs-  pure $ cli {extraArgs = map toText appArgs}+  pure $ cli {cliExtraArgs = map toText appArgs}   where     cliArgs = takeCliArgs [] args     appArgs = case drop (length cliArgs) args of@@ -94,22 +96,24 @@   { -- action modes:     listApps :: Bool,     listCaps :: Bool,+    showManifest :: Bool,     showDhallEnv :: Bool,     showApplication :: Bool,     configExpr :: Maybe Text,     -- runtime env:     update :: Bool,     verbose :: Bool,+    detach :: Bool,     -- app modifiers:     capsOverride :: [Capabilities -> Capabilities],     shell :: Bool,     namespace :: Maybe Text,-    -- TODO: add namespaced :: Bool (when set, namespace is the app name head)     name :: Maybe Text,     cliEnv :: [Text],     volumes :: [Text],+    -- app selector and arguments:     selector :: Maybe Text,-    extraArgs :: [Text]+    cliExtraArgs :: [Text]   }  -- WARNING: when adding strOption, update the 'strOptions' list@@ -119,12 +123,14 @@     -- action modes:     <$> switch (long "list" <> help "List available applications")     <*> switch (long "list-caps" <> help "List available capabilities")+    <*> switch (long "manifest" <> hidden)     <*> switch (long "dhall-env" <> hidden)     <*> switch (long "show" <> help "Show the environment without running it")     <*> optional (strOption (long "config" <> help "A config expression"))     -- runtime env:     <*> switch (long "update" <> help "Update the runtime")     <*> switch (long "verbose" <> help "Increase verbosity")+    <*> switch (long "detach" <> hidden)     -- app modifiers:     <*> capsParser     <*> switch (long "shell" <> help "Start a shell instead of the application command")@@ -183,21 +189,17 @@     Nothing -> getDataDir >>= \fp -> pure $ fp </> "volumes"    config <- Podenv.Config.load selector configExpr-  (args, baseApp) <- mayFail $ Podenv.Config.select config (maybeToList selector <> extraArgs)-  let app = cliPrepare cli args baseApp+  (extraArgs, baseApp) <- mayFail $ Podenv.Config.select config (maybeToList selector <> cliExtraArgs)+  let app = cliPrepare cli baseApp       name' = Name $ fromMaybe (app ^. appName) name-      re = RuntimeEnv {verbose, system, volumesDir}+      re = RuntimeEnv {verbose, detach, system, extraArgs, volumesDir}       mode = if shell then Podenv.Application.Shell else Podenv.Application.Regular   pure (app, mode, name', re)  -- | Apply the CLI argument to the application-cliPrepare :: CLI -> [Text] -> Application -> Application-cliPrepare CLI {..} args = modifiers+cliPrepare :: CLI -> Application -> Application+cliPrepare CLI {..} = setShell . setEnvs . setVolumes . setCaps . setNS   where-    modifiers = setShell . setEnvs . setVolumes . setCaps . setNS . addArgs--    addArgs = appCommand %~ (<> args)-     setNS = maybe id (appNamespace ?~) namespace      setShell = bool id setShellCap shell@@ -214,7 +216,7 @@   where     infos =       ["[+] runtime: " <> Podenv.Build.beInfos be, ""]-        <> ["[+] Capabilities", unwords appCaps, ""]+        <> ["[+] Capabilities", unwords (sort appCaps), ""]         <> ["[+] Command", cmd]     cmd = Podenv.Runtime.showRuntimeCmd re ctx     appCaps = concatMap showCap Podenv.Application.capsAll@@ -231,12 +233,8 @@  printApps :: Maybe Text -> IO () printApps configTxt = do-  config <- Podenv.Config.load Nothing configTxt-  let atoms = sortOn fst $ case config of-        Podenv.Config.ConfigDefault app -> [("default", Podenv.Config.Lit app)]-        Podenv.Config.ConfigApplication atom -> [("default", atom)]-        Podenv.Config.ConfigApplications xs -> xs-      showApp' (Podenv.Config.ApplicationRecord app) =+  atoms <- configToAtoms <$> Podenv.Config.load Nothing configTxt+  let showApp' (Podenv.Config.ApplicationRecord app) =         "Application" <> maybe "" (\desc -> " (" <> desc <> ")") (app ^. appDescription)       showFunc args app = "λ " <> args <> " → " <> showApp' app       showArg a = "<" <> show a <> ">"@@ -247,3 +245,28 @@         Podenv.Config.LamApp _ -> "λ app → app"       showAtom (name, app) = name <> ": " <> showConfig app   traverse_ (putTextLn . showAtom) atoms++configToAtoms :: Podenv.Config.Config -> [(Text, Podenv.Config.Atom)]+configToAtoms = \case+  Podenv.Config.ConfigDefault ar -> [("default", Podenv.Config.Lit ar)]+  Podenv.Config.ConfigApplication atom -> [("default", atom)]+  Podenv.Config.ConfigApplications xs -> sortOn fst xs++printManifest :: Maybe Text -> IO ()+printManifest configTxt = do+  atoms <- configToAtoms <$> Podenv.Config.load Nothing configTxt+  let re = Podenv.Runtime.defaultRuntimeEnv "/volume"+      addNL = Data.Text.replace "--" "\\\n  --"+      doPrint name ar = do+        putTextLn name+        (be, app) <- Podenv.Build.prepare re ar+        ctx <- Podenv.Application.prepare (Podenv.Application.Regular) app (Name name)+        putTextLn . addNL $ showApp app ctx be re++      printAppContext :: (Text, Podenv.Config.Atom) -> IO ()+      printAppContext (name, atom) = case atom of+        Podenv.Config.Lit app -> doPrint name (Podenv.Config.unRecord app)+        Podenv.Config.LamArg _ f -> doPrint name (Podenv.Config.unRecord $ f "a")+        Podenv.Config.LamArg2 _ _ f -> doPrint name (Podenv.Config.unRecord $ f "a" "b")+        Podenv.Config.LamApp _ -> putTextLn $ name <> ": lamapp"+  traverse_ (printAppContext) atoms
src/Podenv/Prelude.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-}  -- | Common functions
src/Podenv/Runtime.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -11,6 +12,8 @@ module Podenv.Runtime   ( execute,     showRuntimeCmd,+    getPodmanPodStatus,+    deletePodmanPod,      -- * Podman helpers     podman,@@ -27,14 +30,14 @@   ) where -import qualified Data.Map.Strict as Map-import qualified Data.Set-import qualified Data.Text as Text+import Data.Map.Strict qualified as Map+import Data.Set qualified+import Data.Text qualified as Text import Podenv.Config (defaultSystemConfig) import Podenv.Context import Podenv.Dhall (SystemConfig (..), sysDns) import Podenv.Prelude-import qualified System.Process.Typed as P+import System.Process.Typed qualified as P  execute :: RuntimeEnv -> Context -> IO () execute re ctx = do@@ -53,7 +56,7 @@   exist <- doesPathExist fp   unless exist $ do     createDirectoryIfMissing True fp-    P.runProcess_ $ P.proc "chcon" ["system_u:object_r:container_file_t:s0", fp]+    P.runProcess_ $ P.proc "/bin/chcon" ["system_u:object_r:container_file_t:s0", fp]  doExecute :: Context -> ContextEnvT () doExecute ctx = case ctx ^. runtimeCtx of@@ -73,7 +76,7 @@  commonArgs :: Context -> [Text] commonArgs Context {..} =-  concatMap (\c -> ["--cap-add", Text.drop 4 (show c)]) _syscaps+  concatMap (\c -> ["--cap-add", show c]) $ sort $ Data.Set.toList _syscaps  bwrapRunArgs :: RuntimeEnv -> Context -> FilePath -> [String] bwrapRunArgs RuntimeEnv {..} ctx@Context {..} fp = toString <$> args@@ -86,9 +89,9 @@      networkArg       | _network = case _namespace of-        Just "host" -> []-        Just _ns -> error "Shared netns not implemented"-        Nothing -> [] -- TODO: implement private network namespace+          Just "host" -> []+          Just _ns -> error "Shared netns not implemented"+          Nothing -> [] -- TODO: implement private network namespace       | otherwise = ["--unshare-net"]      volumeArg :: (FilePath, Volume) -> [Text]@@ -145,13 +148,17 @@  data RuntimeEnv = RuntimeEnv   { verbose :: Bool,+    detach :: Bool,     system :: SystemConfig,+    -- | The app argument provided on the command line+    extraArgs :: [Text],+    -- | The host location of the volumes directory, default to ~/.local/share/podenv/volumes     volumesDir :: FilePath   }   deriving (Show)  defaultRuntimeEnv :: FilePath -> RuntimeEnv-defaultRuntimeEnv = RuntimeEnv True defaultSystemConfig+defaultRuntimeEnv = RuntimeEnv True False defaultSystemConfig []  type ContextEnvT a = ReaderT RuntimeEnv IO a @@ -182,10 +189,10 @@     hostnameArg = ["--hostname", unName _name]     networkArg       | _network =-        hostnameArg <> case _namespace of-          Just "host" -> ["--network", "host"]-          Just ns -> ["--network", "container:" <> infraName ns]-          Nothing -> maybe [] (\dns -> ["--dns=" <> dns]) (system ^. sysDns) <> portArgs+          hostnameArg <> case _namespace of+            Just "host" -> ["--network", "host"]+            Just ns -> ["--network", "container:" <> infraName ns]+            Nothing -> maybe [] (\dns -> ["--dns=" <> dns]) (system ^. sysDns) <> portArgs       | otherwise = ["--network", "none"]      volumeArg :: (FilePath, Volume) -> [Text]@@ -213,6 +220,7 @@     args =       ["run"]         <> podmanArgs ctx+        <> ["--detach" | detach]         <> maybe [] (\h -> ["--hostname", h]) _hostname         <> cond _privileged ["--privileged"]         <> ["--rm"]@@ -241,19 +249,23 @@     Unknown Text   deriving (Show, Eq) -getPodmanStatus :: String -> ContextEnvT PodmanStatus-getPodmanStatus cname = do-  (_, stdout', _) <- P.readProcess (podman ["inspect", cname, "--format", "{{.State.Status}}"])+getPodmanPodStatus :: MonadIO m => Name -> m PodmanStatus+getPodmanPodStatus (Name cname) = do+  (_, stdout', _) <- P.readProcess (podman ["inspect", Text.unpack cname, "--format", "{{.State.Status}}"])   pure $ case stdout' of     "" -> NotFound     "running\n" -> Running     other -> Unknown (Text.dropWhileEnd (== '\n') $ decodeUtf8 other) +deletePodmanPod :: MonadIO m => Name -> m ()+deletePodmanPod (Name cname) =+  P.runProcess_ (podman ["rm", toString cname])+ ensureInfraNet :: Text -> ContextEnvT () ensureInfraNet ns = do   debug $ "Ensuring infra net for: " <> show ns   let pod = infraName ns-  infraStatus <- getPodmanStatus (toString pod)+  infraStatus <- getPodmanPodStatus (Name pod)   case infraStatus of     Running -> pure ()     _ -> do@@ -280,9 +292,9 @@     (Just ns, True) | ns /= mempty -> ensureInfraNet ns     _ -> pure () -  status <- getPodmanStatus cname-  debug $ "Podman status of " <> toText cname <> ": " <> show status-  let cfail err = liftIO . mayFail . Left $ toText cname <> ": " <> err+  status <- getPodmanPodStatus (ctx ^. name)+  debug $ "Podman status of " <> cname <> ": " <> show status+  let cfail err = liftIO . mayFail . Left $ cname <> ": " <> err   args <-     case status of       NotFound -> pure $ podmanRunArgs re ctx image@@ -292,8 +304,8 @@   debug $ show cmd   P.runProcess_ cmd   where-    cname = toString (unName $ ctx ^. name)+    cname = unName $ ctx ^. name     -- Delete a non-kept container and return the run args     recreateContainer re = do-      P.runProcess_ (podman ["rm", cname])+      deletePodmanPod (ctx ^. name)       pure $ podmanRunArgs re ctx image
test/Spec.hs view
@@ -1,20 +1,20 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module Main where -import Data.Maybe (maybeToList) import Data.Text (pack)-import qualified Data.Text as Text-import qualified Podenv.Application-import qualified Podenv.Build-import qualified Podenv.Config-import qualified Podenv.Context-import qualified Podenv.Dhall+import Data.Text qualified as Text+import Podenv.Application qualified+import Podenv.Build qualified+import Podenv.Config qualified+import Podenv.Context qualified+import Podenv.Dhall qualified import Podenv.Env-import qualified Podenv.Main+import Podenv.Main qualified import Podenv.Prelude (mayFail)-import qualified Podenv.Runtime+import Podenv.Runtime qualified import System.Environment (getEnv, setEnv) import Test.Hspec @@ -29,6 +29,7 @@       setEnv "XDG_CACHE_HOME" (curHome <> "/.cache")       setEnv "HOME" "/home/user"       setEnv "WAYLAND_DISPLAY" "wayland-0"+      setEnv "NIX_SSL_CERT_FILE" "/etc/hosts"  spec :: Podenv.Config.Config -> Spec spec config = describe "unit tests" $ do@@ -64,10 +65,10 @@   describe "cli parser" $ do     it "pass command args" $ do       cli <- Podenv.Main.usage ["--name", "test", "image:ubi8", "ls", "-la"]-      Podenv.Main.extraArgs cli `shouldBe` ["ls", "-la"]+      Podenv.Main.cliExtraArgs cli `shouldBe` ["ls", "-la"]     it "handle separator" $ do       cli <- Podenv.Main.usage ["--name", "test", "image:ubi8", "--", "ls", "-la"]-      Podenv.Main.extraArgs cli `shouldBe` ["ls", "-la"]+      Podenv.Main.cliExtraArgs cli `shouldBe` ["ls", "-la"]   describe "cli with single config" $ do     it "select app" $ cliTest "env" [] "env"     it "add args" $ cliTest "env" ["ls"] "env // { command = [\"ls\"]}"@@ -82,9 +83,13 @@     it "nix:expr" $ cliTest "env" ["nix:test"] "def // { runtime.nix = \"test\", name = \"nix-a94a8f\" }"   describe "bwrap ctx" $ do     it "run simple" $ bwrapTest ["--shell"] (defBwrap <> ["/bin/sh"])+  describe "nix test" $ do+    it "nix run without args" $ nixTest "{ runtime.nix = \"test\"}" [] ["run", "test"]+    it "nix run with args" $ nixTest "{env, test = { runtime.nix = \"test\"}}" ["test", "--help"] ["run", "test", "--", "--help"]+    it "nix run with shell" $ nixTest "{env, test = { runtime.nix = \"test\", command = [\"test\"]}}" ["test", "--help"] ["shell", "test", "--command", "test", "--help"]   describe "podman ctx" $ do     it "run simple" $ podmanTest "env" ["run", "--rm", "--hostname", "env", "--name", "env", defImg]-    it "run syscaps" $ podmanTest "env // { syscaps = [\"NET_ADMIN\"] }" (defRun ["--hostname", "env", "--cap-add", "NET_ADMIN"])+    it "run syscaps" $ podmanTest "env // { syscaps = [\"NET_ADMIN\"] }" (defRun ["--hostname", "env", "--cap-add", "CAP_NET_ADMIN"])     it "run hostdir" $ podmanTest "env // { volumes = [\"/tmp/test\"]}" (defRun ["--security-opt", "label=disable", "--hostname", "env", "--volume", "/tmp/test:/tmp/test"])     it "run volumes" $ podmanTest "env // { volumes = [\"nix-store:/nix\"]}" (defRun ["--hostname", "env", "--volume", "/data/nix-store:/nix"])     it "run home volumes" $@@ -125,7 +130,7 @@     it "name override keep image" $ do       cli <- Podenv.Main.usage ["--name", "tmp", "--config", "{ name = \"firefox\", runtime.image = \"localhost/firefox\" }"]       (app, mode, ctxName, re) <- Podenv.Main.cliConfigLoad cli-      ctx <- Podenv.Application.preparePure testEnv app mode ctxName+      ctx <- Podenv.Application.preparePure mode testEnv app ctxName       Podenv.Runtime.podmanRunArgs re ctx (getImg ctx) `shouldBe` ["run", "--rm", "--read-only=true", "--network", "none", "--name", "tmp", "localhost/firefox"]   where     defRun xs = ["run", "--rm"] <> xs <> ["--name", "env", defImg]@@ -157,7 +162,7 @@       cli <- Podenv.Main.usage (args <> ["rootfs:/srv"])       (app, mode, ctxName, re') <- Podenv.Main.cliConfigLoad cli       let re = re' {Podenv.Runtime.system = Podenv.Config.defaultSystemConfig}-      ctx <- Podenv.Application.preparePure testEnv app mode ctxName+      ctx <- Podenv.Application.preparePure mode testEnv app ctxName       Podenv.Runtime.bwrapRunArgs re ctx (getFP ctx) `shouldBe` expected      getImg ctx = case Podenv.Context._runtimeCtx ctx of@@ -166,25 +171,32 @@      podmanCliTest args expected = do       cli <- Podenv.Main.usage (["--rw"] <> args)-      (app, mode, ctxName, re') <- Podenv.Main.cliConfigLoad cli+      (cliApp, mode, ctxName, re') <- Podenv.Main.cliConfigLoad cli+      (_, app) <- Podenv.Build.prepare re' cliApp       let re = re' {Podenv.Runtime.system = Podenv.Config.defaultSystemConfig}-      ctx <- Podenv.Application.preparePure testEnv app mode ctxName+      ctx <- Podenv.Application.preparePure mode testEnv app ctxName       Podenv.Runtime.podmanRunArgs re ctx (getImg ctx) `shouldBe` expected      podmanTest code expected = do       app <- loadOne (addCap code "network = True, rw = True")-      ctx <- Podenv.Application.prepare app Podenv.Application.Regular (Podenv.Context.Name "env")+      ctx <- Podenv.Application.prepare Podenv.Application.Regular app (Podenv.Context.Name "env")       Podenv.Runtime.podmanRunArgs defRe ctx (getImg ctx) `shouldBe` expected -    cliTest code args expectedCode = do-      cli@Podenv.Main.CLI {..} <- Podenv.Main.usage args-      config' <- loadConfig (Podenv.Main.selector cli) code-      (args', baseApp) <- mayFail $ Podenv.Config.select config' (maybeToList selector <> extraArgs)-      expected <- loadOne expectedCode+    getApp code args = do+      cli <- Podenv.Main.usage args+      (baseApp, _, _, re) <- Podenv.Main.cliConfigLoad (cli {Podenv.Main.configExpr = Just . mkConfig $ code})+      (_, app) <- Podenv.Build.prepare re baseApp+      pure app -      let got = Podenv.Main.cliPrepare cli args' baseApp+    cliTest gotCode args expectedCode = do+      got <- getApp gotCode args+      expected <- getApp expectedCode []       got `shouldBe` expected +    nixTest code args expectedCommand = do+      app <- getApp code args+      drop 3 (Podenv.Dhall.command app) `shouldBe` expectedCommand+     loadTest code expected = do       config' <- loadConfig Nothing code       let got = case config' of@@ -196,20 +208,18 @@     addCap code capCode =       "( " <> code <> " // { capabilities = (" <> code <> ").capabilities // {" <> capCode <> "}})" +    mkConfig code =+      pack $+        unlines+          [ "let Podenv = env:PODENV",+            "let Nix = Podenv.Nix",+            "let def = { capabilities = {=}, runtime = Podenv.Image \"ubi8\" }",+            "let env = def // { name = \"env\" }",+            "let env2 = env // { name = \"beta\" } in",+            code+          ]     loadConfig s code =-      Podenv.Config.load-        s-        ( Just-            . pack-            $ unlines-              [ "let Podenv = env:PODENV",-                "let Nix = Podenv.Nix",-                "let def = { capabilities = {=}, runtime = Podenv.Image \"ubi8\" }",-                "let env = def // { name = \"env\" }",-                "let env2 = env // { name = \"beta\" } in",-                code-              ]-        )+      Podenv.Config.load s (Just . mkConfig $ code)      loadOne code = do       config' <- loadConfig Nothing code