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