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

Improving deployment process.

Browse Source
This commit is contained in:
Thomas Hintz
2025-11-12 05:42:25 -08:00
parent fb9c3f8daf
commit 5d256e5cf8
3 changed files with 128 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

88
src/nassella.scm
View File

@@ -6,8 +6,10 @@
(chicken pretty-print)
(chicken process)
(chicken process-context)
(chicken irregex)
(rename srfi-1 (delete srfi1:delete))
srfi-18
html-widgets
sxml-transforms
@@ -813,31 +815,79 @@ h1, h2, h3, h4, h5, h6 {
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
("flatcar_stable_version" . "4230.2.3")))
(display "ssh_keys=[\"") (display (with-input-from-file "deploy/config/ssh-keys" read-string)) (print "\"]"))))
(change-directory "deploy")
(session-set! "pid" (process-run "make apply > make-out"))
(change-directory "../")
(let* ((user-id (session-get "user-id"))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id)))))
(thread-start!
(lambda ()
(change-directory "deploy")
(let ((pid (process-run "make apply > make-out")))
(with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
(change-directory "../")
(let loop ()
(thread-sleep! 1)
(receive (pid exit-normal status) (process-wait pid #t)
(if (= pid 0)
(loop)
(with-db/transaction
(lambda (db)
(update-deployment-status
db deployment-id
(if exit-normal 'complete 'failed)))))))))))
(schematra:redirect "/config/wizard/success"))
(get
("/config/wizard/success")
(receive (pid exit-normal status) (process-wait (session-get "pid") #t) ;; TODO should not rely on the user refreshing page to process-wait since that could create zombie
(let ((status (with-db/transaction (lambda (db) (get-most-recent-deployment-status db (session-get "user-id")))))
(output (with-input-from-file "deploy/make-out" (lambda () (read-string)))))
`(VStack
(h1
,(if (= pid 0)
"Deployment in progress"
(if exit-normal
"Deployment complete!"
"Deployment failed")))
,@(intersperse
(with-input-from-file "deploy/make-out"
(lambda ()
(letrec ((loop (lambda (out)
(let ((v (read-line)))
(if (eq? v #!eof)
out
(loop (cons v out)))))))
(reverse (loop '())))))
`(br)))))
,(case (string->symbol status)
((queued) "Deployment queued")
((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"))))
(pre ,output)
;; ,@(intersperse
;; (with-input-from-file "deploy/make-out"
;; (lambda ()
;; (letrec ((loop (lambda (out)
;; (let ((v (read-line)))
;; (if (eq? v #!eof)
;; out
;; (loop (cons v out)))))))
;; (reverse (loop '())))))
;; `(br))
)))
(schematra:schematra-install)
(schematra:schematra-start)