From a5fd76880291ea8135ee6b9a433082ed7fd11564 Mon Sep 17 00:00:00 2001 From: ckonstanski Date: Tue, 6 Jan 2026 18:56:24 -0700 Subject: [INF-18492] Automate Queue Retry and Log Streaming Retry octopus fix --- .../service/octopus-qrs-lsrs-redeploy-service.lisp | 72 ++++++++++++++++++++++ 1 file changed, 72 insertions(+) create mode 100644 lisp/service/octopus-qrs-lsrs-redeploy-service.lisp (limited to 'lisp/service/octopus-qrs-lsrs-redeploy-service.lisp') diff --git a/lisp/service/octopus-qrs-lsrs-redeploy-service.lisp b/lisp/service/octopus-qrs-lsrs-redeploy-service.lisp new file mode 100644 index 0000000..a2d4a18 --- /dev/null +++ b/lisp/service/octopus-qrs-lsrs-redeploy-service.lisp @@ -0,0 +1,72 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :snow) + +(defclass octopus-qrs-lsrs-redeploy-service (rest-service) + () + (:documentation "")) + +(defun octopus-qrs-lsrs-redeploy-json () + (with-noauth (instance octopus-qrs-lsrs-redeploy-service) + t)) + +(defclass octopus-qrs-lsrs-redeploy/view-service (octopus-qrs-lsrs-redeploy-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-qrs-lsrs-redeploy-view-json () + (with-noauth (instance octopus-qrs-lsrs-redeploy/view-service) + (setf (form instance) + (make-form "octopus-qrs-lsrs-redeploy-form" + nil + t + `((:name "environment" :label "Environment" :field-type "text" :required "required" :value ,(or (session-value :octopus-environment) "")) + (:label "Find Latest QRS/LSRS in Environment" :field-type "button" :onclick "on_octopus_qrs_lsrs_redeploy_results_clicked()")))))) + +(defclass octopus-qrs-lsrs-redeploy/results-service (octopus-qrs-lsrs-redeploy/view-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-qrs-lsrs-redeploy-results-json (environment) + (with-noauth (instance octopus-latest-deployments/results-service) + (with-octopus (octopus) + (let* ((projects '("Queue Retry Service" "Log Streaming Retry Service")) + (deployments (org-ckons-core::flatten + (loop for project in projects + collect (get-octopus-latest-deployments octopus + :ode-only-p nil + :environment-filter `(,environment) + :project-filter `(,project)))))) + (setf (session-value :octopus-environment) environment) + (setf (session-value :octopus-qrs-lsrs-redeploy-deployments) deployments) + (setf (results instance) deployments) + (setf (form instance) + (make-form "octopus-qrs-lsrs-redeploy-submit-form" + nil + t + `((:label "Redeploy QRS/LSRS" :field-type "button" :onclick "on_octopus_qrs_lsrs_redeploy_results_submit_clicked()")))))))) + +(defclass octopus-qrs-lsrs-redeploy/results-submit-service (octopus-qrs-lsrs-redeploy-service) + ((stdout :initarg :stdout + :initform nil + :accessor stdout) + (location-p :initform nil)) + (:documentation "")) + +(defun octopus-qrs-lsrs-redeploy-results-submit-json () + (with-noauth (instance octopus-qrs-lsrs-redeploy/results-submit-service) + (cl-fad:with-output-to-temporary-file (f :template "/tmp/snow/temp-%") + (loop for deployment in (session-value :octopus-qrs-lsrs-redeploy-deployments) + do (do-octopus-deploy-release (make-instance 'octopus-deploy-release + :project-name (project-name deployment) + :version (release-version deployment) + :environment-name (session-value :octopus-environment) + :stdout (pathname f))) + (setf (stdout instance) (uiop:native-namestring (pathname f))))))) -- cgit v1.3 From da4f53c33fa1faf267a536bc0a2c5a8dd2871c5e Mon Sep 17 00:00:00 2001 From: ckonstanski Date: Wed, 7 Jan 2026 17:28:03 -0700 Subject: Fix environment lookup --- lisp/octopus/octopus.lisp | 17 ++++++++++++++++- lisp/service/octopus-qrs-lsrs-redeploy-service.lisp | 2 +- 2 files changed, 17 insertions(+), 2 deletions(-) (limited to 'lisp/service/octopus-qrs-lsrs-redeploy-service.lisp') diff --git a/lisp/octopus/octopus.lisp b/lisp/octopus/octopus.lisp index c242d54..61302bf 100644 --- a/lisp/octopus/octopus.lisp +++ b/lisp/octopus/octopus.lisp @@ -71,6 +71,9 @@ (version-control-reference :initarg :version-control-reference :initform nil :accessor version-control-reference) + (channel-id :initarg :channel-id + :initform nil + :accessor channel-id) (project :initarg :project :initform nil :accessor project)) @@ -89,6 +92,9 @@ (environment :initarg :environment :initform nil :accessor environment) + (channel-id :initarg :channel-id + :initform nil + :accessor channel-id) (project :initarg :project :initform nil :accessor project) @@ -176,6 +182,9 @@ as an input filter are stored here for the ride through the queue.") (release-version :initarg :release-version :initform nil :accessor release-version) + (channel-id :initarg :channel-id + :initform nil + :accessor channel-id) (git-commit :initarg :git-commit :initform nil :accessor git-commit) @@ -298,6 +307,7 @@ as an input filter are stored here for the ride through the queue.") :id (cdr (assoc :*id release)) :version (cdr (assoc :*version release)) :version-control-reference (cdr (assoc :*version-control-reference release)) + :channel-id (cdr (assoc :*channel-id release)) :project project)) (lambda (x y) (string< (version x) (version y))))) @@ -341,6 +351,7 @@ as an input filter are stored here for the ride through the queue.") :id (cdr (assoc :*id deployment)) :task-id (cdr (assoc :*task-id deployment)) :environment (environment octopus-deploy-release) + :channel-id (cdr (assoc :*channel-id deployment)) :project (project octopus-deploy-release) :release (release octopus-deploy-release))))) @@ -411,7 +422,9 @@ as an input filter are stored here for the ride through the queue.") (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)))))) + (environment (car (remove-if-not (lambda (x) + (string= (name x) (environment-name octopus-deploy-release))) + (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) @@ -457,6 +470,7 @@ as an input filter are stored here for the ride through the queue.") :id (cdr (assoc :*id deployment)) :task-id (cdr (assoc :*task-id deployment)) :release-version (cdr (assoc :*release-version deployment)) + :channel-id (cdr (assoc :*channel-id deployment)) :completed-time (local-time:to-rfc3339-timestring (local-time:parse-timestring (cdr (assoc :*completed-time deployment)))) :environment environment :project project)) @@ -479,6 +493,7 @@ as an input filter are stored here for the ride through the queue.") :deployment-id (id deployment) :task-id (task-id deployment) :release-version (release-version deployment) + :channel-id (channel-id deployment) :git-commit (cdr (assoc :*git-commit (version-control-reference (release deployment)))) :completed-time (completed-time deployment) :environment-name (name (environment deployment)) diff --git a/lisp/service/octopus-qrs-lsrs-redeploy-service.lisp b/lisp/service/octopus-qrs-lsrs-redeploy-service.lisp index a2d4a18..4796754 100644 --- a/lisp/service/octopus-qrs-lsrs-redeploy-service.lisp +++ b/lisp/service/octopus-qrs-lsrs-redeploy-service.lisp @@ -67,6 +67,6 @@ do (do-octopus-deploy-release (make-instance 'octopus-deploy-release :project-name (project-name deployment) :version (release-version deployment) - :environment-name (session-value :octopus-environment) + :environment-name (environment-name deployment) :stdout (pathname f))) (setf (stdout instance) (uiop:native-namestring (pathname f))))))) -- cgit v1.3