diff --git a/.git/modules/hub/HEAD b/.git/modules/hub/HEAD new file mode 100644 --- /dev/null +++ b/.git/modules/hub/HEAD @@ -0,0 +1,1 @@ +0cb06f35180a047ec98c30fb5fc14da7ea39cfc1 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## 0.1.0 (2022-05-02) + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + 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 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 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 those 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 + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,200 @@ +# podenv: a container wrapper + +> 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. +Using rootless containers, podenv let you run applications seamlessly. + +## Overview and scope + +The goal of podenv is to implement a modern application launcher: + +- [Highlevel capability system](#capabilities) +- [Multiple runtimes](#runtimes) +- [VPN network namespace](#namespace) +- [Functional configuration](#configuration) +- [Simple to use](#usages) + +Podenv differs from [toolbx](https://containertoolbx.org/) or [flatpak](https://flatpak.org/): + +- Isolation by default: network or home directory access need to be explicitely enabled. +- Unopinionated runtime: applications are provided by distro packages or Containerfile. +- High level command line interface. + +## Features + +### Capabilities + +Share resources with simple toggles: + +- `--wayland` graphical display. +- `--pipewire` access audio and video streams. +- `--dbus` share the dbus session. +- See the full list in this configuration schema: [Capabilities.Type](https://github.com/podenv/hub/blob/main/schemas/Capabilities.dhall) + +Mount directories with smart volumes: + +- `--volume ~` share the home directory. +- `--volume web:~` use a volume named `web` for the container home. +- `--hostfile ./document.pdf` share a single file. + +### Runtimes + +Podenv works with multiple runtimes: + +- Podman for container image and Containerfile. +- Bubblewrap for local rootfs and Nix Flakes. Checkout the [Howto use Nix tutorial](./docs/tutorials/nix.md). + +The runtime integration is decoupled from the application description +so that more options can be added in the future. + +### Namespace + +Applications can share resources using the `--namespace NAME` option. +For example, a browser application can be attached to the network of a VPN application. +Checkout the [Configure a VPN howto](./docs/howtos/vpn.md). + +### Configuration + +Applications are user-defined with functionnal and re-usable expressions: + +#### Firefox with a fedora container + +```dhall +Application::{ +, name = "firefox" +, description = Some "Mozilla Firefox" +, runtime = (./fedora.dhall).latest.useGraphic [ "firefox" ] +, command = [ "firefox", "--no-remote" ] +, capabilities = Capabilities::{ wayland = True, network = True } +} +``` + +The fedora useGraphic function defines a custom Containerfile: + +```dhall +\(pkgs : List Text) -> +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} + '' +, image_home = Some "/home/fedora" +, image_update = Some "dnf update -y" +} +``` + +> The graphic packages layer is shared by the other apps. + +#### Nix Flakes + +Podenv support the [Nix installables syntax](https://nixos.org/manual/nix/stable/command-ref/new-cli/nix.html#installables): + +```dhall +Application::{ +, name = "polyglot" +, description = Some "Tool to count lines of source code." +, runtime = Nix Flakes::{ installables = [ "github:podenv/polyglot.nix" ]} +, capabilities = Capabilities::{ cwd = True } +} +``` + +#### Hub + +By default, podenv uses the [podenv/hub](https://github.com/podenv/hub) collection. +Run `podenv --list` to see the available applications. + + +## 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). + + +# Documentation + +Podenv documentation is organized into the following [four sections][documentation]: + +[documentation]: https://www.divio.com/en/blog/documentation/ + +## Tutorials + +These guides help you get your hands dirty with working examples: + +* [Install and use podenv](./docs/tutorials/install.md) +* [Use an application](./docs/tutorials/use.md) +* [Create an application](./docs/tutorials/create.md) +* [Howto use Nix](./docs/tutorials/nix.md) + +## Howtos + +These cookbooks teach you how to solve specific tasks: + +* [Configure a VPN](./docs/howtos/vpn.md) +* [Setup a custom image](./docs/howtos/image.md) +* [Contribute to podenv](./docs/howtos/contribute.md) + +## Discussions + +These posts explain the context and motivation behind this tool: + +* [Declarative containers](./docs/discussions/declarative-containers.md) +* [Using dhall for configuration](./docs/discussions/dhall-configuration.md) +* [Roadmap](./docs/discussions/roadmap.md) + +## References + +These comprehensive resources cover details that other texts will gloss over: + +* [Command line](./docs/references/command-line.md) +* [Configuration](./docs/references/configuration.md) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Podenv.Main + +main :: IO () +main = Podenv.Main.main diff --git a/hub/Applications/_audinux.dhall b/hub/Applications/_audinux.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/_audinux.dhall @@ -0,0 +1,21 @@ +let Podenv = ../Podenv.dhall + +in \(description : Text) -> + \(packages : List Text) -> + \(command : Text) -> + Podenv.Application::{ + , description = Some description + , runtime = + Podenv.Container + ( (./fedora.dhall).useGraphicImage + "latest" + ((./fedora.dhall).useCopr "ycollet/audinux") + packages + ) + , command = [ command ] + , capabilities = Podenv.Capabilities::{ + , pipewire = True + , x11 = True + , alsa = True + } + } diff --git a/hub/Applications/_ccrdaMAO.dhall b/hub/Applications/_ccrdaMAO.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/_ccrdaMAO.dhall @@ -0,0 +1,31 @@ +let Podenv = ../Podenv.dhall + +let url = + let base = + "https://ccrma.stanford.edu/planetccrma/mirror/fedora/linux/planetccrma" + + let release = + "\$(rpm -E %fedora)/x86_64/planetccrma-repo-1.1-3.fc\$(rpm -E %fedora).ccrma.noarch.rpm" + + in "${base}/${release}" + +in \(description : Text) -> + \(packages : List Text) -> + \(command : Text) -> + \(alsa : Bool) -> + Podenv.Application::{ + , description = Some description + , runtime = + Podenv.Container + ( (./fedora.dhall).useGraphicImage + "latest" + "RUN rpm -Uvh ${url}" + packages + ) + , command = [ command ] + , capabilities = Podenv.Capabilities::{ + , pipewire = True + , x11 = True + , alsa + } + } diff --git a/hub/Applications/_graphicEditor.dhall b/hub/Applications/_graphicEditor.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/_graphicEditor.dhall @@ -0,0 +1,15 @@ +\(name : Text) -> +\(desc : Text) -> + let Podenv = ../Podenv.dhall + + in Podenv.Application::{ + , name + , description = Some desc + , command = [ name ] + , runtime = (./fedora.dhall).latest.useGraphic [ name ] + , capabilities = Podenv.Capabilities::{ + , hostfile = True + , wayland = True + , x11 = True + } + } diff --git a/hub/Applications/ardour.dhall b/hub/Applications/ardour.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/ardour.dhall @@ -0,0 +1,1 @@ +./_ccrdaMAO.dhall "Digital Audio Workstation" [ "ardour6" ] "ardour6" True diff --git a/hub/Applications/audacity.dhall b/hub/Applications/audacity.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/audacity.dhall @@ -0,0 +1,14 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Sound editor with graphical UI" + , runtime = + (./fedora.dhall).latest.useGraphic + [ "audacity", "alsa-plugins-pulseaudio" ] + , command = [ "audacity" ] + , capabilities = Podenv.Capabilities::{ + , pipewire = True + , pulseaudio = True + , wayland = True + } + } diff --git a/hub/Applications/blender.dhall b/hub/Applications/blender.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/blender.dhall @@ -0,0 +1,20 @@ +let default = + -- This is using nix because the fedora package doesn't come with ffmpeg + (../Podenv.dhall).Application::{ + , description = Some "3D creation suite" + , runtime = (./nix.dhall).uses [ ./nixGL.dhall ] [ "blender" ] + , command = [ "nixGLIntel", "blender" ] + , capabilities = (../Podenv.dhall).Capabilities::{ + , dri = True + , x11 = True + , pulseaudio = True + } + } + +let fedora = + default + // { runtime = (./fedora.dhall).latest.useGraphic [ "blender" ] + , command = [ "blender" ] + } + +in { default, fedora } diff --git a/hub/Applications/brave.dhall b/hub/Applications/brave.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/brave.dhall @@ -0,0 +1,40 @@ +let Podenv = ../Podenv.dhall + +let container = + let repo = + '' + [brave-browser] + name=created by dnf config-manager from https://brave-browser-rpm-release.s3.brave.com/x86_64/ + baseurl=https://brave-browser-rpm-release.s3.brave.com/x86_64/ + enabled=1 + '' + + let key = "https://brave-browser-rpm-release.s3.brave.com/brave-core.asc" + + let extra = + '' + RUN rpm --import ${key} + RUN echo -e ${Text/show repo} > /etc/yum.repos.d/brave-browser.repo + '' + + in \(packages : List Text) -> + Podenv.Container + ((./fedora.dhall).useGraphicCodecImage "latest" extra packages) + +let default = + Podenv.Application::{ + , description = Some "Brave Browser" + , runtime = container [ "brave-browser" ] + , command = [ "brave-browser" ] + , capabilities = Podenv.Capabilities::{ + , dbus = True + , network = True + , x11 = True + , dri = True + , video = True + , pipewire = True + , pulseaudio = True + } + } + +in { default } diff --git a/hub/Applications/centos.dhall b/hub/Applications/centos.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/centos.dhall @@ -0,0 +1,13 @@ +let Podenv = ../Podenv.dhall + +let image-ref = \(ver : Text) -> "registry.centos.org/centos:${ver}" + +let default = + Podenv.Application::{ + , name = "centos-7" + , description = Some "CentOS 7 shell" + , runtime = Podenv.Image (image-ref "7") + , volumes = [ "cache-yum-c7:/var/cache/yum" ] + } + +in { default } diff --git a/hub/Applications/chromium.dhall b/hub/Applications/chromium.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/chromium.dhall @@ -0,0 +1,14 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "open-source web browser" + , runtime = (./fedora.dhall).latest.useGraphicCodec [ "chromium" ] + , command = [ "chromium-browser" ] + , capabilities = Podenv.Capabilities::{ + , network = True + , wayland = True + , pipewire = True + , -- | chrome somehow still needs x11 + x11 = True + } + } diff --git a/hub/Applications/debian.dhall b/hub/Applications/debian.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/debian.dhall @@ -0,0 +1,25 @@ +-- | This application includes a builder +let Podenv = ../Podenv.dhall + +let debian = ../Builders/debian.dhall + +let mkUse = + \(version : Text) -> + \(packages : List Text) -> + Podenv.Container (debian.image version packages) + +let default = + \(version : Text) -> + Podenv.Application::{ + , description = Some "Debian ${version} shell" + , runtime = Podenv.Image (debian.image-ref version) + , volumes = debian.mkVolumes version + , capabilities = Podenv.Capabilities::{ + , terminal = True + , interactive = True + , network = True + , rw = True + } + } + +in { default = default "latest", bullseye.use = mkUse "bullseye" } diff --git a/hub/Applications/electrum.dhall b/hub/Applications/electrum.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/electrum.dhall @@ -0,0 +1,8 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Electrum is an easy to use Bitcoin client" + , runtime = (./fedora.dhall).latest.useGraphic [ "electrum" ] + , command = [ "electrum" ] + , capabilities = Podenv.Capabilities::{ network = True, wayland = True } + } diff --git a/hub/Applications/fbrnch.dhall b/hub/Applications/fbrnch.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/fbrnch.dhall @@ -0,0 +1,10 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Tool to update fedora packages branches" + , runtime = + (./fedora.dhall).latest.use + [ "fbrnch", "krb5-workstation", "openssh-clients" ] + , command = [ "fbrnch" ] + , capabilities = Podenv.Capabilities::{ network = True, cwd = True } + } diff --git a/hub/Applications/fedora.dhall b/hub/Applications/fedora.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/fedora.dhall @@ -0,0 +1,152 @@ +let Prelude = ../Prelude.dhall + +let Podenv = ../Podenv.dhall + +let fedora = ../Builders/fedora.dhall + +let mkUse = + \(version : Text) -> + \(pre-task : Text) -> + \(packages : List Text) -> + Podenv.Container (fedora.image version pre-task packages) + +let default = + \(version : Text) -> + Podenv.Application::{ + , runtime = Podenv.Image (fedora.image-ref (":" ++ version)) + , volumes = fedora.mkVolumes version + , capabilities = Podenv.Capabilities::{ + , terminal = True + , interactive = True + , network = True + , rw = True + , root = True + } + } + +let -- | Create a default app and use function + useD = + \(version : Text) -> { default = default version, use = mkUse version "" } + +let fusion-repo = + \(variant : Text) -> + \(ver : Text) -> + "https://download1.rpmfusion.org/${variant}/fedora/rpmfusion-${variant}-release-${ver}.noarch.rpm" + +let -- | Extra layer to install common graphic packages + extraGraphic = + let extra-pkgs = + [ "mesa-dri-drivers" + , "mesa-vulkan-drivers" + , "libglvnd-glx" + , "glxinfo" + , "gtk4" + , "qt5-qtwayland" + , "xdg-utils" + , "glx-utils" + , "harfbuzz-icu" + ] + # [ "dejavu-sans-mono-fonts", "dejavu-sans-mono-fonts" ] + # [ "xdg-dbus-proxy", "xdg-desktop-portal-gtk" ] + # [ "which" + , "findutils" + , "strace" + , "procps-ng" + , "file" + , "xz" + , "diffutils" + ] + # [ "pipewire-libs", "pulseaudio-libs", "pipewire-pulseaudio" ] + + in '' + RUN dnf install -y ${Prelude.Text.concatSep " " extra-pkgs} + '' + +let -- | Extra layer to install codec + -- See: https://fedoraproject.org/wiki/Firefox_Hardware_acceleration + extraGraphicCodec = + let -- | A list of packages that are often required but missing from the requirements + gfx-pkgs = + [ "ffmpeg" + , "libva" + , "libva-utils" + , "libva-intel-driver" + , "libvdpau-va-gl" + ] + + let repo = fusion-repo "free" "\$(rpm -E %fedora)" + + in '' + RUN dnf install -y ${repo} && dnf install -y ${Prelude.Text.concatSep + " " + gfx-pkgs} + '' + +let -- | Simpler helper where app == package == command + simples = + let -- | When the application name is the package and command name + mkUseSimple = + \(extra : Text) -> + \(name : Text) -> + \(desc : Text) -> + Podenv.Application::{ + , name + , description = Some desc + , runtime = mkUse "latest" extra [ name ] + , command = [ name ] + } + + in { useSimple = mkUseSimple "" + , useGraphicSimple = mkUseSimple extraGraphic + , useGraphicCodecSimple = + mkUseSimple (extraGraphic ++ extraGraphicCodec) + } + +let -- | Base image access for extra customization + images = + let mkUseImage = + \(extra : Text) -> + \(version : Text) -> + \(pre-task : Text) -> + fedora.image version (extra ++ pre-task) + + in { useImage = mkUseImage "" + , useGraphicImage = mkUseImage extraGraphic + , useGraphicCodecImage = + mkUseImage (extraGraphic ++ extraGraphicCodec) + } + +let base = + { default = default "latest" + , latest = + { use = mkUse "latest" "" + , useGraphic = mkUse "latest" extraGraphic + , useGraphicCodec = mkUse "latest" (extraGraphic ++ extraGraphicCodec) + } + , `34` = useD "34" + , rawhide = useD "rawhide" + , fusion = + let ver = "34" + + let mkVariant = + \(variant : Text) -> + \(extra : Text) -> + { use = + mkUse + ver + ( extra + ++ "RUN dnf install -y " + ++ fusion-repo variant ver + ) + } + + in mkVariant "free" "" + // { nonfree = + mkVariant "nonfree" (extraGraphic ++ extraGraphicCodec) + } + , useCopr = + \(name : Text) -> + "RUN dnf -y install dnf-plugins-core && dnf -y copr enable ${name}" + } + +in base // simples // images diff --git a/hub/Applications/feh.dhall b/hub/Applications/feh.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/feh.dhall @@ -0,0 +1,1 @@ +./_graphicEditor.dhall "feh" "Display an image file" diff --git a/hub/Applications/ffmpeg.dhall b/hub/Applications/ffmpeg.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/ffmpeg.dhall @@ -0,0 +1,9 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some + "A complete, cross-platform solution to record, convert and stream audio and video" + , runtime = (./fedora.dhall).latest.useGraphicCodec [ "ffmpeg" ] + , command = [ "ffmpeg" ] + , capabilities = Podenv.Capabilities::{ dri = True } + } diff --git a/hub/Applications/firefox.dhall b/hub/Applications/firefox.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/firefox.dhall @@ -0,0 +1,24 @@ +let Podenv = ../Podenv.dhall + +let minimal = + Podenv.Application::{ + , description = Some "Mozilla Firefox" + , runtime = (./fedora.dhall).latest.useGraphic [ "firefox" ] + , command = [ "firefox", "--no-remote" ] + , capabilities = Podenv.Capabilities::{ wayland = True, network = True } + } + +let default = + minimal + // { runtime = + (./fedora.dhall).latest.useGraphicCodec + [ "firefox" + , "gdouros-symbola-fonts" + , "pipewire-pulseaudio" + , "mozilla-ublock-origin" + ] + , capabilities = + minimal.capabilities // { dri = True, pulseaudio = True } + } + +in { default, minimal } diff --git a/hub/Applications/flutter.dhall b/hub/Applications/flutter.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/flutter.dhall @@ -0,0 +1,23 @@ +(../Podenv.dhall).Application::{ +, description = Some "Flutter SDK" +, runtime = + (./nix.dhall).uses + [ ./nixGL.dhall ] + [ "flutter" + , "clang" + , "pkg-config" + , "gtk3" + , "pcre" + , "epoxy" + , "glib.dev" + , "mount" + ] +, command = [ "nixGLIntel", "bash" ] +, capabilities = (../Podenv.dhall).Capabilities::{ + , terminal = True + , interactive = True + , dri = True + , x11 = True + , pulseaudio = True + } +} diff --git a/hub/Applications/gimp.dhall b/hub/Applications/gimp.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/gimp.dhall @@ -0,0 +1,1 @@ +./_graphicEditor.dhall "gimp" "Raster graphics editor" diff --git a/hub/Applications/google-chrome.dhall b/hub/Applications/google-chrome.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/google-chrome.dhall @@ -0,0 +1,17 @@ +let Podenv = ../Podenv.dhall + +let packages = + [ "https://dl.google.com/linux/direct/google-chrome-stable_current_x86_64.rpm" + ] + +in Podenv.Application::{ + , description = Some "Cross-platform web browser developed by Google" + , runtime = (./fedora.dhall).latest.useGraphicCodec packages + , command = [ "google-chrome" ] + , capabilities = Podenv.Capabilities::{ + , network = True + , wayland = True + , -- | chrome somehow still needs x11 + x11 = True + } + } diff --git a/hub/Applications/gworldclock.dhall b/hub/Applications/gworldclock.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/gworldclock.dhall @@ -0,0 +1,8 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Displays time and date in specified time zones." + , runtime = (./debian.dhall).bullseye.use [ "gworldclock" ] + , command = [ "gworldclock" ] + , capabilities = Podenv.Capabilities::{ x11 = True } + } diff --git a/hub/Applications/hydrogen.dhall b/hub/Applications/hydrogen.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/hydrogen.dhall @@ -0,0 +1,1 @@ +./_ccrdaMAO.dhall "Drum Machine" [ "hydrogen" ] "hydrogen" False diff --git a/hub/Applications/inkscape.dhall b/hub/Applications/inkscape.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/inkscape.dhall @@ -0,0 +1,1 @@ +./_graphicEditor.dhall "inkscape" "Open a svg file" diff --git a/hub/Applications/kigo.dhall b/hub/Applications/kigo.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/kigo.dhall @@ -0,0 +1,8 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Go Board game" + , runtime = (./fedora.dhall).latest.useGraphic [ "kigo", "dbus-x11" ] + , command = [ "kigo" ] + , capabilities = Podenv.Capabilities::{ pulseaudio = True, x11 = True } + } diff --git a/hub/Applications/librecad.dhall b/hub/Applications/librecad.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/librecad.dhall @@ -0,0 +1,1 @@ +./_graphicEditor.dhall "librecad" "Free Open Source 2D CAD" diff --git a/hub/Applications/libreoffice.dhall b/hub/Applications/libreoffice.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/libreoffice.dhall @@ -0,0 +1,1 @@ +./_graphicEditor.dhall "libreoffice" "Open-Source office suite" diff --git a/hub/Applications/linphone.dhall b/hub/Applications/linphone.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/linphone.dhall @@ -0,0 +1,7 @@ + (./fedora.dhall).useGraphicSimple "linphone" "Open Source VOIP project" +// { capabilities = (../Podenv.dhall).Capabilities::{ + , network = True + , pulseaudio = True + , x11 = True + } + } diff --git a/hub/Applications/lmms.dhall b/hub/Applications/lmms.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/lmms.dhall @@ -0,0 +1,1 @@ +./_audinux.dhall "Let's make music" [ "lmms" ] "lmms" diff --git a/hub/Applications/maim.dhall b/hub/Applications/maim.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/maim.dhall @@ -0,0 +1,7 @@ +let default = + (./fedora.dhall).useSimple "maim" "Screen capturing application (x11)" + // { capabilities = (../Podenv.dhall).Capabilities::{ x11 = True } } + +let capture = default // { command = [ "maim", "-s", "-o", "-u" ] } + +in { default, capture } diff --git a/hub/Applications/mplayer.dhall b/hub/Applications/mplayer.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/mplayer.dhall @@ -0,0 +1,12 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Media player software" + , runtime = (./fedora.dhall).latest.useGraphicCodec [ "mplayer" ] + , command = [ "mplayer" ] + , capabilities = Podenv.Capabilities::{ + , dri = True + , pulseaudio = True + , wayland = True + } + } diff --git a/hub/Applications/mumble.dhall b/hub/Applications/mumble.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/mumble.dhall @@ -0,0 +1,12 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "VoIP solution" + , runtime = (./fedora.dhall).latest.useGraphic [ "mumble", "opus" ] + , command = [ "mumble" ] + , capabilities = Podenv.Capabilities::{ + , network = True + , pulseaudio = True + , wayland = True + } + } diff --git a/hub/Applications/mupdf.dhall b/hub/Applications/mupdf.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/mupdf.dhall @@ -0,0 +1,1 @@ +./_graphicEditor.dhall "mupdf" "Display a pdf file" diff --git a/hub/Applications/muse.dhall b/hub/Applications/muse.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/muse.dhall @@ -0,0 +1,1 @@ +./_ccrdaMAO.dhall "Multitrack Virtual Studio" [ "muse" ] "muse4" False diff --git a/hub/Applications/musescore.dhall b/hub/Applications/musescore.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/musescore.dhall @@ -0,0 +1,2 @@ + ./_ccrdaMAO.dhall "Notation Software" [ "musescore" ] "musescore" True +// { capabilities = { pipewire = True, x11 = True, alsa = True, dri = True } } diff --git a/hub/Applications/network.dhall b/hub/Applications/network.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/network.dhall @@ -0,0 +1,13 @@ +-- | Network utility +let Podenv = ../Podenv.dhall + +let http-server = + \(port : Text) -> + Podenv.Application::{ + , runtime = Podenv.Image ((../Builders/fedora.dhall).image-ref "latest") + , command = [ "python3", "-u", "-m", "http.server", port ] + , namespace = Some "host" + , capabilities = Podenv.Capabilities::{ network = True, cwd = True } + } + +in { http-server } diff --git a/hub/Applications/nix.dhall b/hub/Applications/nix.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/nix.dhall @@ -0,0 +1,63 @@ +let Podenv = ../Podenv.dhall + +let setup = ../Builders/nix.dhall + +let -- | A pinned reference for the nixpkgs + nixpkgs = + "github:NixOS/nixpkgs/7954a245e70238e08078baef7ff6459a67e229c3" + +let -- | Setup a Nix runtime with custom installables and nixpkgs packages. + uses = + \(qualifiedInstallables : List Text) -> + \(pkgs : List Text) -> + Podenv.Nix + Podenv.Flakes::{ + , nixpkgs = Some nixpkgs + , installables = + qualifiedInstallables + # (../Prelude.dhall).List.map + Text + Text + (\(pkgs : Text) -> "${nixpkgs}#${pkgs}") + pkgs + } + +let usesExample = + assert + : uses [ "flakes/url" ] [ "bash" ] + === Podenv.Nix + Podenv.Flakes::{ + , nixpkgs = Some nixpkgs + , installables = [ "flakes/url", "${nixpkgs}#bash" ] + } + +let -- | Setup a Nix runtime with nixpkgs packages + use = + uses ([] : List Text) + +let -- | Setup a Nix runtime + useInstallables = + \(installables : List Text) -> Podenv.Nix Podenv.Flakes::{ installables } + +let useExample = + assert + : use [ "bash" ] + === Podenv.Nix + Podenv.Flakes::{ + , nixpkgs = Some nixpkgs + , installables = [ "${nixpkgs}#bash" ] + } + +let default = + Podenv.Application::{ + , description = Some "Run the nix command" + , capabilities = Podenv.Capabilities::{ + , terminal = True + , interactive = True + , network = True + } + , runtime = use [ "nix" ] + , command = [ "nix" ] + } + +in { setup, use, uses, useInstallables, default } diff --git a/hub/Applications/nixGL.dhall b/hub/Applications/nixGL.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/nixGL.dhall @@ -0,0 +1,4 @@ +-- | An Installable nixGL +let commit = "569f95d9577154b26d5ce774895fee727f070455" + +in "github:guibou/nixGL/${commit}#nixGLIntel" diff --git a/hub/Applications/nixify.dhall b/hub/Applications/nixify.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/nixify.dhall @@ -0,0 +1,22 @@ +let Podenv = ../Podenv.dhall + +let setup = ../Builders/nix.dhall + +let -- | Add nix to the application environment + nixify = + \(app : Podenv.Application.Type) -> + app + // { environ = + app.environ + # [ "NIX_SSL_CERT_FILE=/etc/pki/tls/certs/ca-bundle.crt" + , "PATH=/nix/var/nix/profiles/nix-install/bin:/bin:/sbin" + ] + , volumes = + app.volumes + # [ "nix-store:/nix" + , "nix-config:~/.config/nix" + , "nix-cache:~/.cache/nix" + ] + } + +in nixify diff --git a/hub/Applications/obs.dhall b/hub/Applications/obs.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/obs.dhall @@ -0,0 +1,14 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Open Broadcaster Software" + , runtime = (./fedora.dhall).latest.useGraphicCodec [ "obs-studio" ] + , command = [ "obs" ] + , capabilities = Podenv.Capabilities::{ + , wayland = True + , dri = True + , dbus = True + , video = True + , pipewire = True + } + } diff --git a/hub/Applications/openvpn.dhall b/hub/Applications/openvpn.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/openvpn.dhall @@ -0,0 +1,13 @@ +(../Podenv.dhall).Application::{ +, description = Some "VPN solution" +, runtime = (./fedora.dhall).latest.use [ "openvpn", "iproute" ] +, command = [ "openvpn" ] +, syscaps = [ "NET_ADMIN", "SYS_RESOURCE", "SETUID", "SETGID" ] +, capabilities = (../Podenv.dhall).Capabilities::{ + , root = True + , network = True + , tun = True + , interactive = True + , terminal = True + } +} diff --git a/hub/Applications/package.dhall b/hub/Applications/package.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/package.dhall @@ -0,0 +1,58 @@ +{ audacity = ./audacity.dhall +, ardour = ./ardour.dhall +, blender = ./blender.dhall +, brave = ./brave.dhall +, centos = ./centos.dhall +, chromium = ./chromium.dhall +, debian = ./debian.dhall +, electrum = ./electrum.dhall +, fbrnch = ./fbrnch.dhall +, fedora = ./fedora.dhall +, feh = ./feh.dhall +, firefox = ./firefox.dhall +, flutter = ./flutter.dhall +, ffmpeg = ./ffmpeg.dhall +, gimp = ./gimp.dhall +, google-chrome = ./google-chrome.dhall +, gworldclock = ./gworldclock.dhall +, hydrogen = ./hydrogen.dhall +, inkscape = ./inkscape.dhall +, kigo = ./kigo.dhall +, librecad = ./librecad.dhall +, libreoffice = ./libreoffice.dhall +, linphone = ./linphone.dhall +, lmms = ./lmms.dhall +, maim = ./maim.dhall +, mplayer = ./mplayer.dhall +, mumble = ./mumble.dhall +, mupdf = ./mupdf.dhall +, muse = ./muse.dhall +, musescore = ./musescore.dhall +, network = ./network.dhall +, nix = ./nix.dhall +, nixify = ./nixify.dhall +, obs = ./obs.dhall +, openvpn = ./openvpn.dhall +, polyglot = ./polyglot.dhall +, pwsafe = ./pwsafe.dhall +, qjackctl = ./qjackctl.dhall +, qtractor = ./qtractor.dhall +, reaper = ./reaper.dhall +, rosegarden = ./rosegarden.dhall +, seq24 = ./seq24.dhall +, shell = ./shell.dhall +, ssh = ./ssh.dhall +, steam = ./steam.dhall +, streamtuner = ./streamtuner.dhall +, supercollider = ./supercollider.dhall +, tor = ./tor.dhall +, vcv = ./vcv.dhall +, virt-viewer = ./virt-viewer.dhall +, vlc = ./vlc.dhall +, vmpk = ./vmpk.dhall +, vnc-viewer = ./vnc-viewer.dhall +, vscode = ./vscode.dhall +, xeyes = ./xeyes.dhall +, youtube-dl = ./youtube-dl.dhall +, zeal = ./zeal.dhall +} diff --git a/hub/Applications/polyglot.dhall b/hub/Applications/polyglot.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/polyglot.dhall @@ -0,0 +1,5 @@ +(../Podenv.dhall).Application::{ +, description = Some "Tool to count lines of source code." +, runtime = (./nix.dhall).useInstallables [ "github:podenv/polyglot.nix" ] +, capabilities = (../Podenv.dhall).Capabilities::{ cwd = True } +} diff --git a/hub/Applications/pwsafe.dhall b/hub/Applications/pwsafe.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/pwsafe.dhall @@ -0,0 +1,23 @@ +let Podenv = ../Podenv.dhall + +let default = + Podenv.Application::{ + , description = Some + "A unix commandline program that manages encrypted password databases" + , runtime = (./fedora.dhall).latest.use [ "pwsafe", "wl-clipboard" ] + , capabilities = Podenv.Capabilities::{ + , terminal = True + , interactive = True + } + } + +let copy = + \(name : Text) -> + default + // { description = Some "Copy a password to the wayland clipboard" + , capabilities = default.capabilities // { wayland = True } + , command = + [ "sh", "-c", "pwsafe -E -p ${name} | wl-copy -f -o -p" ] + } + +in { default, copy } diff --git a/hub/Applications/qjackctl.dhall b/hub/Applications/qjackctl.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/qjackctl.dhall @@ -0,0 +1,12 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Qt based JACK control application" + , runtime = + (./nix.dhall).useInstallables [ "github:podenv/modularix#qjackctl" ] + , capabilities = Podenv.Capabilities::{ + , pipewire = True + , x11 = True + , alsa = True + } + } diff --git a/hub/Applications/qtractor.dhall b/hub/Applications/qtractor.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/qtractor.dhall @@ -0,0 +1,5 @@ +./_ccrdaMAO.dhall + "Audio/MIDI multi-track sequencer" + [ "qtractor" ] + "qtractor" + True diff --git a/hub/Applications/reaper.dhall b/hub/Applications/reaper.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/reaper.dhall @@ -0,0 +1,9 @@ +(../Podenv.dhall).Application::{ +, description = Some "Complete digital audio production application" +, runtime = (./nix.dhall).useInstallables [ "github:podenv/modularix#reaper" ] +, capabilities = (../Podenv.dhall).Capabilities::{ + , dri = True + , x11 = True + , pipewire = True + } +} diff --git a/hub/Applications/rosegarden.dhall b/hub/Applications/rosegarden.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/rosegarden.dhall @@ -0,0 +1,5 @@ +./_ccrdaMAO.dhall + "Digital Audio Workstation" + [ "rosegarden4" ] + "rosegarden" + True diff --git a/hub/Applications/seq24.dhall b/hub/Applications/seq24.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/seq24.dhall @@ -0,0 +1,1 @@ +./_audinux.dhall "MIDI loops sequencer" [ "seq24" ] "seq24" diff --git a/hub/Applications/shell.dhall b/hub/Applications/shell.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/shell.dhall @@ -0,0 +1,9 @@ +(../Podenv.dhall).Application::{ +, description = Some "A simple terminal" +, capabilities = (../Podenv.dhall).Capabilities::{ + , terminal = True + , interactive = True + , network = True + } +, runtime = (../Podenv.dhall).Image "ubi8" +} diff --git a/hub/Applications/ssh.dhall b/hub/Applications/ssh.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/ssh.dhall @@ -0,0 +1,17 @@ +let Podenv = ../Podenv.dhall + +let client = + \(host : Text) -> + Podenv.Application::{ + , description = Some "OpenSSH client" + , runtime = (./fedora.dhall).latest.use [ "openssh-clients" ] + , command = [ "ssh", host ] + , capabilities = Podenv.Capabilities::{ + , ssh = True + , network = True + , terminal = True + , interactive = True + } + } + +in { client } diff --git a/hub/Applications/steam.dhall b/hub/Applications/steam.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/steam.dhall @@ -0,0 +1,14 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Steam" + , command = [ "steam" ] + , runtime = (./fedora.dhall).fusion.nonfree.use [ "steam", "pciutils" ] + , capabilities = Podenv.Capabilities::{ + , dri = True + , x11 = True + , pulseaudio = True + , network = True + , privileged = True + } + } diff --git a/hub/Applications/streamtuner.dhall b/hub/Applications/streamtuner.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/streamtuner.dhall @@ -0,0 +1,12 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "An internet radio browser" + , runtime = (./fedora.dhall).latest.useGraphic [ "streamtuner" ] + , command = [ "streamtuner2" ] + , capabilities = Podenv.Capabilities::{ + , x11 = True + , network = True + , pulseaudio = True + } + } diff --git a/hub/Applications/supercollider.dhall b/hub/Applications/supercollider.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/supercollider.dhall @@ -0,0 +1,15 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some + "Programming environment for real-time audio and video processing" + , runtime = + (./fedora.dhall).latest.useGraphicCodec + [ "supercollider", "pipewire-jack-audio-connection-kit" ] + , command = [ "scide" ] + , capabilities = Podenv.Capabilities::{ + , dri = True + , x11 = True + , pipewire = True + } + } diff --git a/hub/Applications/tor.dhall b/hub/Applications/tor.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/tor.dhall @@ -0,0 +1,24 @@ +let Podenv = ../Podenv.dhall + +let browser = + Podenv.Application::{ + , description = Some "Tor browser" + , runtime = + (./fedora.dhall).latest.use + [ "torbrowser-launcher" + , "dbus-glib" + , "qt5-qtwayland" + , "libXt" + , "gtk3" + ] + , command = + [ "sh", "-c", "torbrowser-launcher; echo Press enter to exit; read" ] + , capabilities = Podenv.Capabilities::{ + , network = True + , x11 = True + , interactive = True + } + , volumes = [ "data-tb:~/" ] + } + +in { browser } diff --git a/hub/Applications/vcv.dhall b/hub/Applications/vcv.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/vcv.dhall @@ -0,0 +1,10 @@ +(../Podenv.dhall).Application::{ +, description = Some "The EuroRack simulator" +, runtime = (./nix.dhall).useInstallables [ "github:podenv/modularix#vcv" ] +, capabilities = (../Podenv.dhall).Capabilities::{ + , dri = True + , x11 = True + , pipewire = True + , alsa = True + } +} diff --git a/hub/Applications/virt-viewer.dhall b/hub/Applications/virt-viewer.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/virt-viewer.dhall @@ -0,0 +1,9 @@ +(../Podenv.dhall).Application::{ +, description = Some "Display the graphical console for a virtual machine" +, runtime = (./fedora.dhall).latest.useGraphic [ "virt-viewer" ] +, command = [ "remote-viewer" ] +, capabilities = (../Podenv.dhall).Capabilities::{ + , wayland = True + , network = True + } +} diff --git a/hub/Applications/vlc.dhall b/hub/Applications/vlc.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/vlc.dhall @@ -0,0 +1,9 @@ +(../Podenv.dhall).Application::{ +, description = Some "Media Player" +, runtime = (./nix.dhall).use [ "vlc" ] +, capabilities = (../Podenv.dhall).Capabilities::{ + , dri = True + , x11 = True + , pulseaudio = True + } +} diff --git a/hub/Applications/vmpk.dhall b/hub/Applications/vmpk.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/vmpk.dhall @@ -0,0 +1,8 @@ +let Podenv = ../Podenv.dhall + +in Podenv.Application::{ + , description = Some "Virtual MIDI Piano Keyboard" + , runtime = (./fedora.dhall).latest.useGraphic [ "vmpk" ] + , command = [ "vmpk" ] + , capabilities = Podenv.Capabilities::{ pipewire = True, wayland = True } + } diff --git a/hub/Applications/vnc-viewer.dhall b/hub/Applications/vnc-viewer.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/vnc-viewer.dhall @@ -0,0 +1,6 @@ +(../Podenv.dhall).Application::{ +, description = Some "Remote display client" +, runtime = (./fedora.dhall).latest.useGraphic [ "tigervnc" ] +, command = [ "vncviewer" ] +, capabilities = (../Podenv.dhall).Capabilities::{ x11 = True, network = True } +} diff --git a/hub/Applications/vscode.dhall b/hub/Applications/vscode.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/vscode.dhall @@ -0,0 +1,35 @@ +-- | This application includes a custom runtime to install the upstream repository key. +let Podenv = ../Podenv.dhall + +let container = + let repo = + '' + [code] + name=Visual Studio Code + baseurl=https://packages.microsoft.com/yumrepos/vscode + enabled=1 + gpgcheck=1 + gpgkey=https://packages.microsoft.com/keys/microsoft.asc + '' + + let key = "https://packages.microsoft.com/keys/microsoft.asc" + + let extra = + '' + RUN rpm --import ${key} + RUN echo -e ${Text/show repo} > /etc/yum.repos.d/vscode.repo + '' + + in \(packages : List Text) -> + Podenv.Container + ((./fedora.dhall).useGraphicCodecImage "latest" extra packages) + +let default = + Podenv.Application::{ + , description = Some "Code editing" + , runtime = container [ "code", "iproute" ] + , command = [ "code", "--wait" ] + , capabilities = Podenv.Capabilities::{ wayland = True, x11 = True } + } + +in { default } diff --git a/hub/Applications/xeyes.dhall b/hub/Applications/xeyes.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/xeyes.dhall @@ -0,0 +1,6 @@ +(../Podenv.dhall).Application::{ +, description = Some "Test graphical setup" +, runtime = (./fedora.dhall).`34`.use [ "xeyes" ] +, command = [ "xeyes" ] +, capabilities = (../Podenv.dhall).Capabilities::{ x11 = True } +} diff --git a/hub/Applications/youtube-dl.dhall b/hub/Applications/youtube-dl.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/youtube-dl.dhall @@ -0,0 +1,9 @@ + (./fedora.dhall).useSimple + "youtube-dl" + "command-line program to download videos" +// { capabilities = (../Podenv.dhall).Capabilities::{ + , network = True + , cwd = True + , terminal = True + } + } diff --git a/hub/Applications/zeal.dhall b/hub/Applications/zeal.dhall new file mode 100644 --- /dev/null +++ b/hub/Applications/zeal.dhall @@ -0,0 +1,6 @@ + (./fedora.dhall).useGraphicSimple + "zeal" + "Offline documentation browser inspired by Dash" +// { volumes = [ "cache-zeal:~" ] + , capabilities = (../Podenv.dhall).Capabilities::{ x11 = True } + } diff --git a/hub/Builders/debian.dhall b/hub/Builders/debian.dhall new file mode 100644 --- /dev/null +++ b/hub/Builders/debian.dhall @@ -0,0 +1,26 @@ +let Prelude = ../Prelude.dhall + +let Podenv = ../Podenv.dhall + +let image-ref = \(ver : Text) -> "docker.io/library/debian:${ver}" + +let mkVolumes = \(ver : Text) -> [ "cache-apt-${ver}:/var/cache/apt" ] + +let image = + \(ver : Text) -> + \(pkgs : List Text) -> + Podenv.ContainerBuild::{ + , containerfile = + '' + FROM ${image-ref ver} + ARG USER_UID + RUN ${./mkUser.dhall "debian"} + RUN apt-get update + RUN apt-get install -y ${Prelude.Text.concatSep " " pkgs} + '' + , image_volumes = mkVolumes ver + , image_home = Some "/home/debian" + , image_update = Some "apt-get update" + } + +in { image-ref, mkVolumes, image } diff --git a/hub/Builders/fedora.dhall b/hub/Builders/fedora.dhall new file mode 100644 --- /dev/null +++ b/hub/Builders/fedora.dhall @@ -0,0 +1,31 @@ +let Prelude = ../Prelude.dhall + +let Podenv = ../Podenv.dhall + +let image-ref = \(ver : Text) -> "registry.fedoraproject.org/fedora${ver}" + +let mkVolumes = \(ver : Text) -> [ "cache-dnf-${ver}:/var/cache/dnf" ] + +let base-image = + \(from : Text) -> + \(ver : Text) -> + \(pre-task : Text) -> + \(pkgs : List Text) -> + Podenv.ContainerBuild::{ + , containerfile = + '' + FROM ${from} + ARG USER_UID + RUN ${./mkUser.dhall "fedora"} + ${pre-task} + RUN dnf update -y + RUN dnf install -y ${Prelude.Text.concatSep " " pkgs} + '' + , image_volumes = mkVolumes ver + , image_home = Some "/home/fedora" + , image_update = Some "dnf update -y" + } + +let image = \(ver : Text) -> base-image (image-ref (":" ++ ver)) ver + +in { image-ref, mkVolumes, base-image, image } diff --git a/hub/Builders/mkUser.dhall b/hub/Builders/mkUser.dhall new file mode 100644 --- /dev/null +++ b/hub/Builders/mkUser.dhall @@ -0,0 +1,6 @@ +let uid = "\${USER_UID}" + +in \(name : Text) -> + "useradd -u ${uid} -d /home/${name} -m ${name} && " + ++ "mkdir -p /home/${name}/.cache /home/${name}/.config /run/user/${uid} /run/user/0 && " + ++ "chown -R ${uid}:${uid} /home/${name} /run/user/" diff --git a/hub/Builders/nix.dhall b/hub/Builders/nix.dhall new file mode 100644 --- /dev/null +++ b/hub/Builders/nix.dhall @@ -0,0 +1,48 @@ +-- | The default nix builder +let Prelude = ../Prelude.dhall + +let Podenv = ../Podenv.dhall + +let home = "/home/user" + +in Podenv.Application::{ + , description = Some "Setup the nix store" + , capabilities = Podenv.Capabilities::{ network = True } + , command = + let version = "2.8.0" + + let hash = + "0b32afd8c9147532bf8ce8908395b1b4d6dde9bedb0fcf5ace8b9fe0bd4c075c" + + let default-config = + '' + sandbox = false + build-users-group = + experimental-features = nix-command flakes + '' + + let args = + [ "test -d /nix/var || (" + , Prelude.Text.concatSep + " && " + [ "cd /tmp" + , "curl -OL https://nixos.org/releases/nix/nix-${version}/nix-${version}-x86_64-linux.tar.xz" + , "echo '${hash} nix-${version}-x86_64-linux.tar.xz' | sha256sum -c" + , "tar xf nix-${version}-x86_64-linux.tar.xz" + , "/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" + ] + , "); test -f ~/.config/nix/nix.conf || (" + , "echo -en ${Text/show default-config} > ~/.config/nix/nix.conf" + , "); /nix/var/nix/profiles/nix-install/bin/nix --version" + ] + + in [ "bash", "-c", Prelude.Text.concatSep " " args ] + , volumes = + [ "nix-store:/nix", "nix-config:~/.config/nix", "nix-setup-home:~/" ] + , runtime = Podenv.Rootfs "/" + } diff --git a/hub/Podenv.dhall b/hub/Podenv.dhall new file mode 100644 --- /dev/null +++ b/hub/Podenv.dhall @@ -0,0 +1,1 @@ +./schemas/package.dhall diff --git a/hub/Prelude.dhall b/hub/Prelude.dhall new file mode 100644 --- /dev/null +++ b/hub/Prelude.dhall @@ -0,0 +1,35 @@ +{- This file provides a central `Prelude` import for the rest of the library to + use so that the integrity check only needs to be updated in one place + whenever upgrading the interpreter. + + This allows the user to provide their own Prelude import using the + `DHALL_PRELUDE` environment variable, like this: + + ``` + $ export DHALL_PRELUDE='https://prelude.dhall-lang.org/package.dhall sha256:...' + ``` + + Note that overriding the Prelude in this way only works if this repository + is imported locally. Remote imports do not have access to environment + variables and any attempt to import one will fall back to the next available + import. To learn more, read: + + * https://github.com/dhall-lang/dhall-lang/wiki/Safety-guarantees#cross-site-scripting-xss + + This file also provides an import without the integrity check as a slower + fallback if the user is using a different version of the Dhall interpreter. + + This pattern is documented in the dhall-nethack repo: + + * https://github.com/dhall-lang/dhall-nethack/blob/master/Prelude.dhall +-} + env:DHALL_PRELUDE +? { Text.concatSep + = + https://prelude.dhall-lang.org/v17.0.0/Text/concatSep + sha256:e4401d69918c61b92a4c0288f7d60a6560ca99726138ed8ebc58dca2cd205e58 + , List.map + = + https://prelude.dhall-lang.org/v17.0.0/List/map + sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 + } diff --git a/hub/package.dhall b/hub/package.dhall new file mode 100644 --- /dev/null +++ b/hub/package.dhall @@ -0,0 +1,2 @@ +-- | Welcome to the hub package. +./schemas/package.dhall // { Hub = ./Applications/package.dhall } diff --git a/hub/schemas/Application.dhall b/hub/schemas/Application.dhall new file mode 100644 --- /dev/null +++ b/hub/schemas/Application.dhall @@ -0,0 +1,31 @@ +{ Type = + { -- | The application name, default to the parent key. + name : Text + , description : Optional Text + , -- | The application runtime. + runtime : ./Runtime.dhall + , -- | An optional namespace name. + namespace : Optional Text + , -- | The application capabilities. + capabilities : (./Capabilities.dhall).Type + , -- | List of system capabilities(7). + syscaps : List Text + , -- | Process environment. + environ : List Text + , -- | Extra volumes. + volumes : List Text + , -- | Optional command and its argument. + command : List Text + } +, default = + { -- The name defaults to the cli selector + name = "" + , description = None Text + , namespace = None Text + , capabilities = (./Capabilities.dhall).default + , syscaps = [] : List Text + , environ = [] : List Text + , volumes = [] : List Text + , command = [] : List Text + } +} diff --git a/hub/schemas/Capabilities.dhall b/hub/schemas/Capabilities.dhall new file mode 100644 --- /dev/null +++ b/hub/schemas/Capabilities.dhall @@ -0,0 +1,67 @@ +{ Type = + { -- Process i/o + -- + -- | Attach a terminal, imply interactive + terminal : Bool + , -- | Attach stdin + interactive : Bool + , -- + -- Process perms + -- + -- | Run as root + root : Bool + , -- | Mount the rootfs as read write + rw : Bool + , -- | Run with extra privileges + privileged : Bool + , -- + -- Host service + -- + wayland : Bool + , pipewire : Bool + , dbus : Bool + , pulseaudio : Bool + , x11 : Bool + , ssh : Bool + , gpg : Bool + , -- + -- Host devices + -- + video : Bool + , dri : Bool + , kvm : Bool + , alsa : Bool + , network : Bool + , tun : Bool + , -- + -- Host filesystem + -- + -- | Mount the current working directory + cwd : Bool + , -- | Mount host paths given on the cli + hostfile : Bool + } +, -- todo: codegen the defaults + default = + { terminal = False + , interactive = False + , root = False + , privileged = False + , rw = False + , wayland = False + , pipewire = False + , dbus = False + , pulseaudio = False + , x11 = False + , ssh = False + , gpg = False + , video = False + , dri = False + , kvm = False + , alsa = False + , network = False + , tun = False + , cwd = False + , hostfile = False + } +} diff --git a/hub/schemas/ContainerBuild.dhall b/hub/schemas/ContainerBuild.dhall new file mode 100644 --- /dev/null +++ b/hub/schemas/ContainerBuild.dhall @@ -0,0 +1,18 @@ +-- | How to build a local container image +{ Type = + { containerfile : Text + , -- TODO: this atttribute should be named `volumes`, but this is not possible until https://github.com/dhall-lang/dhall-haskell/pull/2285 + image_volumes : List Text + , -- TODO: this attribute should be named `image` + image_name : Optional Text + , -- TODO: this attribute should be named `home` + image_home : Optional Text + , image_update : Optional Text + } +, default = + { image_volumes = [] : List Text + , image_name = None Text + , image_home = None Text + , image_update = None Text + } +} diff --git a/hub/schemas/Flakes.dhall b/hub/schemas/Flakes.dhall new file mode 100644 --- /dev/null +++ b/hub/schemas/Flakes.dhall @@ -0,0 +1,12 @@ +-- | A podenv nix runtime description: +-- +-- - `nixpkgs` is an optional pin for the main package set +-- when set, this is added to the nix command: ["--override-input" "nixpkgs" "${nixpkgs}"] +-- so that installables inputs share the same set. +-- This is necessary for nixGL, see: https://github.com/guibou/nixGL/pull/97 +-- - `installables` is a list of nix flakes, +-- see: https://nixos.org/manual/nix/stable/command-ref/new-cli/nix.html#installables +-- +{ Type = { nixpkgs : Optional Text, installables : List Text } +, default.nixpkgs = None Text +} diff --git a/hub/schemas/Runtime.dhall b/hub/schemas/Runtime.dhall new file mode 100644 --- /dev/null +++ b/hub/schemas/Runtime.dhall @@ -0,0 +1,10 @@ +-- | The application runtime: +-- Image: an existing image ref +-- Nix: a nix expression +-- Container: a static container build +-- Rootfs: a local directory +< Image : Text +| Nix : (./Flakes.dhall).Type +| Container : (./ContainerBuild.dhall).Type +| Rootfs : Text +> diff --git a/hub/schemas/System.dhall b/hub/schemas/System.dhall new file mode 100644 --- /dev/null +++ b/hub/schemas/System.dhall @@ -0,0 +1,4 @@ +-- | The global system configuration. +{ Type = { dns : Optional Text, data_volumes_dir : Optional Text } +, default = { dns = None Text, data_volumes_dir = None Text } +} diff --git a/hub/schemas/package.dhall b/hub/schemas/package.dhall new file mode 100644 --- /dev/null +++ b/hub/schemas/package.dhall @@ -0,0 +1,19 @@ +{ Application = ./Application.dhall +, Capabilities = ./Capabilities.dhall +, ContainerBuild = ./ContainerBuild.dhall +, System = ./System.dhall +, Image = (./Runtime.dhall).Image +, Nix = (./Runtime.dhall).Nix +, Flakes = ./Flakes.dhall +, Container = (./Runtime.dhall).Container +, Rootfs = (./Runtime.dhall).Rootfs +, Containerfile = + let -- "A helper function to simplify documentation..." + func + : Text -> ./Runtime.dhall + = \(containerfile : Text) -> + (./Runtime.dhall).Container + (./ContainerBuild.dhall)::{ containerfile } + + in func +} diff --git a/podenv.cabal b/podenv.cabal new file mode 100644 --- /dev/null +++ b/podenv.cabal @@ -0,0 +1,99 @@ +cabal-version: 3.0 +name: podenv +version: 0.1.0 +synopsis: A container wrapper +description: + Podenv provides a declarative interface to manage containerized applications. + . + Using rootless containers, podenv let you run applications seamlessly. + . +homepage: https://github.com/podenv/podenv#readme +bug-reports: https://github.com/podenv/podenv/issues +license: Apache-2.0 +license-file: LICENSE +extra-doc-files: CHANGELOG.md + README.md +author: Tristan Cacqueray +maintainer: tdecacqu@redhat.com +copyright: 2021 Red Hat +category: Development +extra-source-files: test/*.dhall + hub/*.dhall + hub/**/*.dhall + .git/modules/hub/HEAD + +source-repository head + type: git + location: https://github.com/podenv/podenv.git + +flag ci + description: Make warnings error + default: False + manual: True + +common common + if flag(ci) + ghc-options: -Werror + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wno-missing-pattern-synonym-signatures + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wpartial-fields + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + default-language: Haskell2010 + +library + import: common + build-depends: base < 5 + , SHA + , containers + , dhall >= 1.39 + , directory + , unix + , either + , filepath + , gitrev + , lens-family-core + , lens-family-th + , linux-capabilities + , optparse-applicative + , relude >= 0.7 + , text + , th-env + , typed-process + , unix + hs-source-dirs: src + exposed-modules: Podenv.Application + , Podenv.Build + , Podenv.Config + , Podenv.Context + , Podenv.Dhall + , Podenv.Env + , Podenv.Main + , Podenv.Prelude + , Podenv.Runtime + , Podenv.Version + other-modules: Paths_podenv + autogen-modules: Paths_podenv + +executable podenv + import: common + hs-source-dirs: app + main-is: Main.hs + build-depends: base, podenv + ghc-options: -threaded -rtsopts -with-rtsopts=-N + +test-suite tests + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base, hspec, podenv, text diff --git a/src/Podenv/Application.hs b/src/Podenv/Application.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Application.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} + +-- | This module contains the capability logic. +-- The goal is to convert an Application into a Context +-- +-- This module performs read-only IO +module Podenv.Application + ( prepare, + preparePure, + capsAll, + Cap (..), + Mode (..), + ) +where + +import qualified Data.Map +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Podenv.Build +import Podenv.Dhall +import Podenv.Env +import Podenv.Prelude +import qualified Podenv.Runtime as Ctx +import qualified System.Posix.Files + +data Mode = Regular | Shell + +-- | Converts an Application into a Context +prepare :: Application -> Mode -> Ctx.Name -> IO Ctx.Context +prepare app mode ctxName = do + appEnv <- Podenv.Env.new + preparePure appEnv app mode 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 + home <- getContainerHome + runReaderT (doPrepare app mode ctxName home) (appEnv home) + where + appEnv home = envBase & appHomeDir .~ (toString <$> home) + + getContainerHome + | app ^. appCapabilities . capRoot = pure $ Just "/root" + | otherwise = case app ^. appRuntime of + Container cb -> pure $ cb ^. cbImage_home + Rootfs fp -> fmap toText <$> (envBase ^. rootfsHome) (toString fp) + Nix _ -> pure $ toText <$> envBase ^. hostHomeDir + Image _ -> pure Nothing + +doPrepare :: Application -> Mode -> Ctx.Name -> Maybe Text -> AppEnvT Ctx.Context +doPrepare app mode ctxName appHome = do + uid <- asks _hostUid + let baseCtx = + (Ctx.defaultContext ctxName runtimeCtx) + { Ctx._uid = uid, + Ctx._namespace = app ^. appNamespace + } + + ctx <- + foldM addVolume baseCtx (app ^. appVolumes) + >>= flip (foldM setCaps) capsAll + + setCommand <- case mode of + Regular -> + if app ^. appCapabilities . capHostfile + then resolveFileArgs $ app ^. appCommand + else pure $ Ctx.command .~ app ^. appCommand + Shell -> pure $ Ctx.command .~ ["/bin/sh"] + + pure (validate . setCommand . modifiers $ ctx) + where + runtimeCtx = case app ^. appRuntime of + Image x -> Ctx.Container $ Ctx.ImageName x + Rootfs root -> Ctx.Bubblewrap $ toString root + Container cb -> Podenv.Build.containerBuildRuntime cb + Nix _ -> Podenv.Build.nixRuntime + + validate ctx = case runtimeCtx of + Ctx.Bubblewrap _ | null (ctx ^. Ctx.command) -> ctx & Ctx.command .~ ["/bin/sh"] + _ -> ctx + + modifiers :: Ctx.Context -> Ctx.Context + 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"))) + Nothing -> id + + -- Check if path is part of a mount point + isMounted :: FilePath -> Ctx.Context -> Bool + isMounted fp ctx = any isPrefix mountPaths + where + mountPaths = Data.Map.keys $ ctx ^. Ctx.mounts + isPrefix x = fp `isPrefixOf` x + + ensureWorkdir ctx = case appHome of + (Just x) | isMounted (toString x) ctx -> ctx & Ctx.workdir `setWhenNothing` toString x + _ -> ctx + + setEnv = case appHome of + Just x -> Ctx.addEnv "HOME" x + _ -> id + + -- Some capabilities do not work with selinux + noSelinuxCaps = [capWayland, capX11] + hasPrivCap = any (\l -> app ^. appCapabilities . l) noSelinuxCaps + -- When using host device, selinux also needs to be disabled + hasDevice ctx = ctx ^. Ctx.devices /= mempty + -- When using direct host path, its simpler to disable selinux too. That can be improved though + isHostPath = \case + Ctx.MkVolume _ (Ctx.HostPath _) -> True + _anyOtherVolume -> False + hasHostPath ctx = any isHostPath (toList $ ctx ^. Ctx.mounts) + disableSelinux ctx + | hasPrivCap || hasDevice ctx || hasHostPath ctx = ctx & Ctx.selinux .~ False + | otherwise = ctx + + setRunAs = case appHome of + -- To keep it simple, when the app home is in `/home`, assume we share the host uid. + Just h | "/home" `Text.isPrefixOf` h -> Ctx.runAs `setWhenNothing` Ctx.RunAsHostUID + _ -> id + + addSysCaps ctx = foldr addSysCap ctx (app ^. appSyscaps) + 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 :) + + addEnvs ctx = foldr addEnv ctx (app ^. appEnviron) + addEnv :: Text -> Ctx.Context -> Ctx.Context + addEnv env = + let (k, v) = Text.breakOn "=" env + in Ctx.addEnv k (Text.drop 1 v) + + setCaps = capContextApply $ app ^. appCapabilities + capContextApply :: Capabilities -> Ctx.Context -> Cap -> AppEnvT Ctx.Context + capContextApply appCaps ctx Cap {..} = + if appCaps ^. capLens + then capSet ctx + else pure ctx + +-- | CapInfo describes a capability and how it modify the runtime context +data Cap = Cap + { capName :: Text, + capDescription :: Text, + -- | How to get the capability value from the user provided record: + capLens :: Lens' Capabilities Bool, + -- | How the capability change the context: + capSet :: Ctx.Context -> AppEnvT Ctx.Context + } + +-- | The main list of capabilities +capsAll, capsToggle :: [Cap] +capsAll = capsToggle +capsToggle = + [ Cap "root" "run as root" capRoot (contextSet Ctx.runAs (Just Ctx.RunAsRoot)), + Cap "terminal" "allocate a tty" capTerminal setTerminal, + Cap "interactive" "interactive mode" capInteractive (contextSet Ctx.interactive True), + Cap "dbus" "share session dbus socket" capDbus setDbus, + Cap "wayland" "share wayland socket" capWayland setWayland, + Cap "pipewire" "share pipewire socket" capPipewire setPipewire, + Cap "video" "share video devices" capVideo setVideo, + Cap "dri" "share graphic device" capDri setDri, + Cap "kvm" "share kvm device" capKvm (pure . Ctx.addDevice "/dev/kvm"), + Cap "tun" "share tun device" capTun (pure . Ctx.addDevice "/dev/net/tun"), + Cap "alsa" "share alsa devices" capAlsa (pure . Ctx.addDevice "/dev/snd"), + Cap "pulseaudio" "share pulseaudio socket" capPulseaudio setPulseaudio, + Cap "ssh" "share ssh agent and keys" capSsh setSsh, + Cap "gpg" "share gpg agent and keys" capGpg setGpg, + Cap "x11" "share x11 socket" capX11 setX11, + Cap "cwd" "mount cwd" capCwd setCwd, + Cap "network" "enable network" capNetwork setNetwork, + Cap "hostfile" "mount command file arg" capHostfile pure, + Cap "rw" "mount rootfs rw" capRw (contextSet Ctx.ro False), + Cap "privileged" "run with extra privileges" capPrivileged (contextSet Ctx.privileged True) + ] + +setNetwork :: Ctx.Context -> AppEnvT Ctx.Context +setNetwork ctx = do + setResolvConf <- liftIO $ ensureResolvConf ctx + pure $ ctx & (Ctx.network .~ True) . setResolvConf + +ensureResolvConf :: Ctx.Context -> IO (Ctx.Context -> Ctx.Context) +ensureResolvConf ctx = case ctx ^. Ctx.runtimeCtx of + -- When using host rootfs, then we need to mount /etc/resolv.conf target when it is a symlink + Ctx.Bubblewrap "/" -> do + symlink <- System.Posix.Files.isSymbolicLink <$> System.Posix.Files.getSymbolicLinkStatus "/etc/resolv.conf" + if symlink + then do + realResolvConf <- getSymlinkPath + pure $ Ctx.addMount realResolvConf $ Ctx.roHostPath realResolvConf + else pure id + -- Otherwise we can just mount it directly + Ctx.Bubblewrap _ -> pure $ Ctx.addMount "/etc/resolv.conf" (Ctx.roHostPath "/etc/resolv.conf") + _ -> pure id + where + getSymlinkPath = do + realResolvConf <- System.Posix.Files.readSymbolicLink "/etc/resolv.conf" + pure $ + if "../" `isPrefixOf` realResolvConf + then drop 2 realResolvConf + else realResolvConf + +setTerminal :: Ctx.Context -> AppEnvT Ctx.Context +setTerminal ctx = + pure $ ctx & (Ctx.interactive .~ True) . (Ctx.terminal .~ True) . (Ctx.addEnv "TERM" "xterm-256color") + +setWayland :: Ctx.Context -> AppEnvT Ctx.Context +setWayland ctx = do + sktM <- liftIO $ lookupEnv "WAYLAND_DISPLAY" + case sktM of + Nothing -> setX11 ctx + Just skt -> setWayland' skt ctx + +setWayland' :: FilePath -> Ctx.Context -> AppEnvT Ctx.Context +setWayland' skt ctx = do + shareSkt <- addXdgRun skt + pure $ + ctx + & Ctx.directMount "/etc/machine-id" + . shareSkt + . Ctx.addEnv "GDK_BACKEND" "wayland" + . Ctx.addEnv "QT_QPA_PLATFORM" "wayland" + . Ctx.addEnv "WAYLAND_DISPLAY" (toText skt) + . Ctx.addEnv "XDG_SESSION_TYPE" "wayland" + . Ctx.addMount "/dev/shm" Ctx.tmpfs + +setPipewire :: Ctx.Context -> AppEnvT Ctx.Context +setPipewire ctx = do + let skt = "pipewire-0" -- TODO discover skt name + shareSkt <- addXdgRun skt + pure $ + ctx + & Ctx.directMount "/etc/machine-id" + . shareSkt + +setDbus :: Ctx.Context -> AppEnvT Ctx.Context +setDbus ctx = do + let skt = "bus" -- TODO discover skt name + (sktPath, shareSkt) <- addXdgRun' skt + pure $ + ctx + & Ctx.directMount "/etc/machine-id" + . Ctx.addEnv "DBUS_SESSION_BUS_ADDRESS" ("unix:path=" <> toText sktPath) + . shareSkt + +setVideo :: Ctx.Context -> AppEnvT Ctx.Context +setVideo ctx = do + devices <- liftIO $ listDirectory "/dev" + let addDevices = + map (Ctx.addDevice . toString . mappend "/dev/") $ + filter ("video" `Text.isPrefixOf`) $ map toText devices + pure $ foldr (\c a -> c a) ctx addDevices + +setDri :: Ctx.Context -> AppEnvT Ctx.Context +setDri ctx = do + nvidia <- liftIO $ doesPathExist "/dev/nvidiactl" + pure $ + ctx + & if nvidia + then Ctx.addDevice "/dev/nvidiactl" . Ctx.addDevice "/dev/nvidia0" + else Ctx.addDevice "/dev/dri" + +setPulseaudio :: Ctx.Context -> AppEnvT Ctx.Context +setPulseaudio ctx = do + shareSkt <- addXdgRun "pulse" + uid <- asks _hostUid + let pulseServer = "/run/user/" <> show uid <> "/pulse/native" + pure $ + ctx + & Ctx.directMount "/etc/machine-id" + . shareSkt + . Ctx.addEnv "PULSE_SERVER" pulseServer + +getHomes :: Text -> AppEnvT (FilePath, FilePath) +getHomes help = do + hostDir <- fromMaybe (error $ "Need HOME for " <> help) <$> asks _hostHomeDir + appDir <- fromMaybe (error $ "Application need home for " <> help) <$> asks _appHomeDir + pure (hostDir, appDir) + +mountHomeConfig :: Text -> FilePath -> AppEnvT (Ctx.Context -> Ctx.Context) +mountHomeConfig help fp = do + (hostDir, appDir) <- getHomes help + pure $ Ctx.addMount (appDir fp) (Ctx.roHostPath $ hostDir fp) + +setAgent :: String -> IO (Ctx.Context -> Ctx.Context) +setAgent var = do + value <- lookupEnv var + pure $ case value of + 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 + +setGpg :: Ctx.Context -> AppEnvT Ctx.Context +setGpg ctx = do + shareConfig <- mountHomeConfig "gpg" ".gnupg" + shareGpg <- addXdgRun "gnupg" + pure $ ctx & shareGpg . shareConfig + +setX11 :: Ctx.Context -> AppEnvT Ctx.Context +setX11 ctx = do + display <- liftIO $ getEnv "DISPLAY" + pure $ + ctx + & Ctx.directMount "/tmp/.X11-unix" . Ctx.addEnv "DISPLAY" (toText display) . Ctx.addMount "/dev/shm" Ctx.tmpfs + +setCwd :: Ctx.Context -> AppEnvT Ctx.Context +setCwd ctx = do + cwd <- asks _hostCwd + pure $ ctx & Ctx.addMount "/data" (Ctx.rwHostPath cwd) . (Ctx.workdir ?~ "/data") + +addVolume :: Ctx.Context -> Text -> AppEnvT Ctx.Context +addVolume ctx volume = do + containerPath' <- resolveContainerPath containerPath + hostPath' <- resolveVolume hostPath + pure $ Ctx.addMount containerPath' hostPath' ctx + where + (hostPath, containerPath) = case Text.breakOn ":" volume of + (x, "") -> (x, x) + (x, y) -> (x, Text.drop 1 y) + +resolveFileArgs :: [Text] -> AppEnvT (Ctx.Context -> Ctx.Context) +resolveFileArgs args = do + fps <- traverse checkExist args + pure $ foldr ((.) . addFileArg) id fps + where + addCommand :: Text -> Ctx.Context -> Ctx.Context + addCommand arg = Ctx.command %~ (arg :) + checkExist :: Text -> AppEnvT (Either Text FilePath) + checkExist arg = do + fpM <- resolveHostPath arg + case fpM of + Nothing -> pure $ Left arg + Just fp -> do + exist <- liftIO $ doesPathExist fp + unless exist (liftIO $ putTextLn $ "Warning, arg path does not exist: " <> arg) + pure $ bool (Left arg) (Right fp) exist + addFileArg :: Either Text FilePath -> Ctx.Context -> Ctx.Context + addFileArg (Left arg) = addCommand arg + addFileArg (Right fp) + | hasTrailingPathSeparator fp = error "Directory filearg ar not supported" + | otherwise = + let cfp = "/data" takeFileName fp + in addCommand (toText cfp) . Ctx.addMount cfp (Ctx.rwHostPath fp) + +-- | Helper functions to manipulate paths +getXdgRuntimeDir :: AppEnvT FilePath +getXdgRuntimeDir = fromMaybe (error "Need XDG_RUNTIME_DIR") <$> asks _hostXdgRunDir + +fixPath :: Text -> FilePath +fixPath = toString . Text.drop 1 . Text.dropWhile (/= '/') + +resolveContainerPath :: Text -> AppEnvT FilePath +resolveContainerPath path + | path == "~" || "~/" `Text.isPrefixOf` path = do + appHome' <- fromMaybe (error "Need app home") <$> asks _appHomeDir + pure $ appHome' fixPath path + | "/" `Text.isPrefixOf` path = pure $ toString path + | otherwise = error $ "Invalid container path: " <> path + +resolveHostPath :: Text -> AppEnvT (Maybe FilePath) +resolveHostPath path + | "~/" `Text.isPrefixOf` path = do + envHome' <- fromMaybe (error "Need HOME") <$> asks _hostHomeDir + pure $ Just (envHome' fixPath path) + | "./" `Text.isPrefixOf` path = do + curDir' <- asks _hostCwd + pure $ Just (curDir' fixPath path) + | "/" `Text.isPrefixOf` path = pure $ Just (toString path) + | otherwise = pure Nothing + +resolveHostPath' :: Text -> AppEnvT FilePath +resolveHostPath' path = do + pathM <- resolveHostPath path + case pathM of + Just x -> pure x + Nothing -> error $ "Invalid host path: " <> path + +resolveVolume :: Text -> AppEnvT Ctx.Volume +resolveVolume name = case Text.uncons name of + Nothing -> error "Empty host path" + Just (x, _xs) + -- TODO: handle suffix such as :Z + | x `elem` ['~', '.', '/'] -> Ctx.rwHostPath <$> resolveHostPath' name + | otherwise -> pure $ Ctx.MkVolume Ctx.RW (Ctx.Volume name) + +-- | Helper function to share a XDG_RUNTIME_DIR path +addXdgRun :: FilePath -> AppEnvT (Ctx.Context -> Ctx.Context) +addXdgRun fp = snd <$> addXdgRun' fp + +-- | Returns the container path and the context setter for xdg +addXdgRun' :: FilePath -> AppEnvT (FilePath, Ctx.Context -> Ctx.Context) +addXdgRun' fp = do + hostXdg <- getXdgRuntimeDir + uid <- asks _hostUid + let containerPath = runDir fp + hostPath = hostXdg fp + runBaseDir = "/run/user" + runDir = runBaseDir <> "/" <> show uid + pure + ( containerPath, + Ctx.addEnv "XDG_RUNTIME_DIR" (toText runDir) + -- Podman creates parent directory as root, ensure user can r/w xdgdir using tmpfs + . Ctx.addMount runBaseDir Ctx.tmpfs + . Ctx.addMount containerPath (Ctx.rwHostPath hostPath) + ) + +-- | Helper for capabilities that are directly represented in the context +contextSet :: Lens' Ctx.Context a -> a -> Ctx.Context -> AppEnvT Ctx.Context +contextSet lens value ctx = pure ((lens .~ value) ctx) diff --git a/src/Podenv/Build.hs b/src/Podenv/Build.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Build.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This modules contains logic to perform application runtime build +module Podenv.Build + ( prepare, + BuildEnv (..), + containerBuildRuntime, + nixRuntime, + ) +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 Podenv.Dhall +import Podenv.Prelude +import Podenv.Runtime (ImageName (..)) +import qualified Podenv.Runtime +import System.Directory (doesDirectoryExist, renameFile) +import System.Exit (ExitCode (ExitSuccess)) +import qualified System.Process.Typed as P + +-- | Helper function to run a standalone app, usefull for local build +type AppRunner = Application -> IO () + +-- | A build env contains action to be performed before preparation and execution +data BuildEnv = BuildEnv + { beInfos :: Text, + -- | Builds the runtime + beEnsure :: AppRunner -> IO (), + -- | Updates the runtime + beUpdate :: AppRunner -> IO () + } + +defaultBuildEnv :: Text -> BuildEnv +defaultBuildEnv beInfos = BuildEnv {..} + where + beEnsure = const $ pure () + beUpdate = const $ pure () + +-- | 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) + Nix expr -> prepareNix re app expr + +containerBuildRuntime :: ContainerBuild -> Podenv.Runtime.RuntimeContext +containerBuildRuntime = Podenv.Runtime.Container . mkImageName + +mkImageName :: ContainerBuild -> ImageName +mkImageName containerBuild = ImageName $ "localhost/" <> name + where + -- The image name can be set by the container build, + -- otherwise it default to the Containerfile hash + name = fromMaybe imageHash (containerBuild ^. cbImage_name) + imageHash = toText . SHA.showDigest . SHA.sha256 . encodeUtf8 $ containerBuild ^. cbContainerfile + +-- | Container build env +prepareContainer :: ContainerBuild -> BuildEnv +prepareContainer containerBuild = BuildEnv {..} + where + -- buildenv basic info: + beInfos = "# Containerfile " <> imageName <> "\n" <> fileContent + fileContent = containerBuild ^. cbContainerfile + + ImageName imageName = mkImageName containerBuild + fileName = "Containerfile_" <> toString (imageNameToFP imageName) + where + imageNameToFP = Text.replace "/" "_" . Text.replace ":" "-" + + beEnsure = const $ do + imageReady <- checkImageExist imageName + unless imageReady $ + buildImage imageName fileName fileContent (containerBuild ^. cbImage_volumes) + + beUpdate = const $ case containerBuild ^. cbImage_update of + Nothing -> error "The container is missing the `image_update` attribute" + Just cmd -> do + buildImage + imageName + (fileName <> "-update") + (unlines ["FROM " <> imageName, "RUN " <> cmd]) + (containerBuild ^. cbImage_volumes) + +-- | Nix runtime re-use the host root filesystem, prepareNix added the nix-store volume. +nixRuntime :: Podenv.Runtime.RuntimeContext +nixRuntime = Podenv.Runtime.Bubblewrap "/" + +getCertLocation :: IO (Maybe FilePath) +getCertLocation = runMaybeT $ Control.Monad.msum $ checkPath <$> paths + where + checkPath :: FilePath -> MaybeT IO FilePath + checkPath fp = do + exist <- lift $ doesPathExist fp + unless exist mzero + pure fp + -- Copied from profile.d/nix.sh + paths = + [ "/etc/pki/tls/certs/ca-bundle.crt", + "/etc/ssl/certs/ca-certificates.crt", + "/etc/ssl/ca-bundle.pem", + "/etc/ssl/certs/ca-bundle.crt" + ] + +-- | Nix build env +prepareNix :: Podenv.Runtime.RuntimeEnv -> Application -> Flakes -> IO (BuildEnv, Application) +prepareNix re app flakes = do + certs <- toText . fromMaybe (error "Can't find ca-bundle") <$> getCertLocation + -- TODO: check howto re-use the host /nix + pure + ( BuildEnv + { beInfos = "# Nix expr:\n" <> Text.unwords nixArgs, + beEnsure = beEnsure certs, + beUpdate = const $ error "Nix update is not implemented" + }, + updateApp certs app + ) + where + name = app ^. appName + fileName = toString $ "nix_" <> name + + -- The location where we expect to find the `nix` command + nixStore = Podenv.Runtime.volumesDir re "nix-store" + nixCommandProfile = "var/nix/profiles/nix-install" + nixCommandPath = "/nix/" <> nixCommandProfile <> "/bin/nix" + nixFlags = ["--extra-experimental-features", "nix-command flakes"] + + -- The nix command args + nixExtraArgs = case nixpkgs flakes of + Just pin | not (all (Text.isPrefixOf pin) (installables flakes)) -> ["--override-input", "nixpkgs", pin] + _ -> [] + nixArgs = nixExtraArgs <> installables flakes + + beEnsure certs runApp = do + built <- checkIfBuilt fileName (show nixArgs) + unless built $ do + ensureNixInstalled + _ <- runApp (buildApp certs) + + -- save that the build succeeded + cacheDir <- getCacheDir + Text.writeFile (cacheDir fileName) (show nixArgs) + + debug = when (Podenv.Runtime.verbose re) . hPutStrLn stderr . mappend "[+] " + + ensureNixInstalled = do + debug $ "Checking if " <> nixStore nixCommandProfile <> " exists" + nixInstalled <- doesSymlinkExist $ nixStore nixCommandProfile + unless nixInstalled $ do + debug $ "Checking if " <> nixStore "store" <> " exists" + storeExist <- doesDirectoryExist $ nixStore "store" + when storeExist $ error $ "existing nix-store is invalid, try removing " <> toText nixStore + + podenv <- getExecutablePath + debug $ "[+] Installing nix-store with " <> podenv <> " nix.setup" + P.runProcess_ $ P.setDelegateCtlc True $ P.proc podenv ["nix.setup"] + + -- The Application to build the expression, it is executed in advance to separate build and execution + buildApp certs = + Podenv.Config.defaultApp + { runtime = Rootfs "/", + name = "build-" <> name, + volumes = [toText nixStore <> ":/nix", "nix-setup-home:~/", "nix-cache:~/.cache/nix"], + environ = ["NIX_SSL_CERT_FILE=" <> certs, "LC_ALL=C.UTF-8", "TERM=xterm"], + command = + [toText nixCommandPath, "--verbose"] + <> nixFlags + <> ["build", "--no-link"] + <> nixArgs + } + & (appCapabilities . capNetwork .~ True) + + runCommand = + [toText nixCommandPath] <> nixFlags <> case app ^. appCommand of + [] -> ["run"] <> nixArgs + appArgs -> ["shell"] <> nixArgs <> ["--command"] <> appArgs + addCommand = appCommand .~ runCommand + addVolumes = appVolumes %~ mappend ["nix-store:/nix", "nix-cache:~/.cache/nix"] + addEnvirons certs = + appEnviron + %~ mappend + [ "NIX_SSL_CERT_FILE=" <> certs, + "TERM=xterm", + "LC_ALL=C.UTF-8", + "PATH=/nix/var/nix/profiles/nix-install/bin:/bin" + ] + updateApp certs = addCommand . addVolumes . addEnvirons certs + +-- | Build a container image +buildImage :: Text -> FilePath -> Text -> [Text] -> IO () +buildImage imageName fileName containerfile volumes = do + uid <- getRealUserID + cacheDir <- getCacheDir + createDirectoryIfMissing True cacheDir + let want = fileName <> ".want" + wantfp = cacheDir want + Text.writeFile wantfp containerfile + -- podman build does not support regular volume, lets ensure absolute path + volumesArgs <- traverse (mkVolumeArg cacheDir) volumes + let buildArgs = + ["build"] + <> ["-t", toString imageName] + <> ["--build-arg", "USER_UID=" <> show uid] + <> map toString volumesArgs + <> ["-f", want, cacheDir] + cmd = Podenv.Runtime.podman buildArgs + -- putTextLn $ "Building " <> imageName <> " with " <> toText want <> ": " <> show cmd + P.runProcess_ cmd + + -- save that the build succeeded + renameFile wantfp (cacheDir fileName) + where + mkVolumeArg :: FilePath -> Text -> IO Text + mkVolumeArg cacheDir volume = do + createDirectoryIfMissing True hostPath + pure $ "-v=" <> toText hostPath <> ":" <> containerPath <> ":Z" + where + (p1, p2) = Text.break (== ':') volume + hostPath = cacheDir toString p1 + containerPath = Text.drop 1 p2 + +checkImageExist :: Text -> IO Bool +checkImageExist imageName = do + res <- P.runProcess (Podenv.Runtime.podman ["image", "exists", Text.unpack imageName]) + pure $ res == ExitSuccess + +checkIfBuilt :: FilePath -> Text -> IO Bool +checkIfBuilt filename expected = do + cacheDir <- getCacheDir + current <- readFileM (cacheDir filename) + pure $ current == expected diff --git a/src/Podenv/Config.hs b/src/Podenv/Config.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Config.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This module contains the logic to load the dhall configuration +module Podenv.Config + ( load, + select, + Config (..), + Atom (..), + ApplicationRecord (..), + defaultConfigPath, + defaultApp, + loadSystem, + defaultSystemConfig, + podenvImportTxt, + ) +where + +import Control.Exception (bracket_) +import qualified Data.Digest.Pure.SHA 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 Dhall.Marshal.Decode (DhallErrors (..), extractError) +import qualified Dhall.Parser +import qualified Dhall.Src +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 + +data Config + = -- | A standalone application, e.g. defaultSelector + ConfigDefault ApplicationRecord + | -- | A single application + ConfigApplication Atom + | -- | A collection of applications + ConfigApplications [(Text, Atom)] + +data Atom + = -- | A literal application + Lit ApplicationRecord + | -- | A paremeterized application + LamArg ArgName (Text -> ApplicationRecord) + | LamArg2 ArgName ArgName (Text -> Text -> ApplicationRecord) + | -- | A functional application + LamApp (Application -> ApplicationRecord) + +-- | A wrapper around the true Application type to manage weakly typed configuration +-- (e.g. so that `{ runtime.image = "ubi8" }` can be manually decoded) +newtype ApplicationRecord = ApplicationRecord {unRecord :: Application} + +instance Dhall.FromDhall ApplicationRecord where + autoWith = const appRecordDecoder + +newtype ArgName = ArgName Text + +instance Text.Show.Show ArgName where + show (ArgName n) = toString n + +-- | Config load entrypoint +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 + +defaultSelector :: Text -> Maybe Application +defaultSelector s + | "image:" `Text.isPrefixOf` s = imageApp s + | "nix:" `Text.isPrefixOf` s = nixApp s + | "nixpkgs#" `Text.isPrefixOf` s = nixApp' s + | "rootfs:" `Text.isPrefixOf` s = rootfsApp s + | otherwise = Nothing + where + imageApp x = mkApp ("image-" <> mkName x) (Image $ Text.drop (Text.length "image:") x) + nixApp' x = mkApp ("nix-" <> mkName x) (Nix $ Flakes [x] Nothing) + nixApp x = nixApp' $ Text.drop (Text.length "nix:") x + rootfsApp x = mkApp ("rootfs-" <> mkName x) (Rootfs $ Text.drop (Text.length "rootfs:") x) + mkApp name runtime' = Just $ defaultApp & (appName .~ name) . (appRuntime .~ runtime') + mkName = Text.take 6 . toText . SHA.showDigest . SHA.sha1 . encodeUtf8 + +-- | Inject the package.dhall into the environ so that config can use `env:PODENV` +loadWithEnv :: FilePath -> Dhall.Expr Dhall.Src.Src Dhall.Import -> IO DhallExpr +loadWithEnv baseDir expr = withEnv $ flip evalStateT initialState $ Dhall.Import.loadWith expr + where + -- Set the PODENV environment variable to the frozen url of the current hub + withEnv = bracket_ (setEnv "PODENV" (toString podenvImportTxt)) (unsetEnv "PODENV") + -- Then use a custom Dhall.Import.Status state that inject the static code + -- The goal is to only pretty print (text encode) the package when the cache is cold + initialState = baseStatus & Dhall.Import.remote .~ fetchUrl + baseStatus = Dhall.Import.emptyStatus baseDir + fetchUrl url + | url == podenvUrl = pure (Dhall.pretty podenvPackage) + | otherwise = (baseStatus ^. Dhall.Import.remote) url + +-- | Helper function to parse the initial configuration +loadExpr :: Maybe Text -> IO DhallExpr +loadExpr configM = case configM of + Just configTxt -> do + cwd' <- getCurrentDirectory + loadWithEnv cwd' $ exprFromText' configTxt + Nothing -> do + baseDir <- getConfigDir + let configPath = baseDir "config.dhall" + + -- load main config + configContent <- + bool (pure "(env:PODENV).Hub") (Text.readFile configPath) =<< doesFileExist configPath + let configExpr = exprFromText' configContent + + -- lookup local.d configs + let locald = baseDir "local.d" + localFiles <- bool (pure []) (listDirectory locald) =<< doesPathExist locald + let localConfig = createLocalRecord locald localFiles + + -- adds local.d to the main config using the `//` operator + let expr' = Dhall.Prefer Nothing Dhall.PreferFromSource configExpr localConfig + loadWithEnv baseDir expr' + where + exprFromText' :: Text -> Dhall.Expr Dhall.Src.Src Dhall.Import + exprFromText' configTxt = case Dhall.Parser.exprFromText "" configTxt of + Right expr -> expr + Left e -> error $ "Invalid config: " <> show e + +-- | Create a record for local.d config +createLocalRecord :: FilePath -> [FilePath] -> Dhall.Expr Dhall.Src.Src Dhall.Import +createLocalRecord baseDir = + Dhall.RecordLit . fromList . map toRecord . filter (isExtensionOf ".dhall") + where + toRecord :: FilePath -> (Text, Dhall.RecordField Dhall.Src.Src Dhall.Import) + toRecord name = (toText $ dropExtension name, Dhall.makeRecordField (Dhall.Embed $ toImport name)) + toImport :: FilePath -> Dhall.Import + toImport name = + let file = Dhall.File (Dhall.Directory $ reverse $ map toText $ splitPath baseDir) (toText name) + in Dhall.Import (Dhall.ImportHashed Nothing (Dhall.Local Dhall.Absolute file)) Dhall.Code + +-- | The static hub package expression +podenvUrl :: Dhall.URL +podenvUrl = + Dhall.URL Dhall.HTTPS "raw.githubusercontent.com" path Nothing Nothing + where + hubVersion = case Dhall.extract Dhall.auto (Dhall.renote hubCommit) of + Success x -> Text.dropEnd 1 x + Failure v -> error $ "Unknown hub commit: " <> show v + path = Dhall.File (Dhall.Directory [hubVersion, "hub", "podenv"]) "package.dhall" + +podenvImport :: Dhall.Import +podenvImport = + Dhall.Import (Dhall.ImportHashed (Just hash) (Dhall.Remote podenvUrl)) Dhall.Code + where + hash = Dhall.Import.hashExpression (Dhall.alphaNormalize podenvPackage) + +podenvImportTxt :: Text +podenvImportTxt = Text.replace "\n " "" $ Dhall.pretty podenvImport + +-- | Pure config load +load' :: DhallExpr -> Config +load' expr = case loadConfig "" expr of + Success [(selector, Lit app)] -> ConfigApplication $ Lit (ensureName selector app) + Success [(_, x)] -> ConfigApplication x + Success [] -> error "No application found" + Success xs -> ConfigApplications xs + Failure (DhallErrors (x :| _)) -> error $ show x + +-- | When an application doesn't have a name, set it to the selector path +ensureName :: Text -> ApplicationRecord -> ApplicationRecord +ensureName x app = case unRecord app ^. appName of + "" -> ApplicationRecord $ unRecord app & appName .~ x + _ -> app + +-- | The main config load function. It recursively descend the +-- tree by extending the selector name. +loadConfig :: Text -> DhallExpr -> DhallParser [(Text, Atom)] +loadConfig baseSelector expr = case expr of + -- When the node is a function, assume it is an app. + Dhall.Lam {} -> (\app -> [(baseSelector, app)]) <$> loadApp expr + Dhall.RecordLit kv + | -- When the node has a "runtime" attribute, assume it is an app. + DM.member "runtime" kv -> + (\app -> [(baseSelector, app)]) <$> loadApp expr + | -- Otherwise, traverse each attributes + otherwise -> + 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: + -- FromDhall: You cannot decode a function if it does not have the correct type + | "use" `Text.isPrefixOf` n = pure [] + | otherwise = loadConfig (mkSelector n) (Dhall.recordFieldValue e) + mkSelector name + | baseSelector == mempty = name + | name == "default" = baseSelector + | otherwise = baseSelector <> "." <> name + _ -> extractError $ baseSelector <> ": expected a record literal, but got: " <> Text.take 256 (show expr) + +-- | Select the application, returning the unused cli args. +select :: Config -> [Text] -> Either Text ([Text], Application) +select config args = fmap unRecord <$> select' config args + +select' :: Config -> [Text] -> Either Text ([Text], ApplicationRecord) +select' config args = case config of + -- config default is always selected, drop the first args + ConfigDefault app -> pure (tail (fromList args), app) + -- config has only one application, don't touch the args + ConfigApplication atom -> selectApp [] args atom + -- config has some applications, the first arg is a selector + ConfigApplications atoms -> case args of + (selector : xs) -> do + atom <- lookup selector atoms `orDie` (selector <> ": not found") + (args', app) <- selectApp atoms xs atom + let name' = Text.intercalate "-" $ take (length args - length args') args + pure (args', ensureName name' app) + [] -> Left "Multiple apps configured, provides a selector" + where + selectApp atoms args' atom = case atom of + -- App is not a function, don't touch the arg + Lit app -> pure (args', app) + -- App needs an argument, the tail is the arg + LamArg arg f -> case args' of + (x : xs) -> pure (xs, f x) + [] -> Left ("Missing argument: " <> show arg) + LamArg2 arg1 arg2 f -> case args' of + (x : y : xs) -> pure (xs, f x y) + (_ : _) -> Left ("Missing argument: " <> show arg2) + _ -> Left ("Missing arguments: " <> show arg1 <> " " <> show arg2) + LamApp f -> case args' of + (x : xs) -> case defaultSelector x of + Just app -> pure (xs, f app) + Nothing -> do + -- Recursively select the app to eval arg `mod app arg` as `mod (app arg)` + -- e.g. LamApp should be applied at the end. + atom' <- lookup x atoms `orDie` (x <> ": unknown lam arg") + (rest, app) <- selectApp atoms xs atom' + pure (rest, f (unRecord app)) + [] -> Left "Missing app argument" + +defaultConfigPath :: Text +defaultConfigPath = "~/.config/podenv/config.dhall" + +-- | The default app +defaultApp :: Application +defaultApp = case Dhall.extract Dhall.auto (Dhall.renote appDefault) of + Success app -> app + Failure v -> error $ "Invalid default application: " <> show v + +-- | A type synonym to simplify function annotation. +type DhallParser a = Dhall.Extractor Dhall.Src.Src Void a + +-- | A type synonym to simplify function annotation. +type DhallExpr = Dhall.Expr Dhall.Src.Src Void + +type DhallExtractor a = Dhall.Extractor Dhall.Src.Src Void a + +-- | The `//` dhall record update operation +pref :: Dhall.Expr s a -> Dhall.Expr s a -> Dhall.Expr s a +pref = Dhall.Prefer Nothing Dhall.PreferFromSource + +mkRecord :: [(Text, Dhall.Expr s a)] -> Dhall.Expr s a +mkRecord kv = Dhall.RecordLit (Dhall.makeRecordField <$> DM.fromList kv) + +recordItems :: DM.Map Text (Dhall.RecordField s a) -> [(Text, Dhall.Expr Void a)] +recordItems kv = fmap (Dhall.denote . Dhall.recordFieldValue) <$> DM.toList kv + +-- | A custom Dhall Decoder that can convert a weakly type Application +-- This is done by modifying the 'base' Dhall.Expr with: +-- App.default // (base // { capabilities = Caps.default // base.capabilities }) +-- so that the missing fields are automatically added. +-- +-- For the runtime value, this convert may convert a tag record to an Union variant +appRecordDecoder :: Dhall.Decoder ApplicationRecord +appRecordDecoder = ApplicationRecord <$> Dhall.Decoder extract expected + where + extract :: Dhall.Expr Dhall.Src.Src Void -> DhallExtractor Application + extract (Dhall.RecordLit kv) = case DM.lookup "runtime" kv of + Just (Dhall.RecordField _ (Dhall.RecordLit kv') _ _) -> extract' kv (runtimeFromRecord kv') + Just (Dhall.RecordField _ v _ _) -> extract' kv (Dhall.denote v) + Nothing -> Dhall.extractError "Application does not have a runtime" + extract _ = Dhall.extractError "Application is not a record" + + runtimeFromRecord :: DM.Map Text (Dhall.RecordField s Void) -> Dhall.Expr Void Void + runtimeFromRecord kv = case recordItems kv of + [("image", x)] -> mkRuntime "Image" x + [("nix", x)] -> mkRuntime "Nix" (mkNixRecord x) + [("containerfile", x)] -> mkRuntime "Container" (pref containerBuildDefault (mkRecord [("containerfile", x)])) + _ -> mkRuntime "Container" (pref containerBuildDefault (Dhall.denote (Dhall.RecordLit kv))) + where + mkNixRecord v = + mkRecord + [ ("installables", Dhall.ListLit Nothing $ fromList [v]), + ("nixpkgs", Dhall.App Dhall.None Dhall.Text) + ] + mkRuntime field v = + Dhall.App (Dhall.Field runtimeType (Dhall.FieldSelection Nothing field Nothing)) v + + extract' :: DM.Map Text (Dhall.RecordField s Void) -> Dhall.Expr Void Void -> DhallExtractor Application + extract' kv runtimeExpr = + let capsExpr = case DM.lookup "capabilities" kv of + Just (Dhall.RecordField _ v _ _) -> pref capsDefault (Dhall.denote v) + _ -> capsDefault + + -- capabilities and runtime are always added since they are nested schemas + nestedSchemas = [("capabilities", capsExpr), ("runtime", runtimeExpr)] + + baseExpr = pref (Dhall.denote $ Dhall.RecordLit kv) (mkRecord nestedSchemas) + expr = pref appDefault baseExpr + + -- The generic Application decoder + Dhall.Decoder appDecoder _ = Dhall.genericAuto + in appDecoder (Dhall.renote (Dhall.normalize expr)) + + expected = Success (Dhall.renote appType) + +-- | Parse and tag a DhallExpr with an Atom constructor +loadApp :: DhallExpr -> DhallParser Atom +loadApp expr = case expr of + 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 + | otherwise -> LamArg (getArgName fb) <$> Dhall.extract Dhall.auto expr + _ -> Lit <$> Dhall.extract Dhall.auto expr + where + getArgName = ArgName . Dhall.functionBindingVariable + +loadSystem :: IO SystemConfig +loadSystem = do + confDir <- getXdgDirectory XdgConfig "podenv" + let fp = confDir "system.dhall" + exist <- doesFileExist fp + if exist + then Dhall.input Dhall.auto (toText fp) + else pure defaultSystemConfig + +-- | The default system config +defaultSystemConfig :: SystemConfig +defaultSystemConfig = case Dhall.extract Dhall.auto (Dhall.renote systemConfigDefault) of + Success x -> x + Failure v -> error $ "Invalid default system config: " <> show v diff --git a/src/Podenv/Context.hs b/src/Podenv/Context.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Context.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +-- makeLenses does not produce those +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} + +-- | Runtime Context data types and lenses +module Podenv.Context where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Lens.Family.TH (makeLenses) +import Podenv.Prelude +import System.Linux.Capabilities (Capability) + +newtype ImageName = ImageName {unImageName :: Text} + deriving (Show) + +data RuntimeContext + = Container ImageName + | Bubblewrap FilePath + deriving (Show) + +data Mode = RO | RW + deriving (Show) + +data VolumeType = HostPath FilePath | TmpFS | Volume Text + deriving (Show) + +data Volume = MkVolume Mode VolumeType + deriving (Show) + +data RunAs = RunAsRoot | RunAsHostUID | RunAsAnyUID + deriving (Show) + +data Port = PortTcp Natural | PortUdp Natural + deriving (Show) + +newtype Name = Name {unName :: Text} + deriving (Show) + +-- | The application context to be executed by podman or kubectl +data Context = Context + { -- | identifier + _name :: Name, + _namespace :: Maybe Text, + -- | container image name + _runtimeCtx :: RuntimeContext, + -- | network namespace name + _network :: Bool, + _ports :: [Port], + _runAs :: Maybe RunAs, + _selinux :: Bool, + -- | the unique uid for this container + _anyUid :: UserID, + -- | host uid + _uid :: UserID, + -- | container command + _command :: [Text], + _workdir :: Maybe FilePath, + -- | container env + _environ :: Map Text Text, + -- | container volumes + _mounts :: Map FilePath Volume, + _syscaps :: [Capability], + _ro :: Bool, + -- | container devices + _devices :: Set FilePath, + _hostname :: Maybe Text, + _interactive :: Bool, + _terminal :: Bool, + _privileged :: Bool + } + deriving (Show) + +$(makeLenses ''Context) + +defaultContext :: Name -> RuntimeContext -> Context +defaultContext _name _runtimeCtx = + Context + { _name, + _runtimeCtx, + _command = [], + _uid = 0, + _namespace = Nothing, + -- todo keep track of fresh uid + _anyUid = 4242, + _selinux = True, + _network = False, + _ports = mempty, + _runAs = Nothing, + _environ = mempty, + _mounts = mempty, + _devices = mempty, + _syscaps = mempty, + -- TODO: make ro work for podman + _ro = True, + _workdir = Nothing, + _hostname = Nothing, + _interactive = False, + _terminal = False, + _privileged = False + } + +rwHostPath :: FilePath -> Volume +rwHostPath = MkVolume RW . HostPath + +roHostPath :: FilePath -> Volume +roHostPath = MkVolume RO . HostPath + +tmpfs :: Volume +tmpfs = MkVolume RW TmpFS + +-- Env and mounts head value takes priority +addEnv :: Text -> Text -> Context -> Context +addEnv k v = environ %~ Map.insertWith (\_n o -> o) k v + +addMount :: FilePath -> Volume -> Context -> Context +addMount containerPath hostPath = mounts %~ Map.insertWith (\_n o -> o) containerPath hostPath + +directMount :: FilePath -> Context -> Context +directMount fp = addMount fp (rwHostPath fp) + +addDevice :: FilePath -> Context -> Context +addDevice dev = devices %~ Set.insert dev diff --git a/src/Podenv/Dhall.hs b/src/Podenv/Dhall.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Dhall.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +-- makeLenses does not produce those +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} + +-- | This module defines Haskell data types and lenses for the podenv dhall schemas. +module Podenv.Dhall where + +import Data.Char (toUpper) +import Data.Void +import Dhall.Core (Expr ()) +import qualified Dhall.TH +import Lens.Family.TH (makeLensesBy) + +-- | The hub submodule commit, this is only used for the PODENV environment value +hubCommit :: Expr Void Void +hubCommit = $(Dhall.TH.staticDhallExpression "env:HUB_COMMIT as Text ? ./.git/modules/hub/HEAD as Text") + +-- | Embed static dhall code +podenvPackage :: Expr Void Void +podenvPackage = $(Dhall.TH.staticDhallExpression "./hub/package.dhall") + +appType, appDefault, runtimeType, containerBuildDefault :: Expr Void Void +appType = $(Dhall.TH.staticDhallExpression "(./hub/schemas/Application.dhall).Type") +runtimeType = $(Dhall.TH.staticDhallExpression "./hub/schemas/Runtime.dhall") +containerBuildDefault = $(Dhall.TH.staticDhallExpression "(./hub/schemas/ContainerBuild.dhall).default") +appDefault = + $( let package = "(./hub/schemas/package.dhall)" + in Dhall.TH.staticDhallExpression (package <> ".Application.default // { runtime = " <> package <> ".Image \"\" }") + ) + +capsDefault :: Expr Void Void +capsDefault = $(Dhall.TH.staticDhallExpression "(./hub/schemas/Capabilities.dhall).default") + +systemConfigDefault :: Expr Void Void +systemConfigDefault = $(Dhall.TH.staticDhallExpression "(./hub/schemas/System.dhall).default") + +-- | Generate Haskell Types from Dhall Types. +-- See: https://hackage.haskell.org/package/dhall-1.39.0/docs/Dhall-TH.html +Dhall.TH.makeHaskellTypes + ( let mainPath name = "(./hub/schemas/" <> name <> ".dhall).Type" + main' cname name = Dhall.TH.SingleConstructor cname cname $ mainPath name + main name = main' name name + in [ main "Capabilities", + main "Application", + main "ContainerBuild", + main "Flakes", + main' "SystemConfig" "System", + Dhall.TH.MultipleConstructors "Runtime" "./hub/schemas/Runtime.dhall" + ] + ) + +$(makeLensesBy (\n -> Just $ "cap" <> [toUpper $ head n] <> tail n) ''Capabilities) + +$(makeLensesBy (\n -> Just $ "app" <> [toUpper $ head n] <> tail n) ''Application) + +$(makeLensesBy (\n -> Just $ "cb" <> [toUpper $ head n] <> tail n) ''ContainerBuild) + +deriving instance Show Runtime + +deriving instance Eq Runtime + +deriving instance Show ContainerBuild + +deriving instance Eq ContainerBuild + +deriving instance Show Flakes + +deriving instance Eq Flakes + +deriving instance Show Capabilities + +deriving instance Eq Capabilities + +deriving instance Show Application + +deriving instance Eq Application + +$(makeLensesBy (\n -> Just $ "sys" <> [toUpper $ head n] <> tail n) ''SystemConfig) + +deriving instance Show SystemConfig + +deriving instance Eq SystemConfig diff --git a/src/Podenv/Env.hs b/src/Podenv/Env.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Env.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} + +-- | The platform environment +module Podenv.Env where + +import qualified Data.List.NonEmpty +import qualified Data.Maybe +import qualified Data.Text +import Lens.Family.TH (makeLenses) +import Podenv.Prelude + +data AppEnv = AppEnv + { _hostXdgRunDir :: Maybe FilePath, + _hostHomeDir :: Maybe FilePath, + _hostCwd :: FilePath, + _hostUid :: UserID, + _appHomeDir :: Maybe FilePath, + _rootfsHome :: FilePath -> IO (Maybe FilePath) + } + +$(makeLenses ''AppEnv) + +type AppEnvT a = ReaderT AppEnv IO a + +-- | Get the current uid home path in the rootfs +getRootfsHome :: UserID -> Maybe FilePath -> FilePath -> IO (Maybe FilePath) +getRootfsHome _ (Just hostHome) "/" = pure $ Just hostHome +getRootfsHome uid _ fp = do + passwd <- readFileM (fp "etc/passwd") + pure $ + toString . Data.List.NonEmpty.head + <$> Data.List.NonEmpty.nonEmpty (Data.Maybe.mapMaybe isUser $ Podenv.Prelude.lines passwd) + where + isUser l = case Data.Text.splitOn ":" l of + (_ : _ : uid' : _ : _ : home : _) | readMaybe (toString uid') == Just uid -> Just home + _ -> Nothing + +new :: IO AppEnv +new = do + uid <- getRealUserID + home <- lookupEnv "HOME" + AppEnv + <$> lookupEnv "XDG_RUNTIME_DIR" + <*> pure home + <*> getCurrentDirectory + <*> pure uid + <*> pure Nothing + <*> pure (getRootfsHome uid home) diff --git a/src/Podenv/Main.hs b/src/Podenv/Main.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Main.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This module contains the podenv CLI entrypoint +-- The workflow is: Main -> Config -> Build -> Application -> Context +-- +-- * Main: select the app and override with command line arguments +-- * Config: load the configuration and select the application +-- * Build: optional application build +-- * App: convert application and capability into a Context +-- * Runtime: execute with podman or kubernetes +module Podenv.Main + ( main, + runApp, + + -- * exports for tests + usage, + cliConfigLoad, + cliInfo, + cliPrepare, + CLI (..), + ) +where + +import qualified Data.Text +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.Dhall +import Podenv.Prelude +import Podenv.Runtime (Context, Name (..), RuntimeEnv (..)) +import qualified Podenv.Runtime +import qualified Podenv.Version (version) + +-- | podenv entrypoint +main :: IO () +main = do + cli@CLI {..} <- usage =<< getArgs + 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 + + if showApplication + then putTextLn $ showApp app ctx be re + else do + Podenv.Build.beEnsure be (runApp re) + when update $ Podenv.Build.beUpdate be (runApp re) + Podenv.Runtime.execute re ctx + +-- | 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) + Podenv.Runtime.execute re ctx + +usage :: [String] -> IO CLI +usage args = do + cli <- handleParseResult $ execParserPure defaultPrefs cliInfo cliArgs + pure $ cli {extraArgs = map toText appArgs} + where + cliArgs = takeCliArgs [] args + appArgs = case drop (length cliArgs) args of + -- Drop any `--` prefix + ("--" : rest) -> rest + xs -> xs + + -- Collect args until the selector, the rest should not be passed to optparse-applicative + isPodenvArg arg + | arg `elem` strOptions || "--bash-completion-" `isPrefixOf` arg = True + | otherwise = False + takeCliArgs acc args' = case args' of + [] -> reverse acc + -- Handle toggle such as `"--name" : "app-name" : _` + (toggle : x : xs) | isPodenvArg toggle -> takeCliArgs (x : toggle : acc) xs + (x : xs) + -- `--` is a hard separator, stop now. + | "--" == x -> takeCliArgs acc [] + -- this is switch, keep on taking + | "--" `isPrefixOf` x -> takeCliArgs (x : acc) xs + -- otherwise the selector is found, stop now + | otherwise -> takeCliArgs (x : acc) [] + +data CLI = CLI + { -- action modes: + listApps :: Bool, + listCaps :: Bool, + showDhallEnv :: Bool, + showApplication :: Bool, + configExpr :: Maybe Text, + -- runtime env: + update :: Bool, + verbose :: 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], + selector :: Maybe Text, + extraArgs :: [Text] + } + +-- WARNING: when adding strOption, update the 'strOptions' list +cliParser :: Parser CLI +cliParser = + CLI + -- action modes: + <$> switch (long "list" <> help "List available applications") + <*> switch (long "list-caps" <> help "List available capabilities") + <*> 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") + -- app modifiers: + <*> capsParser + <*> switch (long "shell" <> help "Start a shell instead of the application command") + <*> optional (strOption (long "namespace" <> help "Share a network ns")) + <*> optional (strOption (long "name" <> metavar "NAME" <> help "Container name")) + <*> many (strOption (long "env" <> metavar "ENV" <> help "Extra env 'KEY=VALUE'")) + <*> many (strOption (long "volume" <> short 'v' <> metavar "VOLUME" <> help "Extra volumes 'volume|hostPath[:containerPath]'")) + <*> optional (strArgument (metavar "APP" <> help "Application config name or image:name or nix:expr")) + <*> many (strArgument (metavar "ARGS" <> help "Application args")) + +-- | List of strOption that accept an argument (that is not the selector) +strOptions :: [String] +strOptions = ["--config", "--namespace", "--name", "--env", "--volume", "-v"] + +-- | Parse all capabilities toggles +capsParser :: Parser [Capabilities -> Capabilities] +capsParser = catMaybes <$> traverse mkCapParser Podenv.Application.capsAll + where + mkCapParser :: Podenv.Application.Cap -> Parser (Maybe (Capabilities -> Capabilities)) + mkCapParser cap = + toggleCapParser cap True <|> toggleCapParser cap False + +-- | A helper function to parse CLI capability toggle +toggleCapParser :: Podenv.Application.Cap -> Bool -> Parser (Maybe (Capabilities -> Capabilities)) +toggleCapParser Podenv.Application.Cap {..} isOn = setMaybeCap <$> flagParser + where + -- We parse a dummy flag from the command line + flagParser :: Parser (Maybe ()) + flagParser = optional (flag' () (long flagName <> hidden)) + flagName = toString $ (if isOn then "" else "no-") <> capName + + -- That will be replaced by the setCap when Just () + setMaybeCap :: Maybe () -> Maybe (Capabilities -> Capabilities) + setMaybeCap = fmap (const setCap) + setCap :: Capabilities -> Capabilities + setCap = capLens .~ isOn + +cliInfo :: ParserInfo CLI +cliInfo = + info + (versionOption <*> cliParser <**> helper) + (fullDesc <> header "podenv - a container wrapper") + where + versionOption = + infoOption + (concat [showVersion version, " ", Podenv.Version.version]) + (long "version" <> help "Show version") + +-- | Load the config +cliConfigLoad :: CLI -> IO (Application, Podenv.Application.Mode, Name, RuntimeEnv) +cliConfigLoad cli@CLI {..} = do + system <- Podenv.Config.loadSystem + -- The volumes dir may be provided by the system config, otherwise default to ~/.local/share/podenv/volumes + volumesDir <- case data_volumes_dir system of + Just fp -> pure $ toString fp + 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 + name' = Name $ fromMaybe (app ^. appName) name + re = RuntimeEnv {verbose, system, 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 + where + modifiers = setShell . setEnvs . setVolumes . setCaps . setNS . addArgs + + addArgs = appCommand %~ (<> args) + + setNS = maybe id (appNamespace ?~) namespace + + setShell = bool id setShellCap shell + setShellCap = appCapabilities %~ (capTerminal .~ True) . (capInteractive .~ True) + + setEnvs app' = foldr (\v -> appEnviron %~ (v :)) app' cliEnv + + setVolumes app' = foldr (\v -> appVolumes %~ (v :)) app' volumes + + setCaps app' = foldr (appCapabilities %~) app' capsOverride + +showApp :: Application -> Context -> Podenv.Build.BuildEnv -> RuntimeEnv -> Text +showApp Application {..} ctx be re = unlines infos + where + infos = + ["[+] runtime: " <> Podenv.Build.beInfos be, ""] + <> ["[+] Capabilities", unwords appCaps, ""] + <> ["[+] Command", cmd] + cmd = Podenv.Runtime.showRuntimeCmd re ctx + appCaps = concatMap showCap Podenv.Application.capsAll + showCap Podenv.Application.Cap {..} = + [capName | capabilities ^. capLens] + +printCaps :: IO () +printCaps = do + putText $ unlines $ sort $ map showCap Podenv.Application.capsAll + where + showCap Podenv.Application.Cap {..} = + let sep = if Data.Text.length capName < 8 then "\t\t" else "\t" + in capName <> sep <> capDescription + +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) = + "Application" <> maybe "" (\desc -> " (" <> desc <> ")") (app ^. appDescription) + showFunc args app = "λ " <> args <> " → " <> showApp' app + showArg a = "<" <> show a <> ">" + showConfig = \case + Podenv.Config.Lit app -> showApp' app + Podenv.Config.LamArg name f -> showFunc (show name) (f (showArg name)) + Podenv.Config.LamArg2 n1 n2 f -> showFunc (show n1 <> " " <> show n2) (f (showArg n1) (showArg n2)) + Podenv.Config.LamApp _ -> "λ app → app" + showAtom (name, app) = name <> ": " <> showConfig app + traverse_ (putTextLn . showAtom) atoms diff --git a/src/Podenv/Prelude.hs b/src/Podenv/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Prelude.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Common functions +module Podenv.Prelude + ( module Relude, + foldM, + lookup, + getEnv, + orDie, + mayFail, + + -- * io + readFileM, + hPutStrLn, + + -- * base env + +#if !MIN_VERSION_relude(1,0,0) + getArgs, + lookupEnv, +#endif + getExecutablePath, + + -- * xdg + getCacheDir, + getConfigDir, + getDataDir, + + -- * directory + createDirectoryIfMissing, + getCurrentDirectory, + doesFileExist, + doesPathExist, + doesSymlinkExist, + pathIsSymbolicLink, + findExecutable, + (), + takeFileName, + takeDirectory, + hasTrailingPathSeparator, + listDirectory, + + -- * posix + UserID, + getRealUserID, + + -- * lens + Lens', + (^.), + (.~), + (?~), + (%~), + setWhenNothing, + ) +where + +import qualified Control.Exception +import Control.Monad (foldM) +import qualified Data.Text.IO +import Lens.Family (ASetter, set, (%~), (.~), (^.)) +import Relude +import Relude.Extra.Lens (Lens') +import System.Directory +import System.Environment +import System.FilePath.Posix (hasTrailingPathSeparator, takeDirectory, takeFileName, ()) +import System.IO (hPutStrLn) +import qualified System.Posix.Files +import System.Posix.Types (UserID) +import System.Posix.User (getRealUserID) + +orDie :: Maybe a -> Text -> Either Text a +orDie (Just a) _ = Right a +orDie Nothing e = Left e + +mayFail :: Either Text a -> IO a +mayFail (Right a) = pure a +mayFail (Left msg) = hPutStrLn stderr ("Error: " <> toString msg) >> exitFailure >> fail "over" + +(?~) :: ASetter s t a (Maybe b) -> b -> s -> t +l ?~ b = set l (Just b) + +setWhenNothing :: ASetter s t (Maybe b) (Maybe b) -> b -> s -> t +l `setWhenNothing` b = l %~ maybe (Just b) Just + +getCacheDir :: IO FilePath +getCacheDir = getXdgDirectory XdgCache "podenv" + +getDataDir :: IO FilePath +getDataDir = getXdgDirectory XdgData "podenv" + +getConfigDir :: IO FilePath +getConfigDir = getXdgDirectory XdgConfig "podenv" + +readFileM :: FilePath -> IO Text +readFileM fp' = do + exist <- liftIO $ doesFileExist fp' + if exist + then liftIO $ Data.Text.IO.readFile fp' + else pure "" + +doesSymlinkExist :: FilePath -> IO Bool +doesSymlinkExist fp = + either (const False) (const True) <$> checkFp + where + checkFp :: IO (Either Control.Exception.SomeException FilePath) + checkFp = Control.Exception.try $ System.Posix.Files.readSymbolicLink fp diff --git a/src/Podenv/Runtime.hs b/src/Podenv/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Runtime.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This module contains the podman/bubblewrap context wrapper +module Podenv.Runtime + ( execute, + showRuntimeCmd, + + -- * Podman helpers + podman, + podmanRunArgs, + + -- * Bubblewrap helpers + bwrap, + bwrapRunArgs, + + -- * data type and lenses + module Podenv.Context, + RuntimeEnv (..), + defaultRuntimeEnv, + ) +where + +import qualified Data.Map.Strict as Map +import qualified Data.Set +import qualified Data.Text as Text +import Podenv.Config (defaultSystemConfig) +import Podenv.Context +import Podenv.Dhall (SystemConfig (..), sysDns) +import Podenv.Prelude +import qualified System.Process.Typed as P + +execute :: RuntimeEnv -> Context -> IO () +execute re ctx = do + traverse_ (ensureHostDirectory (volumesDir re)) (Map.elems $ ctx ^. mounts) + runReaderT (doExecute ctx) re + +-- | Create host directory and set SELinux label if needed +ensureHostDirectory :: FilePath -> Volume -> IO () +ensureHostDirectory volumesDir (MkVolume _ (Volume volumeName)) = + ensureHostDirectory' $ volumesDir toString volumeName +ensureHostDirectory _ (MkVolume _ (HostPath fp)) | (last <$> nonEmpty fp) == Just '/' = ensureHostDirectory' fp +ensureHostDirectory _ _ = pure () + +ensureHostDirectory' :: FilePath -> IO () +ensureHostDirectory' fp = do + exist <- doesPathExist fp + unless exist $ do + createDirectoryIfMissing True fp + P.runProcess_ $ P.proc "chcon" ["system_u:object_r:container_file_t:s0", fp] + +doExecute :: Context -> ContextEnvT () +doExecute ctx = case ctx ^. runtimeCtx of + Container image -> executePodman ctx image + Bubblewrap fp -> executeBubblewrap ctx fp + +executeBubblewrap :: Context -> FilePath -> ContextEnvT () +executeBubblewrap ctx fp = do + re <- ask + let args = bwrapRunArgs re ctx fp + let cmd = bwrap args + debug $ show cmd + P.runProcess_ cmd + +bwrap :: [String] -> P.ProcessConfig () () () +bwrap = P.setDelegateCtlc True . P.proc "bwrap" + +commonArgs :: Context -> [Text] +commonArgs Context {..} = + concatMap (\c -> ["--cap-add", Text.drop 4 (show c)]) _syscaps + +bwrapRunArgs :: RuntimeEnv -> Context -> FilePath -> [String] +bwrapRunArgs RuntimeEnv {..} ctx@Context {..} fp = toString <$> args + where + userArg = case ctx ^. runAs of + Just RunAsRoot -> ["--unshare-user", "--uid", "0"] + Just RunAsHostUID -> [] + Just RunAsAnyUID -> ["--unshare-user", "--uid", show $ ctx ^. anyUid] + Nothing -> [] + + networkArg + | _network = case _namespace of + Just "host" -> [] + Just _ns -> error "Shared netns not implemented" + Nothing -> [] -- TODO: implement private network namespace + | otherwise = ["--unshare-net"] + + volumeArg :: (FilePath, Volume) -> [Text] + volumeArg (destPath, MkVolume mode vtype) = case vtype of + HostPath hostPath -> [volumeMode mode, toText hostPath, toText destPath] + Volume x -> [volumeMode mode, toText $ volumesDir toString x, toText destPath] + TmpFS -> ["--tmpfs", toText destPath] + where + volumeMode = \case + RO -> "--ro-bind" + RW -> "--bind" + + rootMounts = case fp of + "/" -> + doBind "usr" + <> doBind "lib" + <> doBind "lib64" + <> doBind "bin" + <> doBind "sbin" + <> doBind "etc" + c : _ | c `notElem` ['/', ':'] -> toText <$> [bindMode, toString volumesDir fp, "/"] + _ -> doBind "" + + sysMounts + | Data.Set.null _devices = [] + | otherwise = ["--ro-bind", "/sys", "/sys"] + + bindMode + | ctx ^. ro = "--ro-bind" + | otherwise = "--bind" + doBind p = toText <$> [bindMode, fp p, "/" p] + args = + userArg + <> ["--die-with-parent", "--unshare-pid", "--unshare-ipc", "--unshare-uts"] + <> networkArg + <> commonArgs ctx + <> rootMounts + <> ["--proc", "/proc"] + <> ["--dev", "/dev"] + <> ["--perms", "01777", "--tmpfs", "/tmp"] + <> concatMap volumeArg (Map.toAscList _mounts) + <> concatMap (\d -> ["--dev-bind", toText d, toText d]) _devices + <> sysMounts + <> ["--clearenv"] + <> concatMap (\(k, v) -> ["--setenv", toText k, v]) (Map.toAscList _environ) + <> cond (not _terminal) ["--new-session"] + <> maybe [] (\wd -> ["--chdir", toText wd]) _workdir + <> _command + +showRuntimeCmd :: RuntimeEnv -> Context -> Text +showRuntimeCmd re ctx = case ctx ^. runtimeCtx of + Container image -> show . P.proc "podman" $ podmanRunArgs re ctx image + Bubblewrap fp -> show . P.proc "bwrap" $ bwrapRunArgs re ctx fp + +data RuntimeEnv = RuntimeEnv + { verbose :: Bool, + system :: SystemConfig, + volumesDir :: FilePath + } + deriving (Show) + +defaultRuntimeEnv :: FilePath -> RuntimeEnv +defaultRuntimeEnv = RuntimeEnv True defaultSystemConfig + +type ContextEnvT a = ReaderT RuntimeEnv IO a + +debug :: Text -> ContextEnvT () +debug msg = do + isVerbose <- asks verbose + when isVerbose $ liftIO $ hPutStrLn stderr ("[+] " <> toString msg) + +cond :: Bool -> [a] -> [a] +cond b xs = if b then xs else [] + +infraName :: Text -> Text +infraName ns = ns <> "-ns" + +podmanArgs :: Context -> [Text] +podmanArgs Context {..} = cond _interactive ["-i", "--detach-keys", ""] <> cond _terminal ["-t"] + +podmanRunArgs :: RuntimeEnv -> Context -> ImageName -> [String] +podmanRunArgs RuntimeEnv {..} ctx@Context {..} image = toString <$> args + where + portArgs = concatMap publishArg _ports + publishArg port = ["--publish", showPort port] + showPort port = show $ case port of + -- podman does not seem to distinguish protocol + PortTcp p -> p + PortUdp p -> p + + 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 + | otherwise = ["--network", "none"] + + volumeArg :: (FilePath, Volume) -> [Text] + volumeArg (fp, MkVolume mode vtype) = case vtype of + HostPath x -> volume (toText x) + Volume x -> volume (toText $ volumesDir toString x) + TmpFS -> ["--mount", "type=tmpfs,destination=" <> toText fp] + where + volume hp = ["--volume", hp <> ":" <> toText fp <> showVolumeMode mode] + showVolumeMode = \case + RO -> ":ro" + RW -> "" + + -- The goal here is to ensure host files created by the container are readable by the host user. + userArg = case ctx ^. runAs of + Just RunAsRoot -> ["--user", "0"] + Just RunAsHostUID -> ["--user", show (ctx ^. uid), "--userns", "keep-id"] + Just RunAsAnyUID -> + let x = ctx ^. anyUid + in ["--user", show x, "--uidmap", show x <> ":0:1", "--uidmap", "0:1:" <> show x] + Nothing -> [] + + nameArg = ["--name", unName _name] + + args = + ["run"] + <> podmanArgs ctx + <> maybe [] (\h -> ["--hostname", h]) _hostname + <> cond _privileged ["--privileged"] + <> ["--rm"] + <> cond _ro ["--read-only=true"] + <> cond (not _selinux) ["--security-opt", "label=disable"] + <> userArg + <> networkArg + <> commonArgs ctx + <> concatMap (\d -> ["--device", toText d]) _devices + <> maybe [] (\wd -> ["--workdir", toText wd]) _workdir + <> concatMap (\(k, v) -> ["--env", toText $ k <> "=" <> v]) (Map.toAscList _environ) + <> concatMap volumeArg (Map.toAscList _mounts) + <> nameArg + <> [unImageName image] + <> _command + +podman :: [String] -> P.ProcessConfig () () () +podman = P.setDelegateCtlc True . P.proc "podman" + +data PodmanStatus + = -- | The container does not exists, it needs to be created + NotFound + | -- | The container is already running + Running + | -- | The container ran and it is now stopped + Unknown Text + deriving (Show, Eq) + +getPodmanStatus :: String -> ContextEnvT PodmanStatus +getPodmanStatus cname = do + (_, stdout', _) <- P.readProcess (podman ["inspect", cname, "--format", "{{.State.Status}}"]) + pure $ case stdout' of + "" -> NotFound + "running\n" -> Running + other -> Unknown (Text.dropWhileEnd (== '\n') $ decodeUtf8 other) + +ensureInfraNet :: Text -> ContextEnvT () +ensureInfraNet ns = do + debug $ "Ensuring infra net for: " <> show ns + let pod = infraName ns + infraStatus <- getPodmanStatus (toString pod) + case infraStatus of + Running -> pure () + _ -> do + when (infraStatus /= NotFound) $ + -- Try to delete any left-over infra container + P.runProcess_ (podman ["rm", toString pod]) + + system' <- asks system + let cmd = + podman $ + map toString $ + ["run", "--rm", "--name", pod] + <> ["--detach"] + <> maybe [] (\dns -> ["--dns=" <> dns]) (system' ^. sysDns) + <> ["ubi8"] + <> ["sleep", "infinity"] + debug $ show cmd + P.runProcess_ cmd + +executePodman :: Context -> ImageName -> ContextEnvT () +executePodman ctx image = do + re <- ask + case (ctx ^. namespace, ctx ^. network) of + (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 + args <- + case status of + NotFound -> pure $ podmanRunArgs re ctx image + Running -> cfail "container is already running, use `exec` to join, or `--name new` to start a new instance" + Unknown _ -> recreateContainer re + let cmd = podman args + debug $ show cmd + P.runProcess_ cmd + where + cname = toString (unName $ ctx ^. name) + -- Delete a non-kept container and return the run args + recreateContainer re = do + P.runProcess_ (podman ["rm", cname]) + pure $ podmanRunArgs re ctx image diff --git a/src/Podenv/Version.hs b/src/Podenv/Version.hs new file mode 100644 --- /dev/null +++ b/src/Podenv/Version.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Podenv version +module Podenv.Version (version) where + +import Development.GitRev (gitDirty, gitHash) +import Language.Haskell.TH.Env (envQ) + +version :: String +version = case fromEnv of + Just v -> v + Nothing -> $(gitHash) <> dirty + where + fromEnv :: Maybe String + fromEnv = $$(envQ "PODENV_COMMIT") + dirty + | $(gitDirty) = "-dirty" + | otherwise = "" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,218 @@ +{-# 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 Podenv.Env +import qualified Podenv.Main +import Podenv.Prelude (mayFail) +import qualified Podenv.Runtime +import System.Environment (getEnv, setEnv) +import Test.Hspec + +main :: IO () +main = mockEnv >> loadConfig >>= hspec . spec + where + loadConfig = Podenv.Config.load Nothing (Just "./test/config.dhall") + + -- Fix env values while keeping the host cache for dhall + mockEnv = do + curHome <- getEnv "HOME" + setEnv "XDG_CACHE_HOME" (curHome <> "/.cache") + setEnv "HOME" "/home/user" + setEnv "WAYLAND_DISPLAY" "wayland-0" + +spec :: Podenv.Config.Config -> Spec +spec config = describe "unit tests" $ do + describe "config" $ do + it "load simple" $ loadTest "env" [] + it "load collection" $ loadTest "{ a = env, b = env}" ["a", "b"] + it "load nested" $ loadTest "{ a = { b = env, c = env}, d = env}" ["a.b", "a.c", "d"] + it "load weak" $ loadTest "{ image = { runtime.image = \"ubi\" }, nix = { runtime.nix = \"n\" } }" ["image", "nix"] + describe "builder config" $ do + it "load firefox" $ do + (_, baseApp) <- mayFail $ Podenv.Config.select config ["firefox"] + (be, _) <- Podenv.Build.prepare defRe baseApp + Text.take 34 (Podenv.Build.beInfos be) `shouldBe` "# Containerfile localhost/3c922bca" + it "load nixify" $ do + (_, baseApp) <- mayFail $ Podenv.Config.select config ["nixify", "firefox", "about:blank"] + (be, _) <- Podenv.Build.prepare defRe baseApp + Text.take 34 (Podenv.Build.beInfos be) `shouldBe` "# Containerfile localhost/3c922bca" + it "override nixpkgs when necessary" $ do + let mkApp installables pin = + Podenv.Config.defaultApp + { Podenv.Dhall.runtime = Podenv.Dhall.Nix (Podenv.Dhall.Flakes installables pin) + } + + (_, app0) <- Podenv.Build.prepare defRe (mkApp ["nixpkgs#hello"] (Just "nixpkgs/42")) + (Podenv.Dhall.command app0) `shouldContain` ["--override-input", "nixpkgs"] + + (_, app1) <- Podenv.Build.prepare defRe (mkApp ["nixpkgs/42#hello"] (Just "nixpkgs/42")) + (Podenv.Dhall.command app1) `shouldNotContain` ["--override-input", "nixpkgs"] + + (_, app2) <- Podenv.Build.prepare defRe (mkApp ["nixpkgs/42#hello", "nixGL"] (Just "nixpkgs/42")) + (Podenv.Dhall.command app2) `shouldContain` ["--override-input", "nixpkgs"] + + 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"] + it "handle separator" $ do + cli <- Podenv.Main.usage ["--name", "test", "image:ubi8", "--", "ls", "-la"] + Podenv.Main.extraArgs 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\"]}" + it "add --arg" $ cliTest "env" ["--", "--arg"] "env // { command = [\"--arg\"]}" + it "set cap" $ cliTest "env" ["--wayland"] (addCap "env" "wayland = True") + it "unset cap" $ cliTest (addCap "env" "wayland = True") ["--no-wayland"] "env" + it "set volume" $ cliTest "env" ["--volume", "/tmp/test"] "env // { volumes = [\"/tmp/test\"]}" + it "one args" $ cliTest "\\(name : Text) -> env // { name }" ["a"] "env // { name = \"a\"}" + it "two args" $ cliTest "\\(name : Text) -> \\(desc : Text) -> env // { name, description = Some desc }" ["a", "b"] "env // { name = \"a\", description = Some \"b\"}" + describe "cli default" $ do + it "image:name" $ cliTest "env" ["image:testy"] "def // { runtime = Podenv.Image \"testy\", name = \"image-b2effd\" }" + 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 "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 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" $ + podmanTest "env // { volumes = [\"~/src:/data\"]}" (defRun ["--security-opt", "label=disable", "--hostname", "env", "--volume", "/home/user/src:/data"]) + it "run many volumes" $ + podmanTest + "env // { volumes = [\"/home/data:/tmp/data\", \"/tmp\", \"/home/old-data:/tmp/data\"]}" + (defRun ["--security-opt", "label=disable", "--hostname", "env", "--volume", "/tmp:/tmp", "--volume", "/home/data:/tmp/data"]) + describe "podman cli" $ do + it "run minimal" $ podmanCliTest ["image:ubi8"] ["run", "--rm", "--network", "none", "--name", "image-8bfbaa", "ubi8"] + it "wayland disable selinux" $ + let cmd = ["run", "--rm", "--security-opt", "label=disable", "--network", "none", "--env", "GDK_BACKEND=wayland", "--env", "QT_QPA_PLATFORM=wayland", "--env", "WAYLAND_DISPLAY=wayland-0", "--env", "XDG_RUNTIME_DIR=/run/user/1000", "--env", "XDG_SESSION_TYPE=wayland", "--mount", "type=tmpfs,destination=/dev/shm", "--volume", "/etc/machine-id:/etc/machine-id", "--mount", "type=tmpfs,destination=/run/user", "--volume", "/run/user/1000/wayland-0:/run/user/1000/wayland-0", "--name", "image-8bfbaa", "ubi8"] + in podmanCliTest ["--wayland", "image:ubi8"] cmd + it "hostfile are substituted" $ + let cmd = ["run", "--rm", "--network", "none", "--volume", "/proc/cmdline:/data/cmdline", "--volume", "/etc/hosts:/data/hosts", "--name", "image-8bfbaa", "ubi8", "cat", "/data/hosts", "/data/cmdline"] + in podmanCliTest ["--hostfile", "image:ubi8", "cat", "/etc/hosts", "/proc/cmdline"] cmd + it "run with name" $ + podmanCliTest + ["--name", "test", "image:ubi8"] + ["run", "--rm", "--network", "none", "--name", "test", "ubi8"] + it "run simple" $ + podmanCliTest + ["--network", "--shell", "image:ubi8"] + ["run", "-i", "--detach-keys", "", "-t", "--rm", "--hostname", "image-8bfbaa", "--env", "TERM=xterm-256color", "--name", "image-8bfbaa", "ubi8", "/bin/sh"] + it "shell override hostfile" $ do + let expected extra = ["run", "-i", "--detach-keys", "", "-t", "--rm", "--network", "none", "--env", "TERM=xterm-256color"] <> extra <> ["--name", "image-8bfbaa", "ubi8"] + cmd = ["--hostfile", "--terminal", "image:ubi8", "vi", "/etc/hosts"] + podmanCliTest + (["--shell"] <> cmd) + (expected [] <> ["/bin/sh"]) + podmanCliTest + cmd + (expected ["--volume", "/etc/hosts:/data/hosts"] <> ["vi", "/data/hosts"]) + it "run many volumes" $ + podmanCliTest + ["--volume", "/home/data:/tmp/data", "--volume", "/tmp", "--volume", "/old:/tmp/data", "image:ubi8"] + ["run", "--rm", "--security-opt", "label=disable", "--network", "none", "--volume", "/tmp:/tmp", "--volume", "/home/data:/tmp/data", "--name", "image-8bfbaa", "ubi8"] + 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 + 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] + defImg = "ubi8" + defRe = Podenv.Runtime.defaultRuntimeEnv "/data" + + testEnv = + AppEnv + { _hostXdgRunDir = Just "/run/user/1000", + _hostHomeDir = Just "/home/user", + _hostCwd = "/usr/src/podenv", + _hostUid = 1000, + _appHomeDir = Just "/home/fedora", + _rootfsHome = const $ pure $ Just "/home/nobody" + } + + getFP ctx = case Podenv.Context._runtimeCtx ctx of + Podenv.Context.Bubblewrap fp -> fp + _ -> error "Not bwrap" + + defBwrap = + ["--die-with-parent", "--unshare-pid", "--unshare-ipc", "--unshare-uts", "--unshare-net"] + <> ["--ro-bind", "/srv", "/", "--proc", "/proc", "--dev", "/dev", "--perms", "01777", "--tmpfs", "/tmp"] + <> ["--bind", "/home/user/.local/share/podenv/volumes/rootfs-53b3be-home", "/home/nobody"] + <> ["--clearenv", "--setenv", "HOME", "/home/nobody", "--setenv", "TERM", "xterm-256color"] + <> ["--chdir", "/home/nobody"] + + bwrapTest args expected = do + 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 + Podenv.Runtime.bwrapRunArgs re ctx (getFP ctx) `shouldBe` expected + + getImg ctx = case Podenv.Context._runtimeCtx ctx of + Podenv.Context.Container image -> image + _ -> error "Not podman" + + podmanCliTest args expected = do + cli <- Podenv.Main.usage (["--rw"] <> args) + (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 + 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") + 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 + + let got = Podenv.Main.cliPrepare cli args' baseApp + got `shouldBe` expected + + loadTest code expected = do + config' <- loadConfig Nothing code + let got = case config' of + Podenv.Config.ConfigApplication _ -> [] + Podenv.Config.ConfigApplications xs -> map fst xs + _ -> error "Bad test config" + got `shouldBe` expected + + addCap code capCode = + "( " <> code <> " // { capabilities = (" <> code <> ").capabilities // {" <> capCode <> "}})" + + 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 + ] + ) + + loadOne code = do + config' <- loadConfig Nothing code + case config' of + Podenv.Config.ConfigApplication (Podenv.Config.Lit (Podenv.Config.ApplicationRecord x)) -> pure x + _ -> error "Expected a single app" diff --git a/test/config.dhall b/test/config.dhall new file mode 100644 --- /dev/null +++ b/test/config.dhall @@ -0,0 +1,12 @@ +let Podenv = ../hub/Podenv.dhall + +let fedora = + \(pkgs : List Text) -> + Podenv.Container + Podenv.ContainerBuild::{ containerfile = "FROM fedora" } + +in { firefox.runtime = fedora [ "firefox" ] + , nixify = + \(app : Podenv.Application.Type) -> + app // { volumes = [ "nix-store:/nix" ] } + }