Subject: [bug#76081] [PATCH v10 4/7] services: Add oci-service-type.

From: paul <[email-masked]>
Date: Sun, 1 Jun 2025 02:18:16 +0200

Hi,

On 5/16/25 03:38, Maxim Cournoyer wrote:
>>   @lisp
>> -(service oci-container-service-type
>> -         (list
>> -          (oci-container-configuration
>> -           (network "host")
>> -           (image
>> -            (oci-image
>> -             (repository "guile")
>> -             (tag "3")
>> -             (value (specifications->manifest '("guile")))
>> -             (pack-options '(#:symlinks (("/bin/guile" -> "bin/guile"))
>> -                             #:max-layers 2))))
>> -           (entrypoint "/bin/guile")
>> -           (command
>> -            '("-c" "(display \"hello!\n\")")))
>> -          (oci-container-configuration
>> -           (image "prom/prometheus")
>> -           (ports
>> -             '(("9000" . "9000")
>> -               ("9090" . "9090"))))
>> -          (oci-container-configuration
>> -           (image "grafana/grafana:10.0.1")
>> -           (network "host")
>> -           (volumes
>> -             '("/var/lib/grafana:/var/lib/grafana")))))
>> +(simple-service 'oci-provisioning
>> +                oci-service-type
>> +                (oci-extension
>> +                  (networks
>> +                    (list
>> +                      (oci-network-configuration (name "monitoring"))))
>> +                  (containers
>> +                   (list
>> +                    (oci-container-configuration
>> +                     (network "monitoring")
>> +                     (image
>> +                      (oci-image
>> +                        (repository "guile")
>> +                        (tag "3")
>> +                        (value (specifications->manifest '("guile")))
>> +                        (pack-options '(#:symlinks (("/bin/guile" -> "bin/guile"))
>> +                                        #:max-layers 2))))
>> +                     (entrypoint "/bin/guile")
>> +                     (command
>> +                      '("-c" "(display \"hello!\n\")")))
>> +                    (oci-container-configuration
>> +                      (image "prom/prometheus")
>> +                      (network "host")
>> +                      (ports
>> +                       '(("9000" . "9000")
>> +                         ("9090" . "9090"))))
>> +                    (oci-container-configuration
>> +                      (image "grafana/grafana:10.0.1")
>> +                      (network "host")
>> +                      (volumes
>> +                       '("/var/lib/grafana:/var/lib/grafana")))))))
> I was curious: was is the gain to have by using the extension mechanism
> instead of directly accepting a list of 'oci-configuration' or similarly
> named record to the oci-service-type?
One can always pass a list of 
'oci-{container,network,volume}-configuration's to an 'oci-configuration':

(service oci-service-type
          (oci-configuration
           (runtime 'podman)
           (containers
            (list
             (oci-container-configuration ...)))))

but you loose the deduplication checks done by the extension mechanisms. 
This is useful especially for containers: both System/Home services and 
users of plain 'simple-service' in the system configuration can add 
Shepherd services for different reasons, if users do not set an explicit 
value to the 'provision' field of 'oci-container-configuration', the 
Shepherd service name will be derived from the image. So the 
'oci-extension' suggestion in the documentation is to take care of 
duplicates.
>> +(define (oci-object-exists? runtime runtime-cli object verbose?)
>> +  #~(lambda* (name #:key (format-string "{{.Name}}"))
>> +      (use-modules (ice-9 format)
>> +                   (ice-9 match)
>> +                   (ice-9 popen)
>> +                   (ice-9 rdelim)
>> +                   (srfi srfi-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)))
>> +
>> +      #$(if (eq? runtime 'podman)
>> +            #~(let ((command
>> +                     (list #$runtime-cli
>> +                           #$object "exists" name)))
>> +                (when #$verbose?
>> +                  (format #t "Running~{ ~a~}~%" command))
>> +                (define exit-code (status:exit-val (apply system* command)))
>> +                (when #$verbose?
>> +                  (format #t "Exit code: ~a~%" exit-code))
>> +                (equal? EXIT_SUCCESS exit-code))
>> +            #~(let ((command
>> +                     (string-append #$runtime-cli
>> +                                    " " #$object " ls --format "
>> +                                    "\"" format-string "\"")))
>> +                (when #$verbose?
>> +                  (format #t "Running ~a~%" command))
>> +                (member name (read-lines (open-input-pipe command)))))))
> That's a complex piece of staged code; have you considered placing it in
> a supporting build-side module, e.g. gnu/build/oci-containers.scm ?
> Then it could be more simply imported in the gexp environment and used.
> See the gnu/build/jami-service.scm for an example.
Thank you I was not aware of this option, I tried to move as much as I 
could to gnu/build/oci-containers.scm.
>> +(define* (oci-image-loader runtime runtime-cli name image tag #:key (verbose? #f))
>> +  "Return a file-like object that, once lowered, will evaluate to a program able
>> +to load IMAGE through RUNTIME-CLI and to tag it with TAG afterwards."
>> +  (let ((tarball (lower-oci-image name image)))
>>       (with-imported-modules '((guix build utils))
>> -      (program-file (format #f "~a-image-loader" name)
>> +      (program-file
>> +       (format #f "~a-image-loader" name)
>>          #~(begin
>>              (use-modules (guix build utils)
>> +                        (ice-9 match)
>>                           (ice-9 popen)
>> -                        (ice-9 rdelim))
>> -
>> -           (format #t "Loading image for ~a from ~a...~%" #$name #$tarball)
>> -           (define line
>> -             (read-line
>> -              (open-input-pipe
>> -               (string-append #$docker " load -i " #$tarball))))
>> -
>> -           (unless (or (eof-object? line)
>> -                       (string-null? line))
>> -             (format #t "~a~%" line)
>> -             (let ((repository&tag
>> -                    (string-drop line
>> -                                 (string-length
>> -                                   "Loaded image: "))))
>> -
>> -               (invoke #$docker "tag" repository&tag #$tag)
>> -               (format #t "Tagged ~a with ~a...~%" #$tarball #$tag))))))))
>> -
>> -(define (oci-container-shepherd-service config)
>> -  (define (guess-name name image)
>> -    (if (maybe-value-set? name)
>> -        name
>> -        (string-append "docker-"
>> -                       (basename
>> -                        (if (string? image)
>> -                            (first (string-split image #\:))
>> -                            (oci-image-repository image))))))
>> -
>> -  (let* ((docker (file-append docker-cli "/bin/docker"))
>> -         (actions (oci-container-configuration-shepherd-actions config))
>> +                        (ice-9 rdelim)
>> +                        (srfi srfi-1))
>> +           (define object-exists?
>> +             #$(oci-object-exists? runtime runtime-cli "image" verbose?))
>> +           (define load-command
>> +             (string-append #$runtime-cli
>> +                            " load -i " #$tarball))
>> +
>> +           (if (object-exists? #$tag #:format-string "{{.Repository}}:{{.Tag}}")
>> +               (format #t "~a image already exists, skipping.~%" #$tag)
>> +               (begin
>> +                 (format #t "Loading image for ~a from ~a...~%" #$name #$tarball)
>> +                 (when #$verbose?
>> +                   (format #t "Running ~a~%" load-command))
>> +                 (let ((line (read-line
>> +                              (open-input-pipe load-command))))
>> +                   (unless (or (eof-object? line)
>> +                               (string-null? line))
>> +                     (format #t "~a~%" line)
>> +                     (let* ((repository&tag
>> +                             (string-drop line
>> +                                          (string-length
>> +                                           "Loaded image: ")))
>> +                            (tag-command
>> +                             (list #$runtime-cli "tag" repository&tag #$tag))
>> +                            (drop-old-tag-command
>> +                             (list #$runtime-cli "image" "rm" "-f" repository&tag)))
>> +
>> +                       (unless (string=? repository&tag #$tag)
>> +                         (when #$verbose?
>> +                           (format #t "Running~{ ~a~}~%" tag-command))
>> +
>> +                         (let ((exit-code
>> +                                (status:exit-val (apply system* tag-command))))
>> +                           (format #t "Tagged ~a with ~a...~%" #$tarball #$tag)
>> +
>> +                           (when #$verbose?
>> +                             (format #t "Exit code: ~a~%" exit-code))
>> +
>> +                           (when (equal? EXIT_SUCCESS exit-code)
>> +                             (when #$verbose?
>> +                               (format #t "Running~{ ~a~}~%" drop-old-tag-command))
>> +                             (let ((drop-exit-code
>> +                                    (status:exit-val (apply system* drop-old-tag-command))))
>> +                               (when #$verbose?
>> +                                 (format #t "Exit code: ~a~%" drop-exit-code))))))))))))))))
>> +
>> +(define (oci-container-run-invocation runtime runtime-cli name command image-reference
>> +                                      options runtime-extra-arguments run-extra-arguments)
> That's a lot of arguments!  Perhaps it could accept a record instead?
> Please also mind the 80 chars max width.
Good idea, I made an intermediate oci-container-invocation record.
>> +  "Return a list representing the OCI runtime
>> +invocation for running containers."
>> +  ;; run [OPTIONS] IMAGE [COMMAND] [ARG...]
>> +  `(,runtime-cli ,@runtime-extra-arguments "run" "--rm"
>> +    ,@(if (eq? runtime 'podman)
>> +          ;; This is because podman takes some time to
>> +          ;; release container names.  --replace seems
>> +          ;; to be required to be able to restart services.
>> +          '("--replace")
>> +          '())
>> +    "--name" ,name
>> +    ,@options ,@run-extra-arguments
>> +    ,image-reference ,@command))
>> +
>> +(define* (oci-container-entrypoint runtime runtime-cli name image image-reference
>> +                                   invocation #:key (verbose? #f) (pre-script #~()))
> The default value for a keyword argument is #f, so I'd omit the explicit
> default for verbose?.
>> +              (begin
>> +                (when #$verbose?
>> +                  (format #t "Running~{ ~a~}~%" invocation))
>> +                (let ((exit-code (status:exit-val (apply system* invocation))))
>> +                  (when #$verbose?
>> +                    (format #t "Exit code: ~a~%" exit-code))))))
>> +        (list #$@invocations)))))
>> +
>> +(define* (oci-object-shepherd-service object runtime runtime-cli name requirement invocations
> Max width :-).

I should have dropped the default #f for keywords in all procedure, thanks.

>> +  "Return a file-like object that, once lowered, will evaluate to the entrypoint
>> +for the Shepherd service that will run IMAGE through RUNTIME-CLI."
>> +  (program-file
>> +   (string-append "oci-entrypoint-" name)
>> +   #~(begin
>> +       (use-modules (ice-9 format)
>> +                    (srfi srfi-1))
>> +       (when #$verbose?
>> +         (format #t "Running in verbose mode...~%")
>> +         (format #t "Current user: ~a ~a~%"
>> +                 (getuid) (passwd:name (getpwuid (getuid))))
>> +         (format #t "Current group: ~a ~a~%"
>> +                 (getgid) (group:name (getgrgid (getgid))))
>> +         (format #t "Current directory ~a~%" (getcwd)))
> I'd use a single format call; you can format the string naturally like
>
>              (format #t "\
> Running in verbose mode...
> Current user: ~a ~a
> ...
> " arg1 arg2, ...)
>
>
>> +       (define invocation (list #$@invocation))
>> +       #$@pre-script
>> +       (when #$verbose?
>> +         (format #t "Running~{ ~a~}~%" invocation))
>> +       (apply execlp `(,(first invocation) ,@invocation)))))
> You can more simply: (apply execlp (first invocation) invocation)
Thank you, I have addressed this in gnu/build/oci-containers.scm
>> +
>> +(define* (oci-container-shepherd-service runtime runtime-cli config
>> +                                         #:key
>> +                                         (runtime-environment #~())
>> +                                         (runtime-extra-arguments '())
>> +                                         (oci-requirement '())
>> +                                         (user #f)
>> +                                         (group #f)
>> +                                         (verbose? #f))
>> +  "Return a Shepherd service object that will run the OCI container represented
>> +by CONFIG through RUNTIME-CLI."
>> +  (let* ((actions (oci-container-configuration-shepherd-actions config))
>>            (auto-start?
>>             (oci-container-configuration-auto-start? config))
>> -         (user (oci-container-configuration-user config))
>> -         (group (oci-container-configuration-group config))
>> +         (maybe-user (oci-container-configuration-user config))
>> +         (maybe-group (oci-container-configuration-group config))
>> +         (user (if (maybe-value-set? maybe-user)
>> +                    maybe-user
>> +                    user))
>> +         (group (if (maybe-value-set? maybe-group)
>> +                    maybe-group
>> +                    group))
>>            (host-environment
>>             (oci-container-configuration-host-environment config))
>>            (command (oci-container-configuration-command config))
>>            (log-file (oci-container-configuration-log-file config))
>> -         (provision (oci-container-configuration-provision config))
>>            (requirement (oci-container-configuration-requirement config))
>>            (respawn?
>>             (oci-container-configuration-respawn? config))
>>            (image (oci-container-configuration-image config))
>>            (image-reference (oci-image-reference image))
>>            (options (oci-container-configuration->options config))
>> -         (name (guess-name provision image))
>> +         (name
>> +          (oci-container-shepherd-name runtime config))
>>            (extra-arguments
>> -          (oci-container-configuration-extra-arguments config)))
>> +          (oci-container-configuration-extra-arguments config))
>> +         (invocation
>> +          (oci-container-run-invocation
>> +           runtime runtime-cli name command image-reference
>> +           options runtime-extra-arguments extra-arguments))
>> +         (container-action
>> +          (lambda* (command #:key (environment-variables #f))
>> +            #~(lambda _
>> +                (fork+exec-command
>> +                 (list #$@command)
>> +                 #$@(if user (list #:user user) '())
>> +                 #$@(if group (list #:group group) '())
>> +                 #$@(if (maybe-value-set? log-file)
>> +                        (list #:log-file log-file)
>> +                        '())
>> +                 #$@(if (and user (eq? runtime 'podman))
>> +                        (list #:directory
>> +                              #~(passwd:dir (getpwnam #$user)))
>> +                        '())
>> +                 #$@(if environment-variables
>> +                        (list #:environment-variables
>> +                              environment-variables)
>> +                        '()))))))
> That's a very long let.  Since many values appear to simply be accessed
> from theh oci-container-configuration, match-record could be used to
> great effect.  For readability, I'd also define the action procedures
> using nested 'define' inside the let/match-record.
I tried to address this but it's really difficult to trim much, please 
let me know if there's some better way.
>> +(define (oci-service-subids config)
>> +  "Return a subids-extension record representing subuids and subgids required by
>> +the rootless Podman backend."
>> +  (define (delete-duplicate-ranges ranges)
>> +    (delete-duplicates ranges
>> +                       (lambda args
>> +                         (apply string=? (map subid-range-name ranges)))))
> I don't understand how the above 'delete-duplicate-ranges' procedure
> works; the 2nd argument of delete-duplicates is normally a predicate
> that accepts two values, but here it's a lambda that disregards the
> arguments: it seems it'd be wasteful to compute the same result over and
> over?
It is, I just replace this with a more descriptive error that allows the 
users to drop the duplicate without silently dropping a random one 
between the two.
>> +                          (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"))))
> Is there perhaps an easier way to check that the podman services were
> started successfully?  Perhaps using the podman command directly to
> query the state of the running containers?
>
> 'ls' is usually frowned for scripting; it's meant for interactive use.
> Perhaps you could use the shell wildcard feature or the find command
> instead?  I comment explaining what the above does/check exactly would
> be useful; it's not obvious.
I think this test can be dropped anyway since we later wait for Shepherd 
services to be started, it is a development leftover.
>> +             (let loop ((attempts 0))
>> +               (if (= attempts 60)
>> +                   (error "Services didn't come up after more than 60 seconds")
>> +                   (if (equal? '("cgroup" "cgroup")
>> +                               (run-test))
>> +                       #t
>> +                       (begin
>> +                         (sleep 1)
>> +                         (format #t "Services didn't come up yet, retrying with attempt ~a~%"
>> +                                 (+ 1 attempts))
>> +                         (loop (+ 1 attempts))))))))
> Note that we have a 'with-retries' definition in (gnu build
> jami-service) which could be used here;  perhaps it should be relocated
> elsewhere.

Thank you for the hint, I created gnu/build/utils.scm and tested my 
changes with:

guix shell -CPWN --writable-root nss-certs -m manifest.scm -- make 
check-system TESTS="pounce jami ngircd"

>> +                               (lambda (port)
>> +                                 (display (string-join response "\n") port)))))
>> +                         (lambda ()
>> +                           (primitive-exit 127))))
> The fork is used to be able to run the podman command with the right
> passwd and uid, right?  Maybe you could use the shepherd's provided
> 'command' or 'fork+exec-command', which have a nice API to do this.
> Also, is the dynamic-wind unnecessary?  I would have thought that if a
> forked children aborts, its exit status should be reflected accordingly?
You bring two good points, addressed by dropping dynamic-wind and 
refactoring duplicate code in tests.
> The idiom of forking ot invoke podman is used so commonly it should be
> extracted to a procedure or syntax and reused.
This should be addressed now.
> Phew, that was a large chunk!  I'll continue my review with the
> remaining commits, but when I'm done, could you please submit a v11,
> taking into account my comments?
Thank you a lot for taking the time to go through all of this, I hope I 
addressed all your comments successfully. Please let me know if 
something seems off.

I'll send a v11 soon.

cheers,

giacomo