;;; -*- 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 (value (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 ((or (string= "Platform Database Release" (project-name octopus-ode-deploy-release)) (string= "Platform Release" (project-name octopus-ode-deploy-release)) (string= "Dispatch V2" (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))) (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)))))))