1 files changed, 210 insertions, 0 deletions

diff --git a/gnu/build/oci-containers.scm b/gnu/build/oci-containers.scm
new file mode 100644
index 00000000000..38704e9e4a4
--- /dev/null
+++ b/gnu/build/oci-containers.scm
@@ -0,0 +1,210 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2025 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/>.
+
+;;; Commentary:
+;;;
+;;; This module contains helpers used as part of the oci-service-type
+;;; definition.
+;;;
+;;; Code:
+
+(define-module (gnu build oci-containers)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (srfi srfi-1)
+  #:export (oci-read-lines
+            oci-system*
+            oci-object-exists?
+            oci-object-service-available?
+            oci-image-load
+            oci-log-verbose
+            oci-container-execlp
+            oci-object-create))
+
+(define* (oci-read-lines invocation #:key verbose?)
+  (define (get-lines port)
+    (let ((lines-string (get-string-all port)))
+      (string-split lines-string #\newline)))
+
+  (define command
+   (string-join invocation " "))
+
+  (when verbose? (format #t "Running ~a~%" command))
+
+  (with-input-from-port (open-input-pipe command)
+    (lambda _
+      (get-lines (current-input-port)))))
+
+(define* (oci-log-verbose invocation)
+  (format #t "Running in verbose mode...
+Current user: ~a ~a
+Current group: ~a ~a
+Current directory: ~a~%"
+          (getuid) (passwd:name (getpwuid (getuid)))
+          (getgid) (group:name (getgrgid (getgid)))
+          (getcwd))
+
+  (format #t "Running~{ ~a~}~%" invocation))
+
+(define* (oci-system* invocation #:key verbose?)
+  (when verbose?
+    (format #t "Running~{ ~a~}~%" invocation))
+
+  (let* ((status (apply system* invocation))
+         (exit-code (status:exit-val status)))
+    (when verbose?
+      (format #t "Exit code: ~a~%" exit-code))
+    status))
+
+(define* (oci-object-member name objects
+                            #:key verbose?)
+
+  (define member? (member name objects))
+
+  (when (and verbose? (> (length objects) 0))
+    (format #t "~a is ~apart of:~{ ~a~}~%"
+            name
+            (if member? "" "not ")
+            objects))
+  member?)
+
+(define* (oci-object-list runtime-cli object
+                          #:key verbose?
+                          (format-string "{{.Name}}"))
+
+  (define invocation
+    (list runtime-cli object "ls" "--format"
+          (string-append "\"" format-string "\"")))
+
+  (filter
+   (lambda (name)
+     (not (string=? (string-trim name) "")))
+   (oci-read-lines invocation #:verbose? verbose?)))
+
+(define* (docker-object-exist? runtime-cli object name
+                               #:key verbose?
+                               (format-string "{{.Name}}"))
+
+  (define objects
+    (oci-object-list runtime-cli object
+                     #:verbose? verbose?
+                     #:format-string format-string))
+
+  (oci-object-member name objects #:verbose? verbose?))
+
+(define* (podman-object-exist? runtime-cli object name #:key verbose?)
+  (let ((invocation (list runtime-cli object "exists" name)))
+    (define exit-code
+      (status:exit-val (oci-system* invocation #:verbose? verbose?)))
+    (equal? EXIT_SUCCESS exit-code)))
+
+(define* (oci-object-exists? runtime runtime-cli object name
+                             #:key verbose?
+                             (format-string "{{.Name}}"))
+  (if (eq? runtime 'podman)
+      (podman-object-exist? runtime-cli object name
+                            #:verbose? verbose?)
+      (docker-object-exist? runtime-cli object name
+                            #:verbose? verbose?
+                            #:format-string format-string)))
+
+(define* (oci-object-service-available? runtime-cli object names
+                                        #:key verbose?
+                                        (format-string "{{.Name}}"))
+  "Whether NAMES are provisioned in the current OBJECT environment."
+  (define environment
+    (oci-object-list runtime-cli object
+                     #:verbose? verbose?
+                     #:format-string format-string))
+  (when verbose?
+    (format #t "~a environment:~{ ~a~}~%" object environment))
+
+  (define available?
+    (every
+     (lambda (name)
+       (oci-object-member name environment #:verbose? verbose?))
+     names))
+
+  (when verbose?
+   (format #t "~a service is~a available~%" object (if available? "" " not")))
+
+  available?)
+
+(define* (oci-image-load runtime runtime-cli tarball name tag
+                         #:key verbose?
+                         (format-string "{{.Repository}}:{{.Tag}}"))
+  (define load-invocation
+    (list runtime-cli "load" "-i" tarball))
+
+  (if (oci-object-exists? runtime runtime-cli "image" tag
+                          #:verbose? verbose?
+                          #:format-string format-string)
+      (format #t "~a image already exists, skipping.~%" tag)
+      (begin
+        (format #t "Loading image for ~a from ~a...~%" name tarball)
+
+        (let ((line (first
+                     (oci-read-lines load-invocation #:verbose? verbose?))))
+          (unless (or (eof-object? line)
+                      (string-null? line))
+
+            (format #t "~a~%" line)
+
+            (let* ((repository&tag
+                    (string-drop line
+                                 (string-length
+                                  "Loaded image: ")))
+                   (tag-invocation
+                    (list runtime-cli "tag" repository&tag tag))
+                   (drop-old-tag-invocation
+                    (list runtime-cli "image" "rm" "-f" repository&tag)))
+
+              (unless (string=? repository&tag tag)
+                (let ((exit-code
+                       (status:exit-val
+                        (oci-system* tag-invocation #:verbose? verbose?))))
+                  (format #t "Tagged ~a with ~a...~%" tarball tag)
+
+                  (when (equal? EXIT_SUCCESS exit-code)
+                    (oci-system* drop-old-tag-invocation #:verbose? verbose?))))))))))
+
+(define* (oci-container-execlp invocation #:key verbose? pre-script)
+  (when pre-script
+    (pre-script))
+  (when verbose?
+    (oci-log-verbose invocation))
+  (apply execlp (first invocation) invocation))
+
+(define* (oci-object-create runtime runtime-cli runtime-name
+                            object
+                            invocations
+                            #:key verbose?
+                            (format-string "{{.Name}}"))
+  (for-each
+   (lambda (invocation)
+     (define name (last invocation))
+     (if (oci-object-exists? runtime runtime-cli object name
+                             #:format-string format-string
+                             #:verbose? verbose?)
+         (format #t "~a ~a ~a already exists, skipping creation.~%"
+                 runtime-name name object)
+         (oci-system* invocation #:verbose? verbose?)))
+   invocations))