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

Don't try to make a backup on inital deployment.

Browse Source
This commit is contained in:
Thomas Hintz
2026-07-25 11:00:20 -07:00
parent 2721249a89
commit 9f89356c85
4 changed files with 60 additions and 46 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/db-init.sql
View File

@@ -93,7 +93,7 @@ create table user_app_configs(
create unique index user_app_configs_user_id_instance_id_idx on user_app_configs (user_id, instance_id);
create type deployment_status as enum ('queued', 'in-progress', 'complete', 'failed');
create type deployment_status as enum ('ignored', 'queued', 'in-progress', 'complete', 'failed');
create table deployments(
id bigserial primary key,

6
src/db.scm
View File

@@ -378,7 +378,8 @@ where usa.user_id=$1 and usa.instance_id=$2;"
'((queued . "queued")
(in-progress . "in-progress")
(complete . "complete")
(failed . "failed")))
(failed . "failed")
(ignored . "ignored")))
(define (create-deployment conn user-id instance-id)
(value-at
(query conn
@@ -660,7 +661,8 @@ where user_id=$1;"
(5 . "adding-wordpress-app")
(6 . "adding-lldap-app")
(7 . "adding-authelia-app")
(8 . "adding-backblaze-bucket-name-and-id")))
(8 . "adding-backblaze-bucket-name-and-id")
(9 . "extend-deployment-status-add-ignored")))
(define (run-pending-migrations conn)
(let* ((migration-ids (sort (map car *migrations*) <))

1
src/migrations/9-extend-deployment-status-add-ignored-up.sql Normal file
View File

@@ -0,0 +1 @@
alter type deployment_status add value 'ignored';

97
src/nassella.scm
View File

@@ -1915,50 +1915,59 @@ chmod -R 777 /opt/keys")))
(with-db/transaction
(lambda (db)
(get-user-app-config db (session-user-id) instance-id))))
(first-deployment? (not (with-db/transaction (lambda (db) (get-most-recent-deployment-status db 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))
(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)))))
;; ;; TODO does this handle new deployments? We should not do a back up if this is new!
(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))))
(if first-deployment?
(with-db/transaction
(lambda (db)
(update-deployment-progress db deployment-id '((instance-backup . ignored)
(machine-destroy . ignored)
(ip-destroy . ignored)
(volume-destroy . ignored)))))
(begin
(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 ()
(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) 120))
(with-db/transaction
(lambda (db)
(update-deployment-progress db deployment-id `((instance-backup . ,(or (and complete 'complete) 'failed))))))
(loop)))))
(when (not first-deployment?)
(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) 120))
(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 preapply && make apply > make-out 2>&1")))
(with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
@@ -2034,10 +2043,12 @@ chmod -R 777 /opt/keys")))
((complete) "Complete!")
((failed) "Failed"))))
(ul ,@(map (lambda (x)
`(li (HStack (@ (style ((align-items "center")
(margin-bottom ,($ 'gap.gutter)))))
(Deployment-Status-Pill (@ (status ,(alist-ref (car x) progress))))
,(cdr x))))
(if (eq? (alist-ref (car x) progress) 'ignored)
'()
`((li (HStack (@ (style ((align-items "center")
(margin-bottom ,($ 'gap.gutter)))))
(Deployment-Status-Pill (@ (status ,(alist-ref (car x) progress))))
,(cdr x))))))
'((instance-backup . "Backup Instance")
(generate-configs . "Generate Custom Image")
(custom-image . "Upload Flatcar Image")