Improving deployment process.

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

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

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)