Improving deployment progress status handling.

Makefile

@@ -61,8 +61,13 @@ generated.tfvars: $(apps_config) make-generated.sh
 plan: ignition.json $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars
 	bash -c "terraform plan -var-file=<(cat $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars)"
 
-apply: ignition.json $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars
-	bash -c "terraform apply -auto-approve -var-file=<(cat $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars)"
+.PHONY: announce-start
+announce-start:
+	echo "NASSELLA_CONFIG: start"
+
+apply: announce-start ignition.json $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars
+	echo "NASSELLA_CONFIG: end"
+	bash -c "terraform apply -auto-approve -input=false -var-file=<(cat $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars)"
 
 destroy: ignition.json $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars
 	bash -c "terraform destroy -var-file=<(cat $(config_dir)$(TERRAFORM_ENV).tfvars generated.tfvars)"

src/db.scm

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

src/nassella.scm

@@ -771,6 +771,19 @@ h1, h2, h3, h4, h5, h6 {
   (with-output-to-file (string-append dir "/terraform.tfstate") (lambda () (write-string state)))
   (with-output-to-file (string-append dir "/terraform.tfstate.backup") (lambda () (write-string state-backup))))
 
+(define (parse-deployment-log log)
+  (define (search complete in-progress)
+    (cond ((irregex-search complete log)
+           'complete)
+          ((irregex-search in-progress log)
+           'in-progress)
+          (else 'queued)))
+  `((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start"))
+    (custom-image . ,(search "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Modifying"))
+    (machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..."))
+    (machine-destroy . ,(search "droplet.machine: Destruction complete"
+                                '(: "droplet.machine (deposed object " (* alphanum) "): Destroying...")))))
+
 (define (write-config-entry name value)
   (display name)
   (display "=\"")
@@ -843,12 +856,24 @@ h1, h2, h3, h4, h5, h6 {
         (with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
         (change-directory "../")
         (let loop ()
-          (thread-sleep! 1)
+          (thread-sleep! 5)
           (receive (pid exit-normal status) (process-wait pid #t)
             (if (= pid 0)
-                (loop)
+                (begin (let ((progress (parse-deployment-log
+                                        (with-input-from-file
+                                            (string-append (deployment-directory user-id) "/make-out")
+                                          read-string))))
+                         (with-db/transaction
+                          (lambda (db)
+                            (update-deployment-progress db deployment-id progress))))
+                       (loop))
+                (let ((progress (parse-deployment-log
+                                        (with-input-from-file
+                                            (string-append (deployment-directory user-id) "/make-out")
+                                          read-string))))
                   (with-db/transaction
                    (lambda (db)
+                     (update-deployment-progress db deployment-id progress)
                      ;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES
                      ;; like the random digital ocean error saying the IP can't be
                      ;; updated because another operation is in progress.
@@ -861,13 +886,25 @@ h1, h2, h3, h4, h5, h6 {
                       (with-input-from-file (string-append dir "/make-out") read-string))
                      (update-user-terraform-state db user-id
                                                   (with-input-from-file (string-append dir "/terraform.tfstate") read-string)
-                                                (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))))))))))
+                                                  (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string))))))))))))
   (schematra:redirect "/config/wizard/success"))
 
+(define (progress-status->text status)
+  (case status
+    ((queued) "queued")
+    ((in-progress) "in progress")
+    ((complete) "complete")
+    ((failed) "failed")))
+
 (get
  ("/config/wizard/success")
- (let ((status (with-db/transaction (lambda (db) (get-most-recent-deployment-status db (session-get "user-id")))))
-       (output (with-input-from-file (string-append (deployment-directory (session-get "user-id")) "/make-out") read-string)))
+ (let* ((res (with-db/transaction
+              (lambda (db)
+                `((status . ,(get-most-recent-deployment-status db (session-get "user-id")))
+                  (progress . ,(get-most-recent-deployment-progress db (session-get "user-id")))))))
+        (output (with-input-from-file (string-append (deployment-directory (session-get "user-id")) "/make-out") read-string))
+        (progress (alist-ref 'progress res))
+        (status (alist-ref 'status res)))
    `(VStack
      (h1
       ,(case (string->symbol status)
@@ -875,36 +912,10 @@ h1, h2, h3, h4, h5, h6 {
          ((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"))))
+     (ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
+         (li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
+         (li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress)))
+         (li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
      (pre ,output)
      )))