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

24
src/db-init.sql
View File

@@ -39,3 +39,27 @@ create table user_app_configs(
);
create unique index user_app_configs_user_id_idx on user_app_configs (user_id);
create type deployment_status as enum ('queued', 'in-progress', 'complete', 'failed');
create table deployments(
id bigserial primary key,
user_id integer not null references users on delete cascade,
started timestamptz,
finished timestamptz,
status deployment_status not null default 'queued',
pid integer,
generate_configs deployment_status not null default 'queued',
terraform_custom_image deployment_status not null default 'queued',
terraform_dns deployment_status not null default 'queued',
terraform_volume_create deployment_status not null default 'queued',
terraform_volume_destroy deployment_status not null default 'queued',
terraform_machine_create deployment_status not null default 'queued',
terraform_machine_destroy deployment_status not null default 'queued',
terraform_ip_create deployment_status not null default 'queued',
terraform_ip_destroy deployment_status not null default 'queued',
log_enc text
);
create index deployments_user_id_idx on deployments (user_id);

35
src/db.scm
View File

@@ -10,6 +10,10 @@
update-user-selected-apps get-user-selected-apps
update-user-app-config get-user-app-config
update-root-domain
create-deployment
update-deployment-status get-deployment-status
get-most-recent-deployment-status
update-deployment-in-progress
)
(import scheme
@@ -287,6 +291,37 @@ returning users.user_id;"
(user-decrypt-from-db (alist-ref 'config_enc res) user-key user-iv user-id)
read)))))))
(define *deployment-status*
'((queued . "queued")
(in-progress . "in-progress")
(complete . "complete")
(failed . "failed")))
(define (create-deployment conn user-id)
(value-at
(query conn
"insert into deployments(user_id) values($1) returning deployments.id;"
user-id)))
(define (update-deployment-in-progress conn deployment-id pid)
(query conn
"update deployments set status=$1, pid=$2 where id=$3;"
(alist-ref 'in-progress *deployment-status*) pid deployment-id))
(define (update-deployment-status conn deployment-id status)
(query conn "update deployments set status=$1 where id=$2;"
(alist-ref status *deployment-status*) deployment-id))
(define (get-deployment-status conn deployment-id)
(value-at (query conn "select status from deployments where id=$1;" deployment-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)))
;; (with-db/transaction (lambda (db) (create-deployment db 7)))
;; (with-db/transaction (lambda (db) (get-deployment-status db 1)))
;; (with-db/transaction (lambda (db) (update-deployment-in-progress db 1 123)))
;; (with-db/transaction (lambda (db) (update-deployment-status db 1 'complete)))
;; (with-db/transaction (lambda (db) (get-most-recent-deployment-status db 7)))
;; (with-db/transaction (lambda (db) (create-user db 1 "t@thintz.com" "thecombjelly")))
;; (let ((user-id 7))

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)