Merge pull request #1 from ololabs/initial-commit

initial commit

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)))))))