diff --git a/src/db-init.sql b/src/db-init.sql index aee491b..7ef7fe1 100644 --- a/src/db-init.sql +++ b/src/db-init.sql @@ -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); diff --git a/src/db.scm b/src/db.scm index 7f35612..1532ba5 100644 --- a/src/db.scm +++ b/src/db.scm @@ -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)) diff --git a/src/nassella.scm b/src/nassella.scm index 948741b..0e0a7e1 100644 --- a/src/nassella.scm +++ b/src/nassella.scm @@ -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)