Implement Keycloak Client resources

libexec/lisp/operation.lisp

@@ -716,7 +716,7 @@ This is not to be confused with SAVE-PROJECT."
 (defun list-trac-environments (&optional (project *project*))
   "List trac environments."
   (flet ((reserved-name-p (string)
-	   (position string '("git" "www" "sites") :test #'string=))
+	   (position string '("ssl" "git" "www" "sites") :test #'string=))
 	 (list-trac-directory ()
 	   (run-console-program
 	    (list "/bin/ls" "/var/trac")

org.melusina.cid.asd

@@ -20,7 +20,8 @@
 	       #:drakma
 	       #:flexi-streams
 	       #:ironclad
-	       #:yason)
+	       #:yason
+	       #:uuid)
   :components
   ((:module "src"
     :components ((:file "package")

src/package.lisp

@@ -71,6 +71,7 @@
    #:resource-slot-is-immutable
    #:resource-confirmation
    #:with-resource-confirmation
+   #:resource-parent
    #:resource-exists-p
    #:resource-ready-p
    #:resource-external-p
@@ -125,6 +126,8 @@
    #:get-keycloak-admin-token
    #:keycloak-realm
    #:make-keycloak-realm
+   #:keycloak-client
+   #:make-keycloak-client
    #:realm
    #:displayname
    #:displayname-html

src/poc.lisp

@@ -165,14 +165,14 @@
 
 (defun make-subject-certificate (&rest initargs
 				 &key name displayname
-				      description state identifier external
+				      description state identifier parent external
 				      certificate-authority
 				      public-key
 				      not-valid-before not-valid-after
 				      common-name)
   "Make a SUBJECT-CERTIFICATE with the given parameters."
   (declare (ignore name displayname
-		   description state identifier external
+		   description state identifier parent external
 		   public-key
 		   not-valid-before not-valid-after
 		   common-name))
@@ -287,10 +287,10 @@ This sets *TENANT* and *PROJECT* to work on the POC."
   (:documentation "This class represents a private network."))
 
 (defun make-private-network (&rest initargs &key cloud-vendor name displayname
-						 description state identifier external
+						 description state identifier parent external
 						 availability-zone)
   "Make a PRIVATE-NETWORK."
-  (declare (ignore name displayname description state identifier external
+  (declare (ignore name displayname description state identifier parent external
 		   availability-zone))
   (apply #'make-instance 'private-network
 	 :steward cloud-vendor
@@ -326,10 +326,10 @@ This sets *TENANT* and *PROJECT* to work on the POC."
 
 (defun make-container-image (&rest initargs &key cloud-vendor
 						 name displayname
-						 description state identifier external
+						 description state identifier parent external
 						 repository tag)
   "Make a CONTAINER-IMAGE."
-  (declare (ignore name displayname description state identifier external repository tag))
+  (declare (ignore name displayname description state identifier parent external repository tag))
   (apply #'make-instance 'container-image
 	 :steward cloud-vendor
 	 (remove-property initargs :cloud-vendor)))
@@ -359,9 +359,9 @@ This sets *TENANT* and *PROJECT* to work on the POC."
 
 (defun make-container-image-registry (&rest initargs &key cloud-vendor
 							  name displayname
-							  description state identifier external)
+							  description state identifier parent external)
   "Make a CONTAINER-IMAGE-REGISTRY."
-  (declare (ignore name displayname description state identifier external))
+  (declare (ignore name displayname description state identifier parent external))
   (apply #'make-instance 'container-image-registry
 	 :steward cloud-vendor
 	 (remove-property initargs :cloud-vendor)))
@@ -401,11 +401,11 @@ a cluster from one private network to the other and this slot is immutable."))
 
 (defun make-container-cluster (&rest initargs &key cloud-vendor
 						   name displayname
-						   description state identifier external
+						   description state identifier parent external
 						   private-network)
   "Make a CONTAINER-CLUSTER."
   (declare (ignore name displayname
-		   description state identifier external
+		   description state identifier parent external
 		   private-network))
   (apply #'make-instance 'container-cluster
 	 :steward cloud-vendor
@@ -455,12 +455,12 @@ Allowed values are one of :HTTP, :HTTPS, :TCP.")
 (defun make-container-service (&rest initargs
 			       &key cloud-vendor
 				    name displayname
-				    description state identifier external
+				    description state identifier parent external
 				    cluster image protocol port)
   "Make a CONTAINER-SERVICE."
   (declare (ignore
 	    name displayname
-	    description state identifier external
+	    description state identifier parent external
 	    cluster image protocol port))
   (apply #'make-instance 'container-service
 	 :steward cloud-vendor
@@ -505,10 +505,10 @@ Allowed values are one of :HTTP, :HTTPS, :TCP.")
 (defun make-public-load-balancer (&rest initargs
 				  &key cloud-vendor
 				       name displayname
-				       description state identifier external
+				       description state identifier parent external
 				       private-network services)
   "Make a CLOUD-PUBLIC-LOADBALANCER."
-  (declare (ignore name displayname description state identifier external private-network services))
+  (declare (ignore name displayname description state identifier parent external private-network services))
   (apply #'make-instance 'public-load-balancer
 	 :steward cloud-vendor
 	 (remove-property initargs :cloud-vendor)))

src/resource.lisp

@@ -62,6 +62,12 @@ T meaning the resource exists and is ready or some resource lifecycle specific k
 Depending on the RESOURCE and the STEWARD, the identifier can be or not be
 a deterministic function of other resource properties. If and only if
 the underlying resource has not been created, the IDENTIFIER is NIL.")
+   (parent
+    :initarg :parent
+    :reader resource-parent
+    :initform nil
+    :documentation
+    "A parent resource.")
    (external
     :type boolean
     :initarg :external
@@ -104,7 +110,9 @@ resources. For a given STEWARD, any resource is uniquely identified by its IDENT
     (:initarg :state
      :slot-name state)
     (:initarg :identifier
-     :slot-name identifier)))
+     :slot-name identifier)
+    (:initarg :parent
+     :slot-name parent)))
 
 (defmethod print-object ((instance resource) stream)
   (flet ((print-readably ()
@@ -167,19 +175,25 @@ the resource, so that it is usually unsafe to publish this EXPLANATION."))
 
 (defun describe-resource-error (condition stream)
   (with-slots (name displayname steward) (resource-error-resource condition)
-    (let ((*print-circle* nil))
-      (format stream "~&Operation on resource ~A failed.
-
-The steward ~A trying to ~A the resource ~A met an error condition.
-~A" 
-	      (or displayname name (resource-error-resource condition))
+    (let ((*print-circle*
+	    nil)
+	  (effective-displayname
+	    (or displayname name (resource-error-resource condition))))
+      (format stream "~A" (resource-error-description condition))
+      (start-new-paragraph stream)
+      (format stream "~@<The steward ~A trying to ~A the resource ~A met an error condition.~:@>"
 	      (slot-value steward 'name)
-	      (resource-error-operation condition)
-	      (or displayname name (resource-error-resource condition))
-	      (resource-error-description condition))
+	      (case (resource-error-operation condition)
+		(create-resource "create")
+		(delete-resource "delete")
+		(import-resource "import")
+		(t
+		 (resource-error-operation condition)))
+	      effective-displayname)
       (with-slots (explanation) condition
 	(when explanation
-	  (format stream "~&~A" explanation))))))
+	  (start-new-paragraph stream)
+ 	  (format stream "~A" explanation))))))
 
 (defun resource-error (operation resource description &optional control-string &rest format-arguments)
   "Signal a RESOURCE-ERROR."
@@ -205,20 +219,26 @@ to the resource handle indicates that the underlying resource exists."))
 
 (defun describe-resource-no-longer-exists (condition stream)
   (with-slots (name displayname steward) (resource-error-resource condition)
-    (let ((*print-circle* nil))
-      (format stream "~&Operation on resource ~A failed.
-
-The steward ~A trying to ~A the resource ~A realised that
-the underlying resource ~A no longer exists while the last
-known state indicates the underlying resource was existing." 
-	      (or displayname name (resource-error-resource condition))
+    (let ((*print-circle*
+	    nil)
+	  (effective-displayname
+	    (or displayname name (resource-error-resource condition))))
+      (format stream "~&Resource ~A no longer exists." effective-displayname)
+      (start-new-paragraph stream)
+      (format stream "~@<The steward ~A trying to ~A the resource ~A realised that the underlying resource ~A no longer exists while the last known state indicates the underlying resource was existing.~:@>"
 	      (slot-value steward 'name)
-	      (resource-error-operation condition)
-	      (or displayname name (resource-error-resource condition))
-	      (resource-error-description condition))
+	      (case (resource-error-operation condition)
+		(create-resource "create")
+		(delete-resource "delete")
+		(import-resource "import")
+		(t
+		 (resource-error-operation condition)))
+	      effective-displayname
+	      effective-displayname)
       (with-slots (explanation) condition
 	(when explanation
-	  (format stream "~&~A" explanation))))))
+	  (start-new-paragraph stream)
+	  (format stream "~A" explanation))))))
 
 (defun resource-no-longer-exists (operation resource description &optional control-string &rest format-arguments)
   "Signal a RESOURCE-NO-LONGER-EXISTS."
@@ -683,7 +703,7 @@ keywords are sorted in ascending order."))
      :description description
      :state state)))
 
-(defun import-resource (steward resource-class &key displayname description identifier)
+(defun import-resource (steward resource-class &key displayname description identifier parent)
   "Import a RESOURCE based on its IDENTIFIER into its STEWARD.
 This assumes a resource has been created in STEWARD by a third party and
 imports it into the current system by creating a resource for it."
@@ -692,7 +712,8 @@ imports it into the current system by creating a resource for it."
 			 :steward steward
 			 :displayname displayname
 			 :description description
-			 :identifier identifier)))
+			 :identifier identifier
+			 :parent parent)))
     (update-instance-from-resource instance)
     (unless (resource-exists-p instance)
       (resource-error
@@ -710,7 +731,8 @@ instead of the expected state as specified by RESOURCE."
   (import-resource (steward resource) (type-of resource)
 		   :displayname (displayname resource)
 		   :description (description resource)
-		   :identifier (resource-identifier resource)))
+		   :identifier (resource-identifier resource)
+		   :parent (resource-parent resource)))
 
 (defgeneric update-resource-from-instance (instance)
   (:documentation "Update resource attributes to reflect INSTANCE.

src/stewards/docker-engine.lisp

@@ -144,11 +144,11 @@ the `docker' CLI client."))
    "A local volume belonging to a docker engine steward."))
 
 (defun make-docker-volume (&rest initargs &key docker-engine name displayname description
-					       state identifier external
+					       state identifier parent external
 					       volume driver)
   "Make a local docker volume"
   (declare (ignore name displayname description
-		   state identifier external
+		   state identifier parent external
 		   volume driver))
   (check-type docker-engine docker-engine)
   (apply #'make-instance 'docker-volume
@@ -326,11 +326,11 @@ therefore the docker volume ~A with the same name cannot be created." volume ins
    "A docker compose project belonging to a docker engine steward."))
 
 (defun make-docker-project (&rest initargs &key docker-engine name displayname description
-						state identifier external
+						state identifier parent external
 						project pathname volumes environment)
   "Make a docker compose project."
   (declare (ignore name displayname description
-		   state identifier external
+		   state identifier parent external
 		   project pathname volumes environment))
   (check-type docker-engine docker-engine)
   (apply #'make-instance 'docker-project