path: root/lisp/octopus/octopus.lisp

;;; -*- 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-deploy-release (octopus)
  ((project-name :initarg :project-name
                 :initform nil
                 :accessor project-name)
   (version :initarg :version
            :initform nil
            :accessor version)
   (environment-name :initarg :environment-name
                     :initform nil
                     :accessor environment-name)
   (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-ode-deploy-release (octopus-deploy-release)
  ((ode-names :initarg :ode-names
              :initform nil
              :accessor ode-names))
  (: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)))

(defmacro filter-match-p (filter &body body)
  `(or (null ,filter)
       (string= "all" (car ,filter))
       (intersection (loop for f in ,filter
                           when (not (string= "all" f))
                             collect f)
                     ,@body
                     :test (lambda (x y) (org-ckons-core::match-it x y)))))

(defmethod get-octopus-environments ((octopus octopus) &key ode-only-p environment-filter)
  (sort (loop for environment in (get-octopus-items-default-impl octopus "environments" :method :get :params `(("name" . ,(if ode-only-p "OnDemand-" ""))))
              when (filter-match-p environment-filter `(,(cdr (assoc :*name environment))))
                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 environment-filter)
  (get-octopus-environments octopus
                            :ode-only-p t
                            :environment-filter (if (string= "all" (car environment-filter))
                                                    environment-filter
                                                    (loop for f in environment-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-deploy-release octopus-deploy-release))
  (let ((deployment (get-octopus-items-raw-impl octopus-deploy-release
                                                "deployments"
                                                :method :post
                                                :params (json:encode-json-alist-to-string
                                                         `((:*environment-id . ,(id (environment octopus-deploy-release)))
                                                           (:*project-id . ,(id (project octopus-deploy-release)))
                                                           (:*release-id . ,(id (release octopus-deploy-release))))))))
    (when deployment
      (make-instance 'octopus-deployment
                     :id (cdr (assoc :*id deployment))
                     :task-id (cdr (assoc :*task-id deployment))
                     :environment (environment octopus-deploy-release)
                     :project (project octopus-deploy-release)
                     :release (release octopus-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-deploy-release octopus-deploy-release))
  (let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t))
        (deployment (do-octopus-deployment octopus-deploy-release))
        task)
    (with-output-to-string (stream output)
      (format stream
              "Deployed ~a ~a ~a ~a to ~a ~a~%"
              (name (project octopus-deploy-release))
              (id (project octopus-deploy-release))
              (id (release octopus-deploy-release))
              (task-id deployment)
              (id (environment octopus-deploy-release))
              (name (environment octopus-deploy-release)))
      (loop while (or (not task)
                      (not (completed-p task)))
            do (sleep 15)
               (setf task (get-octopus-task octopus-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-deploy-release) :direction :output :if-exists :append :if-does-not-exist :create)
      (format stream output))))

(defmethod do-octopus-enqueue-deploy-release ((octopus-deploy-release octopus-deploy-release))
  (let ((job (make-instance 'octopus-deploy-release
                            :project-name (project-name octopus-deploy-release)
                            :version (version octopus-deploy-release)
                            :project (project octopus-deploy-release)
                            :release (release octopus-deploy-release)
                            :environment (environment octopus-deploy-release)
                            :stdout (stdout octopus-deploy-release))))
    (cond ((or (string= "Platform Database Release" (project-name octopus-deploy-release))
               (string= "Platform Release" (project-name octopus-deploy-release))
               (string= "Dispatch V2" (project-name octopus-deploy-release)))
           (enqueue *queue-octopus-slow* job))
          (t
           (enqueue *queue-octopus-fast* job)))))

(defmethod do-octopus-deploy-release ((octopus-deploy-release octopus-deploy-release))
  (let* ((project (get-octopus-project octopus-deploy-release (project-name octopus-deploy-release)))
         (release (get-octopus-release octopus-deploy-release project (version octopus-deploy-release)))
         (environment (car (get-octopus-environments octopus-deploy-release :environment-filter `(,(environment-name octopus-deploy-release))))))
    (do-octopus-enqueue-deploy-release (make-instance 'octopus-deploy-release
                                                      :project-name (project-name octopus-deploy-release)
                                                      :version (version octopus-deploy-release)
                                                      :project project
                                                      :release release
                                                      :environment environment
                                                      :stdout (stdout octopus-deploy-release)))))

(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 :environment-filter (ode-names octopus-ode-deploy-release)))
            do (do-octopus-enqueue-deploy-release (make-instance 'octopus-deploy-release
                                                                 :project-name (project-name octopus-ode-deploy-release)
                                                                 :version (version octopus-ode-deploy-release)
                                                                 :project project
                                                                 :release release
                                                                 :environment environment
                                                                 :stdout (stdout octopus-ode-deploy-release)))))))

(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 (environment-filter '("all")) (project-filter '("all")))
  (let ((environments (get-octopus-environments octopus :ode-only-p ode-only-p :environment-filter environment-filter))
        (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 (and environment project)
                          (filter-match-p project-filter `(,(name 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 (environment-filter '("all")) (project-filter '("all")))
  (labels ((deployment-included-p (deployment deploy-hash)
             (and (not (intersection '("Feature Flags for Pipeline" "Channel Resource Release") `(,(name (project deployment))) :test 'string=))
                  (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 :environment-filter environment-filter :project-filter project-filter)
            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)))))))