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

Supporting adjust volume size & pre-update backups.

Browse Source
This commit is contained in:
Thomas Hintz
2026-06-17 12:01:35 -07:00
parent d1e8e0b5dc
commit 7df2c07313
16 changed files with 175 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files

102
src/nassella.scm
View File

@@ -723,23 +723,31 @@ h1, h2, h3, h4, h5, h6 {
(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)
(define (search complete in-progress failed)
(cond ((irregex-search failed log)
'failed)
((irregex-search complete log)
'complete)
((irregex-search in-progress log)
'in-progress)
(else 'queued)))
`((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start"))
`((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start" "Failed to install provider"))
;; TODO this didn't seem to work right when upgrading the flatcar image
;; log: [0mdigitalocean_custom_image.flatcar: Creating...
;; digitalocean_custom_image.flatcar: Still creating... [00m10s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m20s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m30s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m40s elapsed]
(custom-image . ,(search "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Modifying"))
(machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..."))
(custom-image . ,(search '(or "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Creation complete")
'(or "custom_image.flatcar: Modifying" "custom_image.flatcar: Creating")
"XXX - nothing"))
(machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..." "XXX - nothing"))
(machine-destroy . ,(search "droplet.machine: Destruction complete"
'(: "droplet.machine (deposed object " (* alphanum) "): Destroying...")))))
'(: "droplet.machine (deposed object " (* alphanum) "): Destroying...") "XXX - nothing"))
(ip-destroy . ,(search "reserved_ip_assignment.machine: Destruction complete" "reserved_ip_assignment.machine: Destroying..." "XXX - nothing"))
(ip-create . ,(search "reserved_ip_assignment.machine: Creation complete" "reserved_ip_assignment.machine: Creating..." "Error Assigning reserved IP"))
(volume-create . ,(search "volume_attachment.machine: Creation complete" "volume_attachment.machine: Creating..." "XXX - nothing"))
(volume-destroy . ,(search "volume_attachment.machine: Destruction complete" "volume_attachment.machine: Destroying..." "XXX - nothing"))))
(define (write-config-entry name value)
(display name)
@@ -1318,7 +1326,9 @@ chmod -R 777 /opt/keys")))
(method POST))
(VStack
(Fieldset
(@ (title "Size"))
(@ (title "Instance Properties"))
(Field (@ (name "volume-size") (label ("Volume Size in GB (For persistent application storage)"))
(value ,(alist-ref 'digitalocean-volume-size config eq? "60"))))
(Field (@ (element select) (name "size") (input-style ((max-width "100%"))))
,@(map (lambda (s) `(option (@ (value ,(alist-ref 'slug s))
,@(if (equal? (alist-ref 'slug s) "s-2vcpu-2gb") `((selected "selected")) '()))
@@ -1338,7 +1348,8 @@ chmod -R 777 /opt/keys")))
db
(session-user-id)
instance-id
`((digitalocean-size . ,(alist-ref 'size (current-params)))))))
`((digitalocean-size . ,(alist-ref 'size (current-params)))
(digitalocean-volume-size . ,(alist-ref 'volume-size (current-params)))))))
(redirect (conc "/config/wizard/review/" instance-id))))
(get/widgets
@@ -1375,6 +1386,7 @@ chmod -R 777 /opt/keys")))
(li "Size: " ,(alist-ref 'digitalocean-size service-config)))
(form
(@ (action ,(conc "/config/wizard/review-submit/" instance-id)) (method POST))
(input (@ (type "hidden") (value ,(alist-ref 'force (current-params))) (name "force")))
(VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch")))))))))
@@ -1386,7 +1398,8 @@ chmod -R 777 /opt/keys")))
(with-db/transaction
(lambda (db)
(get-most-recent-deployment-status db (session-user-id) instance-id)))))))
(when (not (or (eq? status 'queued) (eq? status 'in-progress)))
(when (or (not (or (eq? status 'queued) (eq? status 'in-progress)))
(equal? (alist-ref 'force (current-params)) "true"))
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(restic-snapshot-id (alist-ref 'restic-snapshot-id (current-params)))
(results
@@ -1466,21 +1479,66 @@ chmod -R 777 /opt/keys")))
(write-config-entry (car e) (cdr e)))
`(("server_type" . ,(alist-ref 'digitalocean-size service-config))
("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
("digitalocean_volume_size" . ,(alist-ref 'digitalocean-volume-size service-config))
("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
("cluster_name" . "nassella")
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
("flatcar_stable_version" . "4593.2.1")))
("flatcar_stable_version" . "4593.2.2")))
;; remove the newline that generating the ssh key adds
(display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]"))))
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(user-id (session-user-id))
(app-config
(with-db/transaction
(lambda (db)
(get-user-app-config db (session-user-id) instance-id))))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
(dir (deployment-directory user-id instance-id)))
(dir (deployment-directory user-id instance-id))
(backup-request-id (conc (truncate (time->seconds (current-time))) "-" (pseudo-random-integer 10000))))
(with-db/transaction
(lambda (db)
(update-deployment-progress db deployment-id '((instance-backup . in-progress)))))
(handle-exceptions
exn
(with-db/transaction
(lambda (db)
(update-deployment-progress db deployment-id '((instance-backup . failed)))))
(send-instance-control-command
(alist-ref 'root-domain app-config)
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
"queue-restic-snapshot-no-restart"
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
`((path . "/")
(tag . "automated_pre_instance_update")
;; effectively a guid, we just want something unique
(request_id . ,backup-request-id)
(version . 0))))
(thread-start!
(lambda ()
;; TODO add a timeout and set status to failed and error if we hit the timeout
(let ((start-time (time->seconds (current-time))))
(let loop ()
(thread-sleep! 1)
(let* ((status-result
(handle-exceptions
exn
'((status . "error"))
(send-instance-control-command
(alist-ref 'root-domain app-config)
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
"restic-snapshot-status"
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
`((request_id . ,backup-request-id)
(version . 0)))))
(complete (string=? (alist-ref 'status status-result) "complete")))
(if (or complete (> (- (time->seconds (current-time)) start-time) 45))
(with-db/transaction
(lambda (db)
(update-deployment-progress db deployment-id `((instance-backup . ,(or (and complete 'complete) 'failed))))))
(loop)))))
(change-directory dir)
(let ((pid (process-run "make apply > make-out 2>&1")))
(with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
@@ -1512,15 +1570,9 @@ chmod -R 777 /opt/keys")))
(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.
;; it still registers as "success".
;; probably need to also write stderr to a file and read/store/parse that?
;; Should we parse make-out for string "Apply complete!" ?
(update-deployment-status
db user-id deployment-id
(if exit-normal 'complete 'failed)
(if (= status 0) 'complete 'failed)
(with-input-from-file (string-append dir "/make-out") read-string))
(update-user-terraform-state db user-id instance-id
(if (eof-object? tf-state) "" tf-state)
@@ -1542,7 +1594,7 @@ chmod -R 777 /opt/keys")))
(lambda (db)
`((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))
(progress . ,(get-most-recent-deployment-progress db (session-user-id) instance-id))))))
(output (with-input-from-file (string-append (deployment-directory (session-user-id) instance-id) "/make-out") read-string))
(output (handle-exceptions exn "" (with-input-from-file (string-append (deployment-directory (session-user-id) instance-id) "/make-out") read-string)))
(progress (alist-ref 'progress res))
(status (alist-ref 'status res)))
`(App
@@ -1554,9 +1606,14 @@ chmod -R 777 /opt/keys")))
((in-progress) "Deployment in progress")
((complete) "Deployment complete!")
((failed) "Deployment failed")))
(ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
(ul (li "perform backup: " ,(progress-status->text (alist-ref 'instance-backup progress)))
(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 "application volume disconnect: " ,(progress-status->text (alist-ref 'volume-destroy progress)))
(li "instance create: " ,(progress-status->text (alist-ref 'machine-create progress)))
(li "instance mapped ip disconnect: " ,(progress-status->text (alist-ref 'ip-destroy progress)))
(li "instance mapped ip connect: " ,(progress-status->text (alist-ref 'ip-create progress)))
(li "application volume connect: " ,(progress-status->text (alist-ref 'volume-create progress)))
(li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
(div
(a (@ (href "/dashboard")) "Dashboard")
@@ -1733,7 +1790,7 @@ chmod -R 777 /opt/keys")))
("cluster_name" . "nassella")
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
("flatcar_stable_version" . "4593.2.1")))
("Flatcar_stable_version" . "4593.2.2")))
;; remove the newline that generating the ssh key adds
(display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]")))
;; TODO need a new table to track destroying?
@@ -1825,6 +1882,7 @@ chmod -R 777 /opt/keys")))
`((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 "attaching : " ,(progress-status->text (alist-ref 'machine-create progress)))
(li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
(div
(a (@ (href "/dashboard")) "Dashboard")