summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/aws/aws.lisp102
-rw-r--r--lisp/service/menu-service.lisp1
-rw-r--r--lisp/service/octopus-projects-with-roles-service.lisp4
-rw-r--r--lisp/service/unhealthy-targetgroups-service.lisp50
-rw-r--r--lisp/snow.asd1
-rw-r--r--lisp/webapps/snow/clojurescript/snow/src/core.cljs67
-rw-r--r--lisp/webapps/snow/site.lisp12
7 files changed, 236 insertions, 1 deletions
diff --git a/lisp/aws/aws.lisp b/lisp/aws/aws.lisp
index f5d6b93..ab6dcc8 100644
--- a/lisp/aws/aws.lisp
+++ b/lisp/aws/aws.lisp
@@ -81,6 +81,48 @@
:accessor passphrase))
(:documentation ""))
+(defclass aws-targetgroup (aws)
+ ((name :initarg :name
+ :initform nil
+ :accessor name)
+ (arn :initarg :arn
+ :initform nil
+ :accessor arn)
+ (protocol :initarg :protocol
+ :initform nil
+ :accessor protocol)
+ (port :initarg :port
+ :initform nil
+ :accessor port)
+ (healthy-p :initarg :healthy-p
+ :initform nil
+ :accessor healthy-p)
+ (stdout :initarg :stdout
+ :initform nil
+ :accessor stdout)
+ (filter :initarg :filter
+ :initform nil
+ :accessor filter)
+ (targets :initarg :targets
+ :initform nil
+ :accessor targets))
+ (:documentation ""))
+
+(defclass aws-target ()
+ ((instance-id :initarg :instance-id
+ :initform nil
+ :accessor instance-id)
+ (port :initarg :port
+ :initform nil
+ :accessor port)
+ (state :initarg :state
+ :initform nil
+ :accessor state)
+ (healthy-p :initarg :healthy-p
+ :initform nil
+ :accessor healthy-p))
+ (:documentation ""))
+
(defclass aws-ssm-parameter (aws)
((name :initarg :name
:initform nil
@@ -130,6 +172,66 @@
:instances (loop for instance in (cdr (assoc :*instances asg))
collect (cdr (assoc :*instance-id instance)))))))
+(defmethod get-targetgroups ((aws-targetgroup aws-targetgroup))
+ (let ((command "aws elbv2 describe-target-groups"))
+ (sort (loop for targetgroup in (cdar (run-aws-cli aws-targetgroup command))
+ when (org-ckons-core::match-it (if (string= (filter aws-targetgroup) "all")
+ ""
+ (filter aws-targetgroup))
+ (cdr (assoc :*target-group-name targetgroup)))
+ collect (let ((targetgroup (make-instance 'aws-targetgroup
+ :profile (profile aws-targetgroup)
+ :region (region aws-targetgroup)
+ :name (cdr (assoc :*target-group-name targetgroup))
+ :arn (cdr (assoc :*target-group-arn targetgroup))
+ :protocol (cdr (assoc :*protocol targetgroup))
+ :port (cdr (assoc :*port targetgroup)))))
+ (setf (targets targetgroup) (get-targets targetgroup))
+ (setf (healthy-p targetgroup) (get-targetgroup-health targetgroup))
+ targetgroup))
+ (lambda (x y) (string< (name x) (name y))))))
+
+(defmethod get-targets ((aws-targetgroup aws-targetgroup))
+ (let ((command (format nil
+ "aws elbv2 describe-target-health --target-group-arn ~a"
+ (arn aws-targetgroup))))
+ (loop for target in (cdar (run-aws-cli aws-targetgroup command))
+ collect (make-instance 'aws-target
+ :instance-id (cdr (assoc :*id (cdr (assoc :*target target))))
+ :port (cdr (assoc :*port (cdr (assoc :*target target))))
+ :state (cdr (assoc :*state (cdr (assoc :*target-health target))))
+ :healthy-p (string= (cdr (assoc :*state (cdr (assoc :*target-health target)))) "healthy")))))
+
+(defmethod get-targetgroup-health ((aws-targetgroup aws-targetgroup))
+ (let ((states (loop for target in (targets aws-targetgroup)
+ collect (healthy-p target))))
+ (= (length states)
+ (length (remove-if 'null states)))))
+
+(defmethod get-aws-unhealthy-targetgroups ((aws-targetgroup aws-targetgroup))
+ (enqueue *queue-aws* aws-targetgroup))
+
+(defmethod bg-perform ((aws-targetgroup aws-targetgroup))
+ (let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t))
+ (targetgroups (get-targetgroups aws-targetgroup)))
+ (with-output-to-string (stream output)
+ (loop for targetgroup in targetgroups
+ when (not (healthy-p targetgroup))
+ do (format stream
+ "~a~t~a~t~a~%"
+ (name targetgroup)
+ (arn targetgroup)
+ (port targetgroup))
+ (loop for target in (targets targetgroup)
+ when (not (healthy-p target))
+ do (format stream
+ "~t~a~t~a~%"
+ (instance-id target)
+ (state target)))
+ (format stream "~%")))
+ (with-open-file (stream (stdout aws-targetgroup) :direction :output :if-exists :append :if-does-not-exist :create)
+ (format stream output))))
+
(defmethod get-certificates ((aws aws) &optional filter)
(sort (loop for cert in (cdr (assoc :*certificate-summary-list (run-aws-cli aws "aws acm list-certificates")))
when (or (and (null filter)
diff --git a/lisp/service/menu-service.lisp b/lisp/service/menu-service.lisp
index 7911e32..1c50f3d 100644
--- a/lisp/service/menu-service.lisp
+++ b/lisp/service/menu-service.lisp
@@ -6,6 +6,7 @@
(defparameter *menu-config* '((:id "a_menu_home" :label "Home" :handler "/home" :permissions "t")
(:id "a_menu_git_update" :label "Git Update" :handler "/git-update" :permissions "t")
(:id "a_menu_asg_recycle" :label "ASG Recycle" :handler "/asg-recycle" :permissions "t")
+ (:id "a_menu_unhealthy_targetgroups" :label "Find Unhealthy Targetgroups" :handler "/unhealthy-targetgroups" :permissions "t")
(:id "a_menu_tfcloud_apply" :label "TFCloud Apply" :handler "/tfcloud-apply" :permissions "t")
(:id "a_menu_octopus_machines_with_roles" :label "Octo Machines With Roles" :handler "/octopus-machines-with-roles" :permissions "t")
(:id "a_menu_octopus_environments_with_roles" :label "Octo Envs With Roles" :handler "/octopus-environments-with-roles" :permissions "t")
diff --git a/lisp/service/octopus-projects-with-roles-service.lisp b/lisp/service/octopus-projects-with-roles-service.lisp
index c3d9a67..627f346 100644
--- a/lisp/service/octopus-projects-with-roles-service.lisp
+++ b/lisp/service/octopus-projects-with-roles-service.lisp
@@ -38,7 +38,9 @@
(with-noauth (instance octopus-projects-with-roles/results-service)
(cl-fad:with-output-to-temporary-file (f :template "/tmp/snow/temp-%")
(get-octopus-projects-with-roles (make-instance 'octopus-process-step
- :target-roles (remove-if (lambda (x) (org-ckons-core::null-or-empty-p x)) (cl-ppcre:split "[, ]" roles))
+ :target-roles (remove-if (lambda (x)
+ (org-ckons-core::null-or-empty-p x))
+ (cl-ppcre:split "[, ]" roles))
:stdout (pathname f)))
(setf (stdout instance) (uiop:native-namestring (pathname f))))
(setf (session-value :octopus-roles) roles)))
diff --git a/lisp/service/unhealthy-targetgroups-service.lisp b/lisp/service/unhealthy-targetgroups-service.lisp
new file mode 100644
index 0000000..578fe9c
--- /dev/null
+++ b/lisp/service/unhealthy-targetgroups-service.lisp
@@ -0,0 +1,50 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :snow)
+
+(defclass unhealthy-targetgroups-service (rest-service)
+ ()
+ (:documentation ""))
+
+(defun unhealthy-targetgroups-json ()
+ (with-noauth (instance unhealthy-targetgroups-service)
+ t))
+
+(defclass unhealthy-targetgroups/view-service (unhealthy-targetgroups-service)
+ ((form :initarg :form
+ :initform nil
+ :accessor form)
+ (location-p :initform nil))
+ (:documentation ""))
+
+(defun unhealthy-targetgroups-view-json ()
+ (with-noauth (instance unhealthy-targetgroups/view-service)
+ (setf (form instance)
+ (make-form "unhealthy-targetgroups-form"
+ nil
+ t
+ `((:name "profile" :label "Profile" :field-type "text" :required "required" :value ,(or (session-value :profile) ""))
+ (:name "region" :label "Region" :field-type "text" :required "required" :value ,(or (session-value :region) (region *webapp*)))
+ (:name "filter" :label "Filter" :field-type "text" :required "required" :value ,(or (session-value :unhealthy-targetgroup-filter) ""))
+ (:label "Find Unhealthy Targetgroups" :field-type "button" :onclick "on_unhealthy_targetgroups_results_clicked()"))))))
+
+(defclass unhealthy-targetgroups/results-service (unhealthy-targetgroups/view-service)
+ ((stdout :initarg :stdout
+ :initform nil
+ :accessor stdout)
+ (location-p :initform nil))
+ (:documentation ""))
+
+(defun unhealthy-targetgroups-results-json (profile region filter)
+ (with-noauth (instance unhealthy-targetgroups/results-service)
+ (cl-fad:with-output-to-temporary-file (f :template "/tmp/snow/temp-%")
+ (get-aws-unhealthy-targetgroups (make-instance 'aws-targetgroup
+ :profile profile
+ :region region
+ :filter filter
+ :stdout (pathname f)))
+ (setf (stdout instance) (uiop:native-namestring (pathname f))))
+ (setf (session-value :profile) profile)
+ (setf (session-value :region) region)
+ (setf (session-value :unhealthy-targetgroup-filter) filter)))
diff --git a/lisp/snow.asd b/lisp/snow.asd
index b8624c3..e9bc646 100644
--- a/lisp/snow.asd
+++ b/lisp/snow.asd
@@ -62,6 +62,7 @@
(:file "home-service" :depends-on ("auth-service"))
(:file "git-update-service" :depends-on ("auth-service"))
(:file "asg-recycle-service" :depends-on ("auth-service"))
+ (:file "unhealthy-targetgroups-service" :depends-on ("auth-service"))
(:file "tfcloud-apply-service" :depends-on ("auth-service"))
(:file "octopus-machines-with-roles-service" :depends-on ("auth-service"))
(:file "octopus-environments-with-roles-service" :depends-on ("auth-service"))
diff --git a/lisp/webapps/snow/clojurescript/snow/src/core.cljs b/lisp/webapps/snow/clojurescript/snow/src/core.cljs
index 304e5ec..922df5a 100644
--- a/lisp/webapps/snow/clojurescript/snow/src/core.cljs
+++ b/lisp/webapps/snow/clojurescript/snow/src/core.cljs
@@ -50,6 +50,16 @@
(declare template-asg-recycle-results-submit)
(declare handler-asg-recycle-results-submit)
(declare render-asg-recycle-results-submit)
+(declare template-unhealthy-targetgroups)
+(declare handler-unhealthy-targetgroups)
+(declare render-unhealthy-targetgroups)
+(declare template-unhealthy-targetgroups-view)
+(declare handler-unhealthy-targetgroups-view)
+(declare render-unhealthy-targetgroups-view)
+(declare on-unhealthy-targetgroups-results-clicked)
+(declare template-unhealthy-targetgroups-results)
+(declare handler-unhealthy-targetgroups-results)
+(declare render-unhealthy-targetgroups-results)
(declare template-tfcloud-apply)
(declare handler-tfcloud-apply)
(declare render-tfcloud-apply)
@@ -247,6 +257,7 @@
(hiccups/defhtml template-asg-recycle [jsonobj]
[:h3 {:style "text-align: center"} "Recycle the ASGs matching the filter."]
+ [:h5 {:style "text-align: center"} "For all ASGs please specify `all` for the filter."]
[:div {:id "content"}]
[:div {:id "results-submit-ack"}]
[:div {:id "results-submit"}]
@@ -325,6 +336,61 @@
:params {:howmany howmany}
:handler handler-asg-recycle-results-submit}))
+;; unhealthy-targetgroups
+
+(hiccups/defhtml template-unhealthy-targetgroups [jsonobj]
+ [:h3 {:style "text-align: center"} "Find all unhealthy targetgroups matching the filter."]
+ [:h5 {:style "text-align: center"} "For all targetgroups please specify `all` for the filter."]
+ [:div {:id "content"}]
+ [:div {:id "results"}])
+
+(defn handler-unhealthy-targetgroups [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#body) (template-unhealthy-targetgroups jsonobj))
+ (render-unhealthy-targetgroups-view)))
+
+(defn render-unhealthy-targetgroups []
+ (GET "/unhealthy-targetgroups" {:handler handler-unhealthy-targetgroups}))
+
+;; unhealthy-targetgroups-view
+
+(hiccups/defhtml template-unhealthy-targetgroups-view [jsonobj]
+ (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)))
+
+(defn handler-unhealthy-targetgroups-view [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#content) (template-unhealthy-targetgroups-view jsonobj))))
+
+(defn render-unhealthy-targetgroups-view []
+ (GET "/unhealthy-targetgroups/view" {:handler handler-unhealthy-targetgroups-view}))
+
+;; unhealthy-targetgroups-results
+
+(defn on-unhealthy-targetgroups-results-clicked []
+ (when (-> (jquery "#unhealthy-targetgroups-form")
+ (.get "0")
+ (.checkValidity))
+ (dommy/set-html! (dommy/sel1 :#results) (template-generic-wait))
+ (render-unhealthy-targetgroups-results)))
+
+(hiccups/defhtml template-unhealthy-targetgroups-results [jsonobj]
+ [:h5 {:style "text-align: center"}
+ "Process started in background. See the output at " [:code (get jsonobj "stdout")]])
+
+(defn handler-unhealthy-targetgroups-results [response]
+ (let [jsonobj (js->clj (js/JSON.parse response))]
+ (notifications jsonobj)
+ (dommy/set-html! (dommy/sel1 :#results) (template-unhealthy-targetgroups-results jsonobj))))
+
+(defn render-unhealthy-targetgroups-results []
+ (POST "/unhealthy-targetgroups/results" {:format :raw
+ :params {:profile (dommy/value (dommy/sel1 :#profile))
+ :region (dommy/value (dommy/sel1 :#region))
+ :filter (dommy/value (dommy/sel1 :#filter))}
+ :handler handler-unhealthy-targetgroups-results}))
+
;; tfcloud-apply
(hiccups/defhtml template-tfcloud-apply [jsonobj]
@@ -676,6 +742,7 @@
(cond (= handler "/home") (render-home))
(cond (= handler "/git-update") (render-git-update))
(cond (= handler "/asg-recycle") (render-asg-recycle))
+ (cond (= handler "/unhealthy-targetgroups") (render-unhealthy-targetgroups))
(cond (= handler "/tfcloud-apply") (render-tfcloud-apply))
(cond (= handler "/octopus-machines-with-roles") (render-octopus-machines-with-roles))
(cond (= handler "/octopus-environments-with-roles") (render-octopus-environments-with-roles))
diff --git a/lisp/webapps/snow/site.lisp b/lisp/webapps/snow/site.lisp
index 868a188..d1091ad 100644
--- a/lisp/webapps/snow/site.lisp
+++ b/lisp/webapps/snow/site.lisp
@@ -68,6 +68,15 @@
(defmacro .asg-recycle-results-submit ()
`(asg-recycle-results-submit-json howmany))
+(defmacro .unhealthy-targetgroups ()
+ `(unhealthy-targetgroups-json))
+
+(defmacro .unhealthy-targetgroups-view ()
+ `(unhealthy-targetgroups-view-json))
+
+(defmacro .unhealthy-targetgroups-results ()
+ `(unhealthy-targetgroups-results-json profile region filter))
+
(defmacro .tfcloud-apply ()
`(tfcloud-apply-json))
@@ -137,6 +146,9 @@
(define-endpoint :get "/asg-recycle/view" () .asg-recycle-view)
(define-endpoint :post "/asg-recycle/results" ((profile :parameter-type 'string) (region :parameter-type 'string) (filter :parameter-type 'string)) .asg-recycle-results)
(define-endpoint :post "/asg-recycle/results/submit" ((howmany :parameter-type 'string)) .asg-recycle-results-submit)
+(define-endpoint :get "/unhealthy-targetgroups" () .unhealthy-targetgroups)
+(define-endpoint :get "/unhealthy-targetgroups/view" () .unhealthy-targetgroups-view)
+(define-endpoint :post "/unhealthy-targetgroups/results" ((profile :parameter-type 'string) (region :parameter-type 'string) (filter :parameter-type 'string)) .unhealthy-targetgroups-results)
(define-endpoint :get "/tfcloud-apply" () .tfcloud-apply)
(define-endpoint :get "/tfcloud-apply/view" () .tfcloud-apply-view)
(define-endpoint :post "/tfcloud-apply/results" ((filter :parameter-type 'string)) .tfcloud-apply-results)
generated by cgit v1.3 (git 2.53.0) at 2026-09-24 16:55:56 +0000