diff options
Diffstat (limited to 'lisp/octopus')
| -rw-r--r-- | lisp/octopus/octopus.lisp | 460 |
1 files changed, 460 insertions, 0 deletions
diff --git a/lisp/octopus/octopus.lisp b/lisp/octopus/octopus.lisp new file mode 100644 index 0000000..e9e1004 --- /dev/null +++ b/lisp/octopus/octopus.lisp @@ -0,0 +1,460 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass octopus () + ((apikey :initarg :apikey + :initform (get-aws-ssm-parameter (sb-ext:posix-getenv "OLO_AWS_BUILD_PROFILE") "/octopus/ode-mgmt/token") + :accessor apikey) + (baseurl :initarg :baseurl + :initform "https://octopus.olobuild.net/api" + :accessor baseurl) + (proxy :initarg :proxy + :initform (let ((proxy-string (uffi:getenv "http_proxy"))) + (when (not (org-ckons-core::null-or-empty-p proxy-string)) + (let ((proxy-list (cl-ppcre:split ":" (car (last (cl-ppcre:split "//" proxy-string)))))) + (setf (elt proxy-list 1) (parse-integer (elt proxy-list 1))) + proxy-list))) + :accessor proxy) + (cookie-jar :initarg :cookie-jar + :initform (make-instance 'drakma:cookie-jar) + :accessor cookie-jar)) + (:documentation "")) + +(defclass octopus-environment () + ((id :initarg :id + :initform nil + :accessor id) + (name :initarg :name + :initform nil + :accessor name)) + (:documentation "")) + +(defclass octopus-project () + ((id :initarg :id + :initform nil + :accessor id) + (name :initarg :name + :initform nil + :accessor name)) + (:documentation "")) + +(defclass octopus-machine () + ((id :initarg :id + :initform nil + :accessor id) + (environment-ids :initarg :environment-ids + :initform nil + :accessor environment-ids) + (name :initarg :name + :initform nil + :accessor name) + (roles :initarg :roles + :initform nil + :accessor roles) + (uri :initarg :uri + :initform nil + :accessor uri) + (health-status :initarg :health-status + :initform nil + :accessor health-status)) + (:documentation "")) + +(defclass octopus-release () + ((id :initarg :id + :initform nil + :accessor id) + (version :initarg :version + :initform nil + :accessor version) + (version-control-reference :initarg :version-control-reference + :initform nil + :accessor version-control-reference) + (project :initarg :project + :initform nil + :accessor project)) + (:documentation "")) + +(defclass octopus-deployment () + ((id :initarg :id + :initform nil + :accessor id) + (task-id :initarg :task-id + :initform nil + :accessor task-id) + (release-version :initarg :release-version + :initform nil + :accessor release-version) + (environment :initarg :environment + :initform nil + :accessor environment) + (project :initarg :project + :initform nil + :accessor project) + (release :initarg :release + :initform nil + :accessor release) + (completed-time :initarg :completed-time + :initform nil + :accessor completed-time)) + (:documentation "")) + +(defclass octopus-task () + ((id :initarg :id + :initform nil + :accessor id) + (completed-p :initarg :completed-p + :initform nil + :accessor completed-p) + (successful-p :initarg :successful-p + :initform nil + :accessor successful-p) + (error-message :initarg :error-message + :initform nil + :accessor error-message)) + (:documentation "")) + +(defclass octopus-process-step (octopus) + ((id :initarg :id + :initform nil + :accessor id) + (name :initarg :name + :initform nil + :accessor name) + (target-roles :initarg :target-roles + :initform nil + :accessor target-roles + :documentation "Does double duty: the roles associated with a process step from +octopus are stored here as output, and also the roles we want to use +as an input filter are stored here for the ride through the queue.") + (project :initarg :project + :initform nil + :accessor project) + (stdout :initarg :stdout + :initform nil + :accessor stdout)) + (:documentation "")) + +(defclass octopus-ode-deploy-release (octopus) + ((project-name :initarg :project-name + :initform nil + :accessor project-name) + (ode-names :initarg :ode-names + :initform nil + :accessor ode-names) + (version :initarg :version + :initform nil + :accessor version) + (environment :initarg :environment + :initform nil + :accessor environment) + (project :initarg :project + :initform nil + :accessor project) + (release :initarg :release + :initform nil + :accessor release) + (stdout :initarg :stdout + :initform nil + :accessor stdout)) + (:documentation "")) + +(defclass octopus-latest-deployment () + ((deployment-id :initarg :deployment-id + :initform nil + :accessor deployment-id) + (task-id :initarg :task-id + :initform nil + :accessor task-id) + (release-version :initarg :release-version + :initform nil + :accessor release-version) + (git-commit :initarg :git-commit + :initform nil + :accessor git-commit) + (completed-time :initarg :completed-time + :initform nil + :accessor completed-time) + (environment-name :initarg :environment-name + :initform nil + :accessor environment-name) + (project-name :initarg :project-name + :initform nil + :accessor project-name)) + (:documentation "")) + +(defmacro with-octopus ((instance-name) &body body) + `(let ((,instance-name (make-instance 'octopus))) + ,@body)) + +(defmethod sanitize ((octopus-machine octopus-machine)) + (make-instance 'octopus-machine + :id (id octopus-machine) + :name (name octopus-machine) + :roles (roles octopus-machine))) + +(defmacro define-octopus-api-call ((method-name) &body macro-body) + (let ((endpoint (gensym))) + `(progn + (defgeneric ,method-name (octopus uri &key method macro-content-type params)) + (defmethod ,method-name ((octopus octopus) uri &key method macro-content-type params) + (let ((,endpoint (format nil "~a/~a" (baseurl octopus) uri)) + results) + (multiple-value-bind (body status-code headers uri stream must-close reason) + (apply #'org-ckons-http::drakma-request + `(,,endpoint + ,(cookie-jar octopus) + :method ,method + :content-type ,macro-content-type + :proxy ,(proxy octopus) + ,@(if (eq method :get) + `(:parameters ,(append params `(("skip" . "0") + ("take" . "100000")))) + `(:content ,params)) + :additional-headers (("X-Octopus-ApiKey" . ,(apikey octopus))))) + (declare (ignore headers uri stream must-close reason)) + (let ((response (cl-json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8)))) + (cond ((< status-code 300) + (org-ckons-core::add-to-list results ,@macro-body)) + (t + (error (format nil "Error response from octopus.~%Method = [~a]~%Endpoint = [~a]~%Params = [~a]~%Response = [~a]" method ,endpoint params response)))))) + results))))) + +(define-octopus-api-call (get-octopus-items-raw-impl) + response) + +(define-octopus-api-call (get-octopus-items-default-impl) + (cdr (assoc :*items response))) + +(define-octopus-api-call (get-octopus-items-process-steps-impl) + (cdr (assoc :*steps response))) + +(defmethod get-octopus-environments ((octopus octopus) &key ode-only-p filter) + (sort (loop for environment in (get-octopus-items-default-impl octopus "environments" :method :get :params `(("name" . ,(if ode-only-p "OnDemand-" "")))) + when (or (null filter) + (string= "all" (car filter)) + (intersection (loop for f in filter + when (not (string= "all" f)) + collect f) + `(,(cdr (assoc :*name environment))) + :test (lambda (x y) (org-ckons-core::match-it x y)))) + collect (make-instance 'octopus-environment + :id (cdr (assoc :*id environment)) + :name (cdr (assoc :*name environment)))) + (lambda (x y) (string< (name x) (name y))))) + +(defmethod get-octopus-ode-environments ((octopus octopus) &key filter) + (get-octopus-environments octopus + :ode-only-p t + :filter (if (string= "all" (car filter)) + filter + (loop for f in filter + collect (format nil "OnDemand-~a" f))))) + +(defmethod get-octopus-projects ((octopus octopus)) + (sort (loop for project in (get-octopus-items-default-impl octopus "projects" :method :get) + when (not (cdr (assoc :*is-disabled project))) + collect (make-instance 'octopus-project + :id (cdr (assoc :*id project)) + :name (cdr (assoc :*name project)))) + (lambda (x y) (string< (name x) (name y))))) + +(defmethod get-octopus-project ((octopus octopus) project-name) + (car (loop for project in (get-octopus-projects octopus) + when (string= project-name (name project)) + collect project))) + +(defmethod get-octopus-process-steps ((octopus octopus) project) + (let ((steps (handler-case + (get-octopus-items-process-steps-impl octopus (format nil "projects/~a/main/deploymentprocesses" (id project)) :method :get) + (error (e) + (declare (ignore e)) + (handler-case + (get-octopus-items-process-steps-impl octopus (format nil "projects/~a/deploymentprocesses" (id project)) :method :get) + (error (f) + (org-ckons-core::logger (format nil "Error in get-octopus-process-steps in project ~a ~a : ~a" (id project) (name project) f)) + ())))))) + (loop for step in steps + collect (make-instance 'octopus-process-step + :id (cdr (assoc :*id step)) + :name (cdr (assoc :*name step)) + :target-roles (let ((roles (cdr (assoc :*octopus.*action.*target-roles (cdr (assoc :*properties step)))))) + (if (listp roles) roles (list roles))) + :project project)))) + +(defmethod get-octopus-releases ((octopus octopus) project) + (sort (loop for release in (get-octopus-items-default-impl octopus (format nil "projects/~a/releases" (id project)) :method :get) + collect (make-instance 'octopus-release + :id (cdr (assoc :*id release)) + :version (cdr (assoc :*version release)) + :version-control-reference (cdr (assoc :*version-control-reference release)) + :project project)) + (lambda (x y) (string< (version x) (version y))))) + +(defmethod get-octopus-release ((octopus octopus) project version) + (when project + (car (loop for release in (get-octopus-releases octopus project) + when (string= version (version release)) + collect release)))) + +(defmethod get-octopus-machines-with-roles ((octopus octopus) roles) + (loop for machine in (get-octopus-items-default-impl octopus "machines" :method :get) + when (intersection roles (cdr (assoc :*roles machine)) :test 'string=) + collect (make-instance 'octopus-machine + :id (cdr (assoc :*id machine)) + :environment-ids (cdr (assoc :*environment-ids machine)) + :name (cdr (assoc :*name machine)) + :roles (cdr (assoc :*roles machine)) + :uri (cdr (assoc :*uri machine)) + :health-status (cdr (assoc :*health-status machine))))) + +(defmethod get-octopus-environments-with-roles ((octopus octopus) &key ode-only-p roles) + (let ((all-environments (get-octopus-environments octopus :ode-only-p ode-only-p))) + (remove-duplicates (sort (org-ckons-core::flatten + (loop for machine in (get-octopus-machines-with-roles octopus roles) + collect (loop for environment in all-environments + when (intersection (environment-ids machine) `(,(id environment)) :test 'string=) + collect environment))) + (lambda (x y) (string< (name x) (name y)))) + :test (lambda (x y) (string= (name x) (name y)))))) + +(defmethod do-octopus-deployment ((octopus-ode-deploy-release octopus-ode-deploy-release)) + (let ((deployment (get-octopus-items-raw-impl octopus-ode-deploy-release + "deployments" + :method :post + :params (json:encode-json-alist-to-string + `((:*environment-id . ,(id (environment octopus-ode-deploy-release))) + (:*project-id . ,(id (project octopus-ode-deploy-release))) + (:*release-id . ,(id (release octopus-ode-deploy-release))) + (:*use-guided-failure . nil) + (:*force-package-download . t) + (:*force-package-redeployment . t)))))) + (when deployment + (make-instance 'octopus-deployment + :id (cdr (assoc :*id deployment)) + :task-id (cdr (assoc :*task-id deployment)) + :environment (environment octopus-ode-deploy-release) + :project (project octopus-ode-deploy-release) + :release (release octopus-ode-deploy-release))))) + +(defmethod get-octopus-task ((octopus octopus) task-id) + (let ((task (get-octopus-items-raw-impl octopus (format nil "tasks/~a" task-id) :method :get))) + (when task + (make-instance 'octopus-task + :id (cdr (assoc :*id task)) + :completed-p (cdr (assoc :*is-completed task)) + :successful-p (cdr (assoc :*finished-successfully task)) + :error-message (cdr (assoc :*error-message task)))))) + +(defmethod bg-perform ((octopus-process-step octopus-process-step)) + (let ((projects (sort + (remove-duplicates + (loop for project in (get-octopus-projects octopus-process-step) + when (loop for step in (get-octopus-process-steps octopus-process-step project) + when (intersection (target-roles octopus-process-step) (target-roles step) :test 'string=) + collect step) + collect project) + :test (lambda (x y) (string= (name x) (name y)))) + (lambda (x y) (string< (name x) (name y)))))) + (with-open-file (stream (stdout octopus-process-step) :direction :output :if-exists :append :if-does-not-exist :create) + (loop for project in projects + do (format stream "~16a~a~%" (id project) (name project)))))) + +(defmethod get-octopus-projects-with-roles ((octopus-process-step octopus-process-step)) + (enqueue *queue-octopus-fast* octopus-process-step)) + +(defmethod bg-perform ((octopus-ode-deploy-release octopus-ode-deploy-release)) + (let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t)) + (deployment (do-octopus-deployment octopus-ode-deploy-release)) + task) + (with-output-to-string (stream output) + (format stream + "Deployed ~a ~a ~a ~a to ~a ~a~%" + (name (project octopus-ode-deploy-release)) + (id (project octopus-ode-deploy-release)) + (id (release octopus-ode-deploy-release)) + (task-id deployment) + (id (environment octopus-ode-deploy-release)) + (name (environment octopus-ode-deploy-release))) + (loop while (or (not task) + (not (completed-p task))) + do (sleep 15) + (setf task (get-octopus-task octopus-ode-deploy-release (task-id deployment)))) + (when (not (successful-p task)) + (format stream " ~a failed: ~a~%" (id task) (error-message task))) + (format stream "~%")) + (with-open-file (stream (stdout octopus-ode-deploy-release) :direction :output :if-exists :append :if-does-not-exist :create) + (format stream output)))) + +(defmethod do-octopus-ode-deploy-release ((octopus-ode-deploy-release octopus-ode-deploy-release)) + (let* ((project (get-octopus-project octopus-ode-deploy-release (project-name octopus-ode-deploy-release))) + (release (get-octopus-release octopus-ode-deploy-release project (version octopus-ode-deploy-release)))) + (when (and project release) + (loop for environment in (remove-if (lambda (x) (or (string= "OnDemand-oid" (name x)) + (string= "OnDemand-verify" (name x)))) + (get-octopus-ode-environments octopus-ode-deploy-release :filter (ode-names octopus-ode-deploy-release))) + do (let ((job (make-instance 'octopus-ode-deploy-release + :project-name (project-name octopus-ode-deploy-release) + :ode-names (ode-names octopus-ode-deploy-release) + :version (version octopus-ode-deploy-release) + :project project + :release release + :environment environment + :stdout (stdout octopus-ode-deploy-release)))) + (cond ((string= "Platform Database Release" (project-name octopus-ode-deploy-release)) + (enqueue *queue-octopus-slow* job)) + (t + (enqueue *queue-octopus-fast* job)))))))) + +(defmethod get-octopus-deployments-successful ((octopus octopus)) + (loop for deployment in (get-octopus-items-default-impl octopus "dashboard/dynamic" :method :get) + when (string= (cdr (assoc :*state deployment)) "Success") + collect deployment)) + +(defmethod get-octopus-deployments ((octopus octopus) &key ode-only-p) + (let ((environments (get-octopus-environments octopus :ode-only-p ode-only-p :filter '("all"))) + (projects (get-octopus-projects octopus))) + (sort (loop for deployment in (get-octopus-deployments-successful octopus) + for environment = (find-if (lambda (x) + (string= (id x) (cdr (assoc :*environment-id deployment)))) + environments) + for project = (find-if (lambda (x) + (string= (id x) (cdr (assoc :*project-id deployment)))) + projects) + when (and environment project) + collect (make-instance 'octopus-deployment + :id (cdr (assoc :*id deployment)) + :task-id (cdr (assoc :*task-id deployment)) + :release-version (cdr (assoc :*release-version deployment)) + :completed-time (local-time:to-rfc3339-timestring (local-time:parse-timestring (cdr (assoc :*completed-time deployment)))) + :environment environment + :project project)) + (lambda (x y) (string> (completed-time x) (completed-time y)))))) + +(defmethod get-octopus-latest-deployments ((octopus octopus) &key ode-only-p) + (labels ((deployment-included-p (deployment deploy-hash) + (and (not (intersection '("Feature Flags for Pipeline" "Channel Resource Release") `(,(name (project deployment))) :test 'string=)) + (not (org-ckons-core::match-it ".*-rc$" (release-version deployment))) + (not (org-ckons-core::match-it ".*-main$" (release-version deployment))) + (not (org-ckons-core::match-it "EKS" (name (project deployment)))) + (not (org-ckons-core::match-it "YARP" (name (project deployment)))) + (or (not (gethash (name (environment deployment)) deploy-hash)) + (string> (completed-time deployment) (completed-time (gethash (name (environment deployment)) deploy-hash))))))) + (let* ((deploy-hash (make-hash-table :test 'equal)) + (deployments (loop for deployment in (get-octopus-deployments octopus :ode-only-p ode-only-p) + when (deployment-included-p deployment deploy-hash) + do (let ((release (get-octopus-release octopus (project deployment) (release-version deployment)))) + (when (version-control-reference release) + (setf (release deployment) release) + (setf (gethash (name (environment deployment)) deploy-hash) deployment)))))) + (sort (loop for deployment being the hash-values of deploy-hash + collect (make-instance 'octopus-latest-deployment + :deployment-id (id deployment) + :task-id (task-id deployment) + :release-version (release-version deployment) + :git-commit (cdr (assoc :*git-commit (version-control-reference (release deployment)))) + :completed-time (completed-time deployment) + :environment-name (name (environment deployment)) + :project-name (name (project deployment)))) + (lambda (x y) (string< (completed-time x) (completed-time y))))))) |