@@ -23,11 +23,14 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services docker)
+ #:use-module (gnu image)
#:use-module (gnu services)
#:use-module (gnu services configuration)
#:use-module (gnu services base)
#:use-module (gnu services dbus)
#:use-module (gnu services shepherd)
+ #:use-module (gnu system)
+ #:use-module (gnu system image)
#:use-module (gnu system setuid)
#:use-module (gnu system shadow)
#:use-module (gnu packages admin) ;shadow
@@ -37,7 +40,11 @@ (define-module (gnu services docker)
#:use-module (guix diagnostics)
#:use-module (guix gexp)
#:use-module (guix i18n)
+ #:use-module (guix monads)
#:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module ((guix scripts pack) #:prefix pack:)
+ #:use-module (guix store)
#:use-module (srfi srfi-1)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
@@ -45,6 +52,16 @@ (define-module (gnu services docker)
#:export (docker-configuration
docker-service-type
singularity-service-type
+ oci-image
+ oci-image?
+ oci-image-fields
+ oci-image-repository
+ oci-image-tag
+ oci-image-value
+ oci-image-pack-options
+ oci-image-target
+ oci-image-system
+ oci-image-grafts?
oci-container-configuration
oci-container-configuration?
oci-container-configuration-fields
@@ -52,9 +69,11 @@ (define-module (gnu services docker)
oci-container-configuration-group
oci-container-configuration-command
oci-container-configuration-entrypoint
+ oci-container-configuration-host-environment
oci-container-configuration-environment
oci-container-configuration-image
oci-container-configuration-provision
+ oci-container-configuration-requirement
oci-container-configuration-network
oci-container-configuration-ports
oci-container-configuration-volumes
@@ -62,7 +81,8 @@ (define-module (gnu services docker)
oci-container-configuration-workdir
oci-container-configuration-extra-arguments
oci-container-service-type
- oci-container-shepherd-service))
+ oci-container-shepherd-service
+ %oci-container-accounts))
(define-maybe file-like)
@@ -320,11 +340,68 @@ (define (valid? member)
but ~a was found") el))))
value))
+(define (oci-image-reference image)
+ (if (string? image)
+ image
+ (string-append (oci-image-repository image)
+ ":" (oci-image-tag image))))
+
+(define (oci-lowerable-image? image)
+ (or (manifest? image)
+ (operating-system? image)
+ (gexp? image)
+ (file-like? image)))
+
+(define (string-or-oci-image? image)
+ (or (string? image)
+ (oci-image? image)))
+
(define list-of-symbols?
(list-of symbol?))
(define-maybe/no-serialization string)
+(define-configuration/no-serialization oci-image
+ (repository
+ (string)
+ "A string like @code{myregistry.local:5000/testing/test-image} that names
+the OCI image.")
+ (tag
+ (string "latest")
+ "A string representing the OCI image tag. Defaults to @code{latest}.")
+ (value
+ (oci-lowerable-image)
+ "A @code{manifest} or @code{operating-system} record that will be lowered
+into an OCI compatible tarball. Otherwise this field's value can be a gexp
+or a file-like object that evaluates to an OCI compatible tarball.")
+ (pack-options
+ (list '())
+ "An optional set of keyword arguments that will be passed to the
+@code{docker-image} procedure from @code{guix scripts pack}. They can be used
+to replicate @command{guix pack} behavior:
+
+@lisp
+(oci-image
+ (repository \"guile\")
+ (tag \"3\")
+ (manifest (specifications->manifest '(\"guile\")))
+ (pack-options
+ '(#:symlinks ((\"/bin/guile\" -> \"bin/guile\"))
+ #:max-layers 2)))
+@end lisp
+
+If the @code{value} field is an @code{operating-system} record, this field's
+value will be ignored.")
+ (system
+ (maybe-string)
+ "Attempt to build for a given system, e.g. \"i686-linux\"")
+ (target
+ (maybe-string)
+ "Attempt to cross-build for a given triple, e.g. \"aarch64-linux-gnu\"")
+ (grafts?
+ (boolean #f)
+ "Whether to allow grafting or not in the pack build."))
+
(define-configuration/no-serialization oci-container-configuration
(user
(string "oci-container")
@@ -372,8 +449,9 @@ (define-configuration/no-serialization oci-container-configuration
documentation for semantics."
(sanitizer oci-sanitize-environment))
(image
- (string)
- "The image used to build the container. Images are resolved by the Docker
+ (string-or-oci-image)
+ "The image used to build the container. It can be a string or an
+@code{oci-image} record. Strings are resolved by the Docker
Engine, and follow the usual format
@code{myregistry.local:5000/testing/test-image:tag}.")
(provision
@@ -470,14 +548,122 @@ (define oci-container-configuration->options
(list "-v" spec))
(oci-container-configuration-volumes config))))))))
+(define* (get-keyword-value args keyword #:key (default #f))
+ (let ((kv (memq keyword args)))
+ (if (and kv (>= (length kv) 2))
+ (cadr kv)
+ default)))
+
+(define (lower-operating-system os target system)
+ (mlet* %store-monad
+ ((tarball
+ (lower-object
+ (system-image (os->image os #:type docker-image-type))
+ system
+ #:target target)))
+ (return tarball)))
+
+(define (lower-manifest name image target system)
+ (define value (oci-image-value image))
+ (define options (oci-image-pack-options image))
+ (define image-reference
+ (oci-image-reference image))
+ (define image-tag
+ (let* ((extra-options
+ (get-keyword-value options #:extra-options))
+ (image-tag-option
+ (and extra-options
+ (get-keyword-value extra-options #:image-tag))))
+ (if image-tag-option
+ '()
+ `(#:extra-options (#:image-tag ,image-reference)))))
+
+ (mlet* %store-monad
+ ((_ (set-grafting
+ (oci-image-grafts? image)))
+ (guile (set-guile-for-build (default-guile)))
+ (profile
+ (profile-derivation value
+ #:target target
+ #:system system
+ #:hooks '()
+ #:locales? #f))
+ (tarball (apply pack:docker-image
+ `(,name ,profile
+ ,@options
+ ,@image-tag
+ #:localstatedir? #t))))
+ (return tarball)))
+
+(define (lower-oci-image name image)
+ (define value (oci-image-value image))
+ (define image-target (oci-image-target image))
+ (define image-system (oci-image-system image))
+ (define target
+ (if (maybe-value-set? image-target)
+ image-target
+ (%current-target-system)))
+ (define system
+ (if (maybe-value-set? image-system)
+ image-system
+ (%current-system)))
+ (with-store store
+ (run-with-store store
+ (match value
+ ((? manifest? value)
+ (lower-manifest name image target system))
+ ((? operating-system? value)
+ (lower-operating-system value target system))
+ ((or (? gexp? value)
+ (? file-like? value))
+ value)
+ (_
+ (raise
+ (formatted-message
+ (G_ "oci-image value must contain only manifest,
+operating-system, gexp or file-like records but ~a was found")
+ value))))
+ #:target target
+ #:system system)))
+
+(define (%oci-image-loader name image tag)
+ (let ((docker (file-append docker-cli "/bin/docker"))
+ (tarball (lower-oci-image name image)))
+ (with-imported-modules '((guix build utils))
+ (program-file (format #f "~a-image-loader" name)
+ #~(begin
+ (use-modules (guix build utils)
+ (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 (car (string-split image #\:))))))
+ (basename
+ (if (string? image)
+ (first (string-split image #\:))
+ (oci-image-repository image))))))
- (let* ((docker-command (file-append docker-cli "/bin/docker"))
+ (let* ((docker (file-append docker-cli "/bin/docker"))
(user (oci-container-configuration-user config))
(group (oci-container-configuration-group config))
(host-environment
@@ -486,6 +672,7 @@ (define (guess-name name image)
(provision (oci-container-configuration-provision config))
(requirement (oci-container-configuration-requirement config))
(image (oci-container-configuration-image config))
+ (image-reference (oci-image-reference image))
(options (oci-container-configuration->options config))
(name (guess-name provision image))
(extra-arguments
@@ -496,30 +683,37 @@ (define (guess-name name image)
(respawn? #f)
(documentation
(string-append
- "Docker backed Shepherd service for image: " image))
+ "Docker backed Shepherd service for "
+ (if (oci-image? image) name image) "."))
(start
- #~(make-forkexec-constructor
- ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
- (list #$docker-command "run" "--rm"
- "--name" #$name
- #$@options #$@extra-arguments #$image #$@command)
- #:user #$user
- #:group #$group
- #:environment-variables
- (list #$@host-environment)))
+ #~(lambda ()
+ (when #$(oci-image? image)
+ (invoke #$(%oci-image-loader
+ name image image-reference)))
+ (fork+exec-command
+ ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+ (list #$docker "run" "--rm" "--name" #$name
+ #$@options #$@extra-arguments
+ #$image-reference #$@command)
+ #:user #$user
+ #:group #$group
+ #:environment-variables
+ (list #$@host-environment))))
(stop
#~(lambda _
- (invoke #$docker-command "rm" "-f" #$name)))
+ (invoke #$docker "rm" "-f" #$name)))
(actions
- (list
- (shepherd-action
- (name 'pull)
- (documentation
- (format #f "Pull ~a's image (~a)."
- name image))
- (procedure
- #~(lambda _
- (invoke #$docker-command "pull" #$image)))))))))
+ (if (oci-image? image)
+ '()
+ (list
+ (shepherd-action
+ (name 'pull)
+ (documentation
+ (format #f "Pull ~a's image (~a)."
+ name image))
+ (procedure
+ #~(lambda _
+ (invoke #$docker "pull" #$image))))))))))
(define %oci-container-accounts
(list (user-account