From 908938dd41d35b07286495c742fb81359bf85fd1 Mon Sep 17 00:00:00 2001 From: Thomas Hintz Date: Wed, 12 Nov 2025 13:22:25 -0800 Subject: [PATCH] Improving deployment progress status handling. --- Makefile | 9 +++- src/db.scm | 74 ++++++++++++++++++++++++++++++++ src/nassella.scm | 109 ++++++++++++++++++++++++++--------------------- 3 files changed, 141 insertions(+), 51 deletions(-) diff --git a/Makefile b/Makefile index 5864fe6..9d391b2 100644 --- a/Makefile +++ b/Makefile @@ -61,8 +61,13 @@ generated.tfvars: $(apps_config) make-generated.sh plan: ignition.json $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars bash -c "terraform plan -var-file=<(cat $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars)" -apply: ignition.json $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars - bash -c "terraform apply -auto-approve -var-file=<(cat $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars)" +.PHONY: announce-start +announce-start: + echo "NASSELLA_CONFIG: start" + +apply: announce-start ignition.json $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars + echo "NASSELLA_CONFIG: end" + bash -c "terraform apply -auto-approve -input=false -var-file=<(cat $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars)" destroy: ignition.json $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars bash -c "terraform destroy -var-file=<(cat $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars)" diff --git a/src/db.scm b/src/db.scm index 1304449..35f20d5 100644 --- a/src/db.scm +++ b/src/db.scm @@ -14,6 +14,8 @@ update-deployment-status get-deployment-status get-most-recent-deployment-status update-deployment-in-progress + update-deployment-progress get-deployment-progress + get-most-recent-deployment-progress update-user-terraform-state get-user-terraform-state ) @@ -322,6 +324,75 @@ returning users.user_id;" (define (get-most-recent-deployment-status conn user-id) (value-at (query conn "select status from deployments where user_id=$1 order by id DESC limit 1;" user-id))) +(define *deployments-column-map* + '((generate-configs . "generate_configs") + (custom-image . "terraform_custom_image") + (machine-create . "terraform_machine_create") + (machine-destroy . "terraform_machine_destroy"))) + +(define *deployments-reverse-column-map* + (map (lambda (config) + `(,(string->symbol (cdr config)) . ,(car config))) + *deployments-column-map*)) + +(define (update-deployment-progress conn deployment-id progress-alist) + (let ((valid-keys (map car *deployments-column-map*))) + (for-each (lambda (progress) + (if (not (memq (car progress) valid-keys)) + (error (string-append "Not a valid progress key: " (->string (car progress)))))) + progress-alist)) + (query* conn + (string-append + "update deployments set " + (string-intersperse + (map-in-order (lambda (progress i) + (conc (alist-ref (car progress) *deployments-column-map*) + "=$" i)) + progress-alist + (iota (length progress-alist) 2)) + ", ") + " where id=$1;") + (cons deployment-id + (map-in-order (lambda (progress) (alist-ref (cdr progress) *deployment-status*)) progress-alist)))) + +(define (get-deployment-progress conn deployment-id) + (let ((res (row-alist + (query conn + (string-append + "select " + (string-intersperse + (map-in-order cdr *deployments-column-map*) + ", ") + " from deployments where id=$1;") + deployment-id)))) + (map (lambda (item) + (let* ((key (car item)) + (value (cdr item)) + (config (alist-ref key *deployments-reverse-column-map*))) + `(,config . ,(if (sql-null? value) + #f + (string->symbol value))))) + res))) + +(define (get-most-recent-deployment-progress conn user-id) + (let ((res (row-alist + (query conn + (string-append + "select " + (string-intersperse + (map-in-order cdr *deployments-column-map*) + ", ") + " from deployments where user_id=$1 order by id DESC limit 1;") + user-id)))) + (map (lambda (item) + (let* ((key (car item)) + (value (cdr item)) + (config (alist-ref key *deployments-reverse-column-map*))) + `(,config . ,(if (sql-null? value) + #f + (string->symbol value))))) + res))) + (define (update-user-terraform-state conn user-id state backup) (receive (user-key user-iv auth-user-id) (get-decrypted-user-key-and-iv conn user-id) @@ -344,6 +415,9 @@ returning users.user_id;" "" (user-decrypt-from-db (alist-ref 'state_backup_enc res) user-key user-iv user-id))))))) +;; (with-db/transaction (lambda (db) (get-most-recent-deployment-progress db 7))) +;; (with-db/transaction (lambda (db) (get-deployment-progress db 14))) +;; (with-db/transaction (lambda (db) (update-deployment-progress db 14 '((generate-configs . complete) (custom-image . in-progress) (machine-create . queued))))) ;; (with-db/transaction ;; (lambda (db) ;; (update-user-terraform-state db 7 diff --git a/src/nassella.scm b/src/nassella.scm index a6a90ab..140e985 100644 --- a/src/nassella.scm +++ b/src/nassella.scm @@ -771,6 +771,19 @@ h1, h2, h3, h4, h5, h6 { (with-output-to-file (string-append dir "/terraform.tfstate") (lambda () (write-string state))) (with-output-to-file (string-append dir "/terraform.tfstate.backup") (lambda () (write-string state-backup)))) +(define (parse-deployment-log log) + (define (search complete in-progress) + (cond ((irregex-search complete log) + 'complete) + ((irregex-search in-progress log) + 'in-progress) + (else 'queued))) + `((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start")) + (custom-image . ,(search "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Modifying")) + (machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating...")) + (machine-destroy . ,(search "droplet.machine: Destruction complete" + '(: "droplet.machine (deposed object " (* alphanum) "): Destroying..."))))) + (define (write-config-entry name value) (display name) (display "=\"") @@ -843,31 +856,55 @@ h1, h2, h3, h4, h5, h6 { (with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid))) (change-directory "../") (let loop () - (thread-sleep! 1) + (thread-sleep! 5) (receive (pid exit-normal status) (process-wait pid #t) (if (= pid 0) - (loop) - (with-db/transaction - (lambda (db) - ;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES - ;; like the random digital ocean error saying the IP can't be - ;; updated because another operation is in progress. - ;; it still registers as "success". - ;; probably need to also write stderr to a file and read/store/parse that? - ;; Should we parse make-out for string "Apply complete!" ? - (update-deployment-status - db user-id deployment-id - (if exit-normal 'complete 'failed) - (with-input-from-file (string-append dir "/make-out") read-string)) - (update-user-terraform-state db user-id - (with-input-from-file (string-append dir "/terraform.tfstate") read-string) - (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string))))))))))) + (begin (let ((progress (parse-deployment-log + (with-input-from-file + (string-append (deployment-directory user-id) "/make-out") + read-string)))) + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id progress)))) + (loop)) + (let ((progress (parse-deployment-log + (with-input-from-file + (string-append (deployment-directory user-id) "/make-out") + read-string)))) + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id progress) + ;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES + ;; like the random digital ocean error saying the IP can't be + ;; updated because another operation is in progress. + ;; it still registers as "success". + ;; probably need to also write stderr to a file and read/store/parse that? + ;; Should we parse make-out for string "Apply complete!" ? + (update-deployment-status + db user-id deployment-id + (if exit-normal 'complete 'failed) + (with-input-from-file (string-append dir "/make-out") read-string)) + (update-user-terraform-state db user-id + (with-input-from-file (string-append dir "/terraform.tfstate") read-string) + (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))))))))))) (schematra:redirect "/config/wizard/success")) +(define (progress-status->text status) + (case status + ((queued) "queued") + ((in-progress) "in progress") + ((complete) "complete") + ((failed) "failed"))) + (get ("/config/wizard/success") - (let ((status (with-db/transaction (lambda (db) (get-most-recent-deployment-status db (session-get "user-id"))))) - (output (with-input-from-file (string-append (deployment-directory (session-get "user-id")) "/make-out") read-string))) + (let* ((res (with-db/transaction + (lambda (db) + `((status . ,(get-most-recent-deployment-status db (session-get "user-id"))) + (progress . ,(get-most-recent-deployment-progress db (session-get "user-id"))))))) + (output (with-input-from-file (string-append (deployment-directory (session-get "user-id")) "/make-out") read-string)) + (progress (alist-ref 'progress res)) + (status (alist-ref 'status res))) `(VStack (h1 ,(case (string->symbol status) @@ -875,36 +912,10 @@ h1, h2, h3, h4, h5, h6 { ((in-progress) "Deployment in progress") ((complete) "Deployment complete!") ((failed) "Deployment failed"))) - (ul (li "generate configs: " - ,(cond ((irregex-search "terraform apply" output) - "complete") - ((irregex-search "mkdir -p all-apps/lb" output) - "in progress") - (else "queued"))) - (li "resource deployment: " - ,(cond ((irregex-search "Apply complete" output) - "complete") - ((irregex-search "terraform apply" output) - "in progress") - (else "queued"))) - (li "custom flatcar image: " - ,(cond ((irregex-search "custom_image.flatcar: Modifications complete" output) - "complete") - ((irregex-search "custom_image.flatcar: Modifying" output) - "in progress") - (else "queued"))) - (li "machine create: " - ,(cond ((irregex-search "droplet.machine: Creation complete" output) - "complete") - ((irregex-search "droplet.machine: Creating..." output) - "in progress") - (else "queued"))) - (li "cleanup previous machine: " - ,(cond ((irregex-search "droplet.machine: Destruction complete" output) - "complete") - ((irregex-search '(: "droplet.machine (deposed object " (* alphanum) "): Destroying...") output) - "in progress") - (else "queued")))) + (ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress))) + (li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress))) + (li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress))) + (li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress)))) (pre ,output) )))