From d21b95cb59ed9d2b281741940190fb9a450e138b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Le=20Barbier?= Date: Mon, 22 Apr 2024 23:09:44 +0200 Subject: [PATCH] Implement DOCKER-IMAGE resource --- TODO.org | 38 ++++ src/package.lisp | 2 + src/stewards/docker-engine.lisp | 312 ++++++++++++++++++++++++++++++-- src/utilities.lisp | 50 +++++ 4 files changed, 391 insertions(+), 11 deletions(-) create mode 100644 TODO.org diff --git a/TODO.org b/TODO.org new file mode 100644 index 0000000..25e24e3 --- /dev/null +++ b/TODO.org @@ -0,0 +1,38 @@ +* Stewards must have a PROBE-RESOURCE method +It seems useful for a steward to feature a PROBE-RESOURCE which +returns a property list. This PROBE-RESOURCE method can be used to +detect if a resource no longer exists and can be used by the +UPDATE-INSTANCE-FROM-RESOURCE methods, so that updating instances can +be implemented generically. + +* Resources do not need a NAME nor a DISPLAYNAME +It does not seem useful for resources to have a mandatory NAME. A NAME +or a DESIGNATOR could be useful when describing a software stack but +requiring them prevents the IMPORT-RESOURCE to work properly. Hence +resource DESIGNATORS seem to be indpendant from the resource themselve +but are probably attached to the software stack themselve. + +* Steward must be aware if resource namespace is global or scoped to a project +Some stewards create resources identified by a name provided by the +user. The steward must be aware if the resource namespace is global or +is scoped to a tenant/project. + +* Resource identifiers are sometimes only known after creating the resource + +* Resource identifiers and state should be initialised via initargs +When we import a resource, we know the state and the identifier of the +resource so that constructors should be able to set these values +directly. + +* Resources must expose a predicate telling if it can be built or not +* Resources must expose a predicate telling it they can be modified or not +* Resources must expose a predicate telling it they can be deleted or not + +* Support persistance of BUILD-TIME-VARIABLES in DOCKER-IMAGE + +* Support FIND-RESOURCE STEWARD RESOURCE-TYPE FILTERS + +* Implement a DOCKER-IMAGE-BLUEPRINT +The docker image blueprint contains all the details about building +a docker image, so that the details are capsulated away from the +DOCKER-IMAGE itself. diff --git a/src/package.lisp b/src/package.lisp index db95b73..4ec6987 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -81,6 +81,8 @@ #:make-docker-engine #:docker-volume #:make-docker-volume + #:docker-image + #:make-docker-image )) (in-package #:org.melusina.cid) diff --git a/src/stewards/docker-engine.lisp b/src/stewards/docker-engine.lisp index 918f1a3..12f710f 100644 --- a/src/stewards/docker-engine.lisp +++ b/src/stewards/docker-engine.lisp @@ -75,10 +75,15 @@ the `docker' CLI client.")) :error-output :lines)) (defun run-docker-engine-command (docker-engine &rest argv) - (uiop:run-program - (cons (namestring (slot-value docker-engine 'pathname)) argv) - :output '(:string :stripped t) - :error-output :lines)) + (flet ((accept-lists-in-argv () + (setf argv + (loop :for arg :in argv + :append (alexandria:ensure-list arg))))) + (accept-lists-in-argv) + (uiop:run-program + (cons (namestring (slot-value docker-engine 'pathname)) argv) + :output '(:string :stripped t) + :error-output :lines))) (defun docker-version (docker-engine) (flet ((version (line) @@ -142,14 +147,18 @@ the `docker' CLI client.")) :driver driver))) (defun probe-docker-volume (steward volume) - (flet ((make-properties (text) - (ppcre:register-groups-bind (volume driver) ("(.*)\\|(.*)" text) - (list - :volume volume - :driver driver))) + (flet ((extract-json-fields (text) + (extract-json-fields + text + '((:property :volume + :name "Name" + :type string) + (:property :driver + :name "Driver" + :type string)))) (inspect-volume () - (run-docker-engine-command steward "volume" "inspect" volume "--format" "{{.Name}}|{{.Driver}}"))) - (handler-case (make-properties (inspect-volume)) + (run-docker-engine-command steward "volume" "inspect" volume "--format" "{{json .}}"))) + (handler-case (extract-json-fields (inspect-volume)) (uiop/run-program:subprocess-error (condition) (declare (ignore condition)) (values nil))))) @@ -241,4 +250,285 @@ therefore the docker volume ~A with the same name cannot be created." volume ins (delete-volume) (update-state-and-identifier))) + +;;;; +;;;; Docker Image +;;;; + +(clsql:def-view-class docker-image (resource) + ((steward-class + :db-kind :virtual + :type symbol + :initform 'docker-engine + :allocation :class) + (id + :initarg :id + :initarg nil + :type string + :reader image-id) + (repository + :initarg :repository + :initarg nil + :type string + :reader image-repository) + (tag + :initarg :tag + :initform "latest" + :type string + :reader image-tag) + (size + :initarg :size + :type string + :reader image-size) + (created-at + :initarg :created-at + :type string + :initform nil + :reader image-created-at) + (dockerfile + :initarg :dockerfile + :type pathname + :initform nil) + (context + :initarg :context + :type pathname + :initform nil) + (cache + :initarg :cache + :type boolean + :initform t) + (build-time-variables + :db-type :virtual + :initarg :build-time-variables + :initform nil))) + +(defun make-docker-image (&rest initargs &key docker-engine name displayname description + id repository tag size created-at + dockerfile context cache + build-time-variables) + "Make a docker image" + (declare (ignore name displayname description id repository tag size created-at + dockerfile context cache build-time-variables)) + (check-type docker-engine docker-engine) + (apply #'make-instance 'docker-image + :steward docker-engine + (remove-property initargs :docker-engine))) + +(defmethod print-object ((instance docker-image) stream) + (print-unreadable-object (instance stream :type t :identity t) + (with-slots (id repository tag size created-at) instance + (format stream + "~@[:REPOSITORY ~S ~]~@[:TAG ~S ~]:ID ~S :SIZE ~S :CREATED-AT ~S" + repository tag id size created-at)))) + +(defun probe-docker-image (steward id) + (flet ((extract-json-fields (text) + (flet ((extract-repository (repo-tags) + (when repo-tags + (subseq (first repo-tags) 0 (position #\: (first repo-tags))))) + (extract-tag (repo-tags) + (when repo-tags + (subseq (first repo-tags) (1+ (position #\: (first repo-tags))))))) + (extract-json-fields + text + `((:property :id + :name "Id" + :type string) + (:property :repository + :name "RepoTags" + :type (list string) + :key ,#'extract-repository) + (:property :tag + :name "RepoTags" + :type (list string) + :key ,#'extract-tag) + (:property :size + :name "Size" + :type integer) + (:property :created + :name "Created" + :type string))))) + (inspect-image () + (run-docker-engine-command steward "image" "inspect" id "--format" "{{json .}}"))) + (handler-case (extract-json-fields (inspect-image)) + (uiop/run-program:subprocess-error (condition) + (declare (ignore condition)) + (values nil))))) + +(defun image-name (image) + (with-slots (repository tag) image + (when (and repository tag) + (concatenate 'string repository '(#\:) tag)))) + +(defun image-short-id (image) + (with-slots (id) image + (when id + (let ((start + (1+ (position #\: id))) + (length + 12)) + (subseq id start (+ start length)))))) + +(defmethod list-resource-identifiers ((steward docker-engine) (resource-class (eql 'docker-image))) + (flet ((unique-identifiers (list) + (remove-duplicates list :test #'string=))) + (unique-identifiers (run-docker-engine-query steward "image" "list""--no-trunc" "--format" "{{.ID}}")))) + +(defmethod list-resources ((steward docker-engine) (resource-class (eql 'docker-image))) + (flet ((docker-image-of-json (text) + (apply + #'make-docker-image + :docker-engine steward + :name "docker-image-name" + :displayname "Docker Image Name" + :description "A docker image." + (extract-json-fields + text + '((:property :id + :key "ID" + :type string) + (:property :repository + :key "Repository" + :type (or string null)) + (:property :tag + :key "Tag" + :type (or string null)) + (:property :size + :key "Size" + :type string) + (:property :created-at + :key "CreatedAt" + :type string))))) + (update-state-and-identifier (instance) + (with-slots (id identifier state) instance + (setf state t + identifier id)) + (values instance)) + (list-docker-images () + (run-docker-engine-query steward "image" "list" "--no-trunc" "--format" "{{json .}}"))) + (loop :for line :in (list-docker-images) + :while line + :collect (update-state-and-identifier (docker-image-of-json line))))) + +(defmethod update-instance-from-resource ((instance docker-image)) + (flet ((ensure-id-is-set-when-identifier-is-set () + (when (and (slot-boundp instance 'identifier) + (slot-value instance 'identifier) + (not (slot-boundp instance 'id))) + (setf (slot-value instance 'id) + (slot-value instance 'identifier)))) + (update-instance (properties) + (unless properties + (resource-no-longer-exists + 'update-instance-from-resource instance + "Docker image no longer exists.")) + (with-slots (state id repository tag size created-at) instance + (setf id (getf properties :id) + repository (getf properties :repository) + tag (getf properties :tag) + size (getf properties :size) + created-at (getf properties :created-at) + state t)))) + (ensure-id-is-set-when-identifier-is-set) + (with-slots (steward id) instance + (update-instance (probe-docker-image steward id))))) + +(defmethod create-resource ((instance docker-image)) + (flet ((return-early-when-image-already-exists (instance) + (with-slots (steward id) instance + (when (probe-docker-image steward id) + (resource-error 'create-resource instance + "Docker image already exists." + "There is already an existing docker image under the name ~S +therefore the docker image ~A with the same name cannot be created." (image-name instance) instance)))) + (create-docker-image () + (with-slots (steward dockerfile context cache build-time-variables) instance + (run-docker-engine-command steward + "build" "--progress=plain" + (unless cache + (list "--no-cache")) + (when build-time-variables + (loop :for (name . value) :in build-time-variables + :append (list "--build-arg" (concatenate 'string name "=" value)))) + "--file" (namestring dockerfile) + "--tag" (image-name instance) + (namestring context)))) + (update-identifier-and-state () + (with-slots (steward identifier state) instance + (let ((properties + (probe-docker-image steward (image-name instance)))) + (setf identifier (getf properties :id) + state t))))) + (return-early-when-image-already-exists instance) + (create-docker-image) + (update-identifier-and-state) + (update-instance-from-resource instance))) + +(defmethod delete-resource ((instance docker-image)) + (flet ((ensure-that-resource-still-exists () + (with-slots (steward identifier) instance + (unless (probe-docker-image steward identifier) + (resource-no-longer-exists + 'delete-resource instance + "Docker image no longer exists.")))) + (delete-image () + (with-slots (steward identifier) instance + (let ((deleted-image + (run-docker-engine-command steward "image" "rm" (image-name instance)))) + (flet ((compare-event (slot-reader regex) + (ppcre:register-groups-bind (value) (regex deleted-image) + (unless (string= value (funcall slot-reader instance)) + (resource-error 'delete-resource instance + "Docker image cannot be deleted." + "Cannot delete docker image ~A" (image-name instance)))))) + (compare-event #'image-name "Untagged: (.*)") + (compare-event #'image-id "Deleted: (.*)"))))) + (update-state-and-identifier () + (with-slots (identifier state) instance + (setf state nil + identifier nil)))) + (ensure-that-resource-still-exists) + (delete-image) + (update-state-and-identifier))) + +#| +(defun reclaim-images () + "Reclaim docker images which are no longer in use." + (flet ((has-no-name-p (image) + (not (image-name image))) + (testsuite-p (image) + (uiop:string-prefix-p "testsuite" (image-tag image)))) + (mapcar #'delete-image + (loop :for image :in (list-images) + :when (or + (testsuite-p image) + (has-no-name-p image)) + :collect image)))) +|# + + +#| +(defun find-image (designator) + "Find image designated by DESIGNATOR." + (typecase designator + (image + designator) + (string + (or + (find designator (list-images) + :key #'image-name + :test #'string=) + (when (= 12 (length designator)) + (find designator (list-images) + :key #'image-short-id + :test #'string=)) + (when (position #\: designator) + (find designator (list-images) + :key #'image-id + :test #'string=)) + (find (concatenate 'string "sha256:" designator) (list-images) + :key #'image-id + :test #'string=))))) +|# + ;;;; End of file `docker-engine.lisp' diff --git a/src/utilities.lisp b/src/utilities.lisp index 2faf3d6..e097250 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -107,4 +107,54 @@ (unless (portable-filename-character-set-p string) (error "The string ~A does not consist of characters form the portable set." string))) + +;;;; +;;;; Extract JSON Fields +;;;; + +(defun extract-json-fields (string fields) + "Extract FIELDS from TEXT and return them in a property list. +The items of the FIELDS specification describe how to extract fields +from the text. Each item in the FIELDS specification is a property +list with the following entries: + + :NAME STRING + The NAME of the object field where the value is stored. + :TYPE SYMBOL + The TYPE of the value. This is one of + 'INTEGER, 'STRING, '(OR STRING NULL), '(LIST STRING) + :PROPERTY KEYWORD + The name of the PROPERTY where the value is to be stored. + :KEY FUNCTION + A function to apply on the field value. +" + (flet ((extract-json-field (object &key name type property (key 'identity)) + (flet ((fetch () + (multiple-value-bind (value present-p) (gethash name object) + (unless present-p + (error "Cannot read field ~A from JSON text." name)) + (alexandria:switch (type :test #'equal) + ('integer + (check-type value integer) + (values value)) + ('string + (string value)) + ('(or string null) + (unless (string= "" value) + (string value))) + ('(list string) + (loop :for item :in value + :collect (string item))) + (t + (error "Cannot extact field of type ~A from JSON text." type))))) + (extract (text) + (when text + (funcall key text))) + (pack (value) + (list property value))) + (pack (extract (fetch)))))) + (loop :with object = (yason:parse string) + :for field :in fields + :nconc (apply #'extract-json-field object field)))) + ;;;; End of file `utilities.lisp'