nassella/app
1
0
Fork 0
Code Issues Pull Requests Packages Projects 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

74
src/db.scm
View File

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

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