services: Add rootless-podman-service-type.

* gnu/services/containers.scm: New file;
(rootless-podman-configuration): new variable;
(rootless-podman-service-subids): new variable;
(rootless-podman-service-accounts): new variable;
(rootless-podman-service-profile): new variable;
(rootless-podman-shepherd-services): new variable;
(rootless-podman-service-etc): new variable;
(rootless-podman-service-type): new variable.
* gnu/local.mk: Test it.
* gnu/local.mk: Add them.
* doc/guix.texi (Miscellaneous Services): Document it.

Change-Id: I041496474c1027da353bd6852f2554a065914d7a
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

1 files changed, 340 insertions, 0 deletions

diff --git a/gnu/tests/containers.scm b/gnu/tests/containers.scm
new file mode 100644
index 0000000000..ba2fb22df6
--- /dev/null
+++ b/gnu/tests/containers.scm
@@ -0,0 +1,340 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests containers)
+  #:use-module (gnu)
+  #:use-module (gnu tests)
+  #:use-module (guix build-system trivial)
+  #:use-module (gnu packages bash)
+  #:use-module (gnu packages containers)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages guile-xyz)
+  #:use-module (gnu services)
+  #:use-module (gnu services containers)
+  #:use-module (gnu services desktop)
+  #:use-module (gnu services dbus)
+  #:use-module (gnu services networking)
+  #:use-module (gnu system)
+  #:use-module (gnu system accounts)
+  #:use-module (gnu system vm)
+  #:use-module (guix gexp)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module ((guix scripts pack) #:prefix pack:)
+  #:use-module (guix store)
+  #:export (%test-rootless-podman))
+
+
+(define %rootless-podman-os
+  (simple-operating-system
+   (service rootless-podman-service-type
+            (rootless-podman-configuration
+             (subgids
+              (list (subid-range (name "dummy"))))
+             (subuids
+              (list (subid-range (name "dummy"))))))
+
+   (service dhcp-client-service-type)
+   (service dbus-root-service-type)
+   (service polkit-service-type)
+   (service elogind-service-type)
+
+   (simple-service 'accounts
+                   account-service-type
+                   (list (user-account
+                          (name "dummy")
+                          (group "users")
+                          (supplementary-groups '("wheel" "netdev" "cgroup"
+                                                  "audio" "video")))))))
+
+(define (run-rootless-podman-test oci-tarball)
+
+  (define os
+    (marionette-operating-system
+     (operating-system-with-gc-roots
+      %rootless-podman-os
+      (list oci-tarball))
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (volatile? #f)
+     (memory-size 1024)
+     (disk-image-size (* 3000 (expt 2 20)))
+     (port-forwardings '())))
+
+  (define test
+    (with-imported-modules '((gnu build marionette)
+                             (gnu services herd))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette))
+
+          (define marionette
+            ;; Relax timeout to accommodate older systems and
+            ;; allow for pulling the image.
+            (make-marionette (list #$vm) #:timeout 60))
+          (define out-dir "/tmp")
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "rootless-podman")
+
+          (test-assert "service started"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'cgroups2-fs-owner)
+                  (#f #f)
+                  ;; herd returns (running #f), likely because of one shot,
+                  ;; so consider any non-error a success.
+                  (('service response-parts ...) #t)))
+             marionette))
+
+          (test-equal "/sys/fs/cgroup/cgroup.subtree_control content is sound"
+            (list "cpu" "cpuset" "memory" "pids")
+            (marionette-eval
+             `(begin
+                (use-modules (srfi srfi-1)
+                             (ice-9 popen)
+                             (ice-9 match)
+                             (ice-9 rdelim))
+
+                (define (read-lines file-or-port)
+                  (define (loop-lines port)
+                    (let loop ((lines '()))
+                      (match (read-line port)
+                        ((? eof-object?)
+                         (reverse lines))
+                        (line
+                         (loop (cons line lines))))))
+
+                  (if (port? file-or-port)
+                      (loop-lines file-or-port)
+                      (call-with-input-file file-or-port
+                        loop-lines)))
+
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ args))
+                           (output (read-lines port))
+                           (status (close-pipe port)))
+                      output)))
+                (let* ((response1 (slurp
+                                   ,(string-append #$coreutils "/bin/cat")
+                                   "/sys/fs/cgroup/cgroup.subtree_control")))
+                  (sort-list (string-split (first response1) #\space) string<?)))
+             marionette))
+
+          (test-equal "/sys/fs/cgroup has correct permissions"
+            '("cgroup" "cgroup")
+            (marionette-eval
+             `(begin
+                (use-modules (ice-9 popen)
+                             (ice-9 match)
+                             (ice-9 rdelim))
+
+                (define (read-lines file-or-port)
+                  (define (loop-lines port)
+                    (let loop ((lines '()))
+                      (match (read-line port)
+                        ((? eof-object?)
+                         (reverse lines))
+                        (line
+                         (loop (cons line lines))))))
+
+                  (if (port? file-or-port)
+                      (loop-lines file-or-port)
+                      (call-with-input-file file-or-port
+                        loop-lines)))
+
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ args))
+                           (output (read-lines port))
+                           (status (close-pipe port)))
+                      output)))
+                (let* ((bash
+                        ,(string-append #$bash "/bin/bash"))
+                       (response1
+                        (slurp bash "-c"
+                               (string-append "ls -la /sys/fs/cgroup | "
+                                              "grep -E ' \\./?$' | awk '{ print $4 }'")))
+                       (response2 (slurp bash "-c"
+                                         (string-append "ls -l /sys/fs/cgroup/cgroup"
+                                                        ".{procs,subtree_control,threads} | "
+                                                        "awk '{ print $4 }' | sort -u"))))
+                  (list (string-join response1 "\n") (string-join response2 "\n"))))
+             marionette))
+
+          (test-equal "Load oci image and run it (unprivileged)"
+            '("hello world" "hi!" "JSON!" #o1777)
+            (marionette-eval
+             `(begin
+                (use-modules (srfi srfi-1)
+                             (ice-9 popen)
+                             (ice-9 match)
+                             (ice-9 rdelim))
+
+                (define (wait-for-file file)
+                  ;; Wait until FILE shows up.
+                  (let loop ((i 60))
+                    (cond ((file-exists? file)
+                           #t)
+                          ((zero? i)
+                           (error "file didn't show up" file))
+                          (else
+                           (pk 'wait-for-file file)
+                           (sleep 1)
+                           (loop (- i 1))))))
+
+                (define (read-lines file-or-port)
+                  (define (loop-lines port)
+                    (let loop ((lines '()))
+                      (match (read-line port)
+                        ((? eof-object?)
+                         (reverse lines))
+                        (line
+                         (loop (cons line lines))))))
+
+                  (if (port? file-or-port)
+                      (loop-lines file-or-port)
+                      (call-with-input-file file-or-port
+                        loop-lines)))
+
+                (define slurp
+                  (lambda args
+                    (let* ((port (apply open-pipe* OPEN_READ
+                                        (list "sh" "-l" "-c"
+                                              (string-join
+                                               args
+                                               " "))))
+                           (output (read-lines port))
+                           (status (close-pipe port)))
+                      output)))
+
+                (match (primitive-fork)
+                  (0
+                   (dynamic-wind
+                     (const #f)
+                     (lambda ()
+                       (setgid (passwd:gid (getpwnam "dummy")))
+                       (setuid (passwd:uid (getpw "dummy")))
+
+                       (let* ((loaded (slurp ,(string-append #$podman
+                                                             "/bin/podman")
+                                             "load" "-i"
+                                             ,#$oci-tarball))
+                              (repository&tag "localhost/guile-guest:latest")
+                              (response1 (slurp
+                                          ,(string-append #$podman "/bin/podman")
+                                          "run" "--pull" "never"
+                                          "--entrypoint" "bin/Guile"
+                                          repository&tag
+                                          "/aa.scm"))
+                              (response2 (slurp ;default entry point
+                                          ,(string-append #$podman "/bin/podman")
+                                          "run" "--pull" "never" repository&tag
+                                          "-c" "'(display \"hi!\")'"))
+
+                              ;; Check whether (json) is in $GUILE_LOAD_PATH.
+                              (response3 (slurp ;default entry point + environment
+                                          ,(string-append #$podman "/bin/podman")
+                                          "run" "--pull" "never" repository&tag
+                                          "-c" "'(use-modules (json))
+  (display (json-string->scm (scm->json-string \"JSON!\")))'"))
+
+                              ;; Check whether /tmp exists.
+                              (response4 (slurp
+                                          ,(string-append #$podman "/bin/podman")
+                                          "run" "--pull" "never" repository&tag "-c"
+                                          "'(display (stat:perms (lstat \"/tmp\")))'")))
+                         (call-with-output-file (string-append ,out-dir "/response1")
+                           (lambda (port)
+                             (display (string-join response1 " ") port)))
+                         (call-with-output-file (string-append ,out-dir "/response2")
+                           (lambda (port)
+                             (display (string-join response2 " ") port)))
+                         (call-with-output-file (string-append ,out-dir "/response3")
+                           (lambda (port)
+                             (display (string-join response3 " ") port)))
+                         (call-with-output-file (string-append ,out-dir "/response4")
+                           (lambda (port)
+                             (display (string-join response4 " ") port)))))
+                     (lambda ()
+                       (primitive-exit 127))))
+                  (pid
+                   (cdr (waitpid pid))))
+                (wait-for-file (string-append ,out-dir "/response4"))
+                (append
+                 (slurp "cat" (string-append ,out-dir "/response1"))
+                 (slurp "cat" (string-append ,out-dir "/response2"))
+                 (slurp "cat" (string-append ,out-dir "/response3"))
+                 (map string->number (slurp "cat" (string-append ,out-dir "/response4")))))
+             marionette))
+
+          (test-end))))
+
+  (gexp->derivation "rootless-podman-test" test))
+
+(define (build-tarball&run-rootless-podman-test)
+  (mlet* %store-monad
+      ((_ (set-grafting #f))
+       (guile (set-guile-for-build (default-guile)))
+       (guest-script-package ->
+        (package
+          (name "guest-script")
+          (version "0")
+          (source #f)
+          (build-system trivial-build-system)
+          (arguments `(#:guile ,guile-3.0
+                       #:builder
+                       (let ((out (assoc-ref %outputs "out")))
+                         (mkdir out)
+                         (call-with-output-file (string-append out "/a.scm")
+                           (lambda (port)
+                             (display "(display \"hello world\n\")" port)))
+                         #t)))
+          (synopsis "Display hello world using Guile")
+          (description "This package displays the text \"hello world\" on the
+standard output device and then enters a new line.")
+          (home-page #f)
+          (license license:public-domain)))
+       (profile (profile-derivation (packages->manifest
+                                     (list guile-3.0 guile-json-3
+                                           guest-script-package))
+                                    #:hooks '()
+                                    #:locales? #f))
+       (tarball (pack:docker-image
+                 "docker-pack" profile
+                 #:symlinks '(("/bin/Guile" -> "bin/guile")
+                              ("aa.scm" -> "a.scm"))
+                 #:extra-options
+                 '(#:image-tag "guile-guest")
+                 #:entry-point "bin/guile"
+                 #:localstatedir? #t)))
+    (run-rootless-podman-test tarball)))
+
+(define %test-rootless-podman
+  (system-test
+   (name "rootless-podman")
+   (description "Test rootless Podman service.")
+   (value (build-tarball&run-rootless-podman-test))))