Added target parameter in protocol src/deployment/*.lisp

* src/deployment/conditions.lisp (deployment-condition::target): new
  slot; stores target of deployment
  (deployment-error): adapted report
  (project-deployment-error): likewise
* src/deployment/protocol.lisp (deploy): added target parameter
  (deploy-dependencies): likewise
  (deploy :around t t): added target parameter; pass target to
  signaled condition
  (deploy-dependencies :around t t): likewise
  (define-service target): new service; for deployment targets
  (make-target): new function; helper for instantiating the target
  service
* src/deployment/defaults.lisp (deploy distribution t): target
  parameter; pass to nested `deploy' call
  (deploy :around version t): similar
  (deploy version t): similar
* src/deployment/jenkins/job.lisp (deploy distribution target):
  removed :around qualifier; added target parameter
  (deploy job target): similar
  (deploy-dependencies job target): similar
  (maybe-delete-other-jobs): new function; delete jobs according to
  settings in target argument
* src/deployment/jenkins/target.lisp: new file; contains target class
  for jenkins deployment
* src/deployment/package.lisp (package build-generator.deployment):
  added exported symbols target and make-target
* src/commands/functions-deploy.lisp (configure-orchestration): accept
  target parameter, pass to `deploy'
  (configure-distribution): similar
  (configure-distributions): similar
* src/commands/command-generate.lisp (command-execute generate):
  construct target instance, pass to `generate-deploy'
  (generate-deploy): accept target argument; pass to `deploy' and
  `maybe-delete-other-jobs'
* build-generator.asd (system build-generator): added file
  src/deployment/jenkins/target.lisp to module "deployment-jenkins"

build-generator.asd

@@ -194,6 +194,7 @@
                               "deployment")
                  :serial     t
                  :components ((:file     "package")
+                              (:file     "target")
                               (:file     "job")))
 
                 (:module     "report"

src/commands/command-generate.lisp

@@ -77,10 +77,12 @@
                     distributions))))
     (as-phase (:check-access ; :continuable? nil
                )
-      (check-distribution-access distributions))
-    (generate-deploy distributions
-                     :delete-other?        delete-other?
-                     :delete-other-pattern delete-other-pattern)))
+              (check-distribution-access distributions))
+    (let ((target (deploy:make-target
+                   :jenkins
+                   :delete-other?        delete-other?
+                   :delete-other-pattern delete-other-pattern)))
+      (generate-deploy distributions target))))
 
 ;;; Functions
 
@@ -164,24 +166,19 @@
                           (map 'list #'resolve-versions distributions))))
     (values distributions analyzed-projects)))
 
-(defun generate-deploy (distributions
-                        &key
-                        delete-other?
-                        delete-other-pattern)
-  (let+ ((jobs/specs (as-phase (:deploy/project)
-                       (mappend #'deploy:deploy distributions)))
-         (jobs       (mappend #'model:implementations jobs/specs))
-         ((&values &ign orchestration-jobs)
-          (as-phase (:orchestration)
-            (configure-distributions distributions)))
-         (all-jobs   (append jobs (mappend #'model:implementations
-                                           orchestration-jobs))))
-    (when delete-other?
-      (as-phase (:delete-other-jobs)
-        (build-generator.deployment.jenkins::delete-other-jobs
-         all-jobs
-         (build-generator.deployment.jenkins::make-delete-other-pattern
-          delete-other-pattern distributions))))
+(defun generate-deploy (distributions target)
+  (let* ((jobs/specs         (as-phase (:deploy/project)
+                               (mappend (rcurry #'deploy:deploy target)
+                                        distributions)))
+         (jobs               (mappend #'model:implementations jobs/specs))
+         (orchestration-jobs (as-phase (:orchestration)
+                               (nth-value
+                                1 (configure-distributions distributions target))))
+         (all-jobs           (append jobs (mappend #'model:implementations
+                                                   orchestration-jobs))))
+    (as-phase (:delete-other-jobs)
+      (build-generator.deployment.jenkins::maybe-delete-other-jobs
+       distributions all-jobs target))
 
     (as-phase (:list-credentials)
       (list-credentials jobs))))

src/commands/functions-deploy.lisp

@@ -8,7 +8,7 @@
 
 ;;; Toolkit specific stuff
 
-(defun configure-orchestration (distribution)
+(defun configure-orchestration (distribution target)
   (with-trivial-progress (:orchestration "Configuring orchestration jobs")
     (let* ((templates    (list (project:find-template "orchestration")))
            (project-spec (make-instance 'project::project-spec
@@ -21,7 +21,7 @@
                            (reinitialize-instance project-spec
                                                   :versions (list version-spec))
                            (model:instantiate version-spec :parent distribution))))
-      (flatten (deploy:deploy version)))))
+      (flatten (deploy:deploy version target)))))
 
 (defun configure-view (name jobs &key columns)
   (with-trivial-progress (:view "~A" name)
@@ -35,11 +35,11 @@
       (jenkins.api:commit! view)
       view)))
 
-(defun configure-distribution (distribution)
+(defun configure-distribution (distribution target)
   (let* ((jobs               (mappend #'project:jobs (project:versions distribution)))
          (orchestration-jobs (with-simple-restart
                                  (continue "~@<Continue without configuring orchestration jobs~@:>")
-                               (configure-orchestration distribution)))
+                               (configure-orchestration distribution target)))
          (all-jobs           (mapcan (lambda (job)
                                        (when-let ((jenkins-job (model:implementation job)))
                                          (list jenkins-job)))
@@ -53,11 +53,11 @@
                  (when columns (list :columns columns))))))
     (values jobs orchestration-jobs all-jobs)))
 
-(defun configure-distributions (distributions)
+(defun configure-distributions (distributions target)
   (values-list
    (reduce (lambda+ ((jobs orchestration-jobs all-jobs) distribution)
              (let+ (((&values jobs1 orchestration-jobs1 all-jobs1)
-                     (configure-distribution distribution)))
+                     (configure-distribution distribution target)))
                (list (append jobs1               jobs)
                      (append orchestration-jobs1 orchestration-jobs)
                      (append all-jobs1           all-jobs))))

src/deployment/conditions.lisp

@@ -7,12 +7,17 @@
 (cl:in-package #:build-generator.deployment)
 
 (define-condition deployment-condition (chainable-condition)
-  ((thing :initarg  :thing
-          :reader   thing
-          :documentation
-          "The thing the deployment of which caused the condition."))
+  ((thing  :initarg  :thing
+           :reader   thing
+           :documentation
+           "The thing the deployment of which caused the condition.")
+   (target :initarg  :target
+           :reader   target
+           :documentation
+           "The target of the deployment which caused the condition."))
   (:default-initargs
-   :thing (missing-required-initarg 'deployment-condition :thing))
+   :thing  (missing-required-initarg 'deployment-condition :thing)
+   :target (missing-required-initarg 'deployment-condition :target))
   (:documentation
    "Subclasses of this condition are signaled to indicate certain
     conditions during the deployment of things."))
@@ -23,8 +28,8 @@
   (:report
    (lambda (condition stream)
      (format stream "~@<Error during deployment of ~
-                     ~A.~/more-conditions:maybe-print-cause/~@:>"
-             (thing condition) condition)))
+                     ~A to ~A.~/more-conditions:maybe-print-cause/~@:>"
+             (thing condition) (target condition) condition)))
   (:documentation
    "This error is signaled when an error is encountered during
     deployment of a thing."))
@@ -34,6 +39,8 @@
   (:report
    (lambda (condition stream)
      (format stream "~@<Error during deployment of project version ~
-                     ~/print-items:format-print-items/.~
+                     ~/print-items:format-print-items/ to ~A.~
                      ~/more-conditions:maybe-print-cause/~@:>"
-             (print-items:print-items (thing condition)) condition))))
+             (print-items:print-items (thing condition))
+             (target condition)
+             condition))))

src/deployment/defaults.lisp

@@ -8,7 +8,7 @@
 
 ;;; `project:distribution'
 
-(defmethod deploy ((thing project:distribution))
+(defmethod deploy ((thing project:distribution) (target t))
   (let ((versions (project:versions thing)))
     (with-sequence-progress (:deploy/project versions)
       (mappend (lambda (version)
@@ -17,26 +17,26 @@
                  (more-conditions::without-progress
                    (with-simple-restart
                        (continue "~@<Skip deploying project version ~S.~@:>" version)
-                     (flatten (deploy version)))))
+                     (flatten (deploy version target)))))
                versions))))
 
 ;;; `project:version'
 
 (defvar *outermost-version?* t)
 
-(defmethod deploy :around ((thing project:version))
+(defmethod deploy :around ((thing project:version) (target t))
   (if *outermost-version?*
       (with-condition-translation (((error project-deployment-error)
-                                    :thing thing))
+                                    :thing thing :target target))
         (let ((*outermost-version?* nil))
           (call-next-method)))
       (call-next-method)))
 
-(defmethod deploy ((thing project:version))
+(defmethod deploy ((thing project:version) (target t))
   (let ((jobs (project:jobs thing)))
     (with-sequence-progress (:deploy/job jobs)
       (mappend (lambda (job)
                  (progress "~/print-items:format-print-items/"
                            (print-items:print-items job))
-                 (list (deploy job)))
+                 (list (deploy job target)))
                jobs))))

src/deployment/jenkins/job.lisp

@@ -8,7 +8,7 @@
 
 ;;; Deploy `distribution'
 
-(defmethod deploy:deploy :around ((thing project:distribution))
+(defmethod deploy:deploy ((thing project:distribution) (target target))
   (let ((jobs (call-next-method)))
     (when-let ((dependency-jobs
                 (remove :none jobs
@@ -17,13 +17,13 @@
         (map nil (lambda (job)
                    (progress "~/print-items:format-print-items/"
                              (print-items:print-items job))
-                   (deploy:deploy-dependencies job))
+                   (deploy:deploy-dependencies job target))
              dependency-jobs)))
     jobs))
 
 ;;; Deploy `job'
 
-(defmethod deploy:deploy ((thing project::job))
+(defmethod deploy:deploy ((thing project::job) (target target))
   (let+ ((id        (substitute-if-not
                      #\_ #'jenkins.api:job-name-character?
                      (var:value/cast thing :build-job-name)))
@@ -85,7 +85,7 @@
 
     thing))
 
-(defmethod deploy:deploy-dependencies ((thing project::job))
+(defmethod deploy:deploy-dependencies ((thing project::job) (target target))
   (let ((relevant-dependencies
           (ecase (var:value/cast thing :dependencies.mode :direct)
             (:direct  (model:direct-dependencies thing))
@@ -153,3 +153,9 @@
     (with-sequence-progress (:delete-other generated-jobs)
       (mapc (progressing #'jenkins.api:delete-job :delete-other)
             generated-jobs))))
+
+(defun maybe-delete-other-jobs (distributions all-jobs target)
+  (let+ (((&accessors-r/o delete-other? delete-other-pattern) target))
+    (when delete-other?
+      (delete-other-jobs all-jobs (make-delete-other-pattern
+                                   delete-other-pattern distributions)))))

src/deployment/jenkins/target.lisp

@@ -0,0 +1,16 @@
+;;;; target.lisp --- Deployment target for Jenkins.
+;;;;
+;;;; Copyright (C) 2018, 2019 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:build-generator.deployment.jenkins)
+
+(defclass target ()
+  ((%delete-other?        :initarg :delete-other?
+                          :reader  delete-other?)
+   (%delete-other-pattern :initarg :delete-other-pattern
+                          :reader  delete-other-pattern)))
+
+(service-provider:register-provider/class
+ 'deploy:target :jenkins :class 'target)

src/deployment/package.lisp

@@ -21,6 +21,7 @@
   (:export
    #:deployment-condition
    #:thing
+   #:target
 
    #:deployment-error
 
@@ -29,4 +30,10 @@
   ;; Deployment protocol
   (:export
    #:deploy
-   #:deploy-dependencies))
+   #:deploy-dependencies)
+
+  ;; Target service
+  (:export
+   #:target                         ; service name
+
+   #:make-target))

src/deployment/protocol.lisp

@@ -8,30 +8,42 @@
 
 ;;; Deployment protocol
 
-(defgeneric deploy (thing)
+(defgeneric deploy (thing target)
   (:documentation
-   "Deploy THING.
+   "Deploy THING for TARGET.
 
     Signal `deployment-condition's such as `deployment-error' when
     conditions such as errors are encountered."))
 
-(defgeneric deploy-dependencies (thing)
+(defgeneric deploy-dependencies (thing target)
   (:documentation
-   "Deploy dependencies of THING.
+   "Deploy dependencies of THING for TARGET.
 
     Signal `deployment-condition's such as `deployment-error' when
     conditions such as errors are encountered."))
 
-;;; Default behavior
+;; Default behavior
 
-(defmethod deploy :around ((thing t))
-  (with-condition-translation (((error deployment-error) :thing thing))
-    (with-simple-restart (continue "~@<Skip deployment of ~A.~@:>" thing)
+(defmethod deploy :around ((thing t) (target t))
+  (with-condition-translation (((error deployment-error)
+                                :thing thing :target target))
+    (with-simple-restart (continue "~@<Skip deployment of ~A for ~A.~@:>"
+                                   thing target)
       (call-next-method))))
 
-(defmethod deploy-dependencies :around ((thing t))
-  (with-condition-translation (((error deployment-error) :thing thing))
+(defmethod deploy-dependencies :around ((thing t) (target t))
+  (with-condition-translation (((error deployment-error)
+                                :thing thing :target target))
     (with-simple-restart (continue "~@<Skip deploying dependencies of ~
-                                    ~A.~@:>"
-                                   thing)
+                                    ~A for ~A.~@:>"
+                                   thing target)
       (call-next-method))))
+
+;;; Service
+
+(service-provider:define-service target
+  (:documentation
+   "Providers implement different kinds of deployments."))
+
+(defun make-target (kind &rest initargs &key &allow-other-keys)
+  (apply #'service-provider:make-provider 'target kind initargs))