nassella/app
1
0
Fork 0
Code Issues 15 Pull Requests Packages Projects 1 Releases Wiki Activity

Improving deployment progress status handling.

Browse Source
This commit is contained in:
Thomas Hintz
2025-11-12 13:22:25 -08:00
parent b781ddb5d7
commit 908938dd41
3 changed files with 141 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

109
src/nassella.scm
View File

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