nassella/app
1
0
Fork 0
Code Issues 26 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 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( create table deployments(
id bigserial primary key, 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") '((queued . "queued")
(in-progress . "in-progress") (in-progress . "in-progress")
(complete . "complete") (complete . "complete")
(failed . "failed"))) (failed . "failed")
(ignored . "ignored")))
(define (create-deployment conn user-id instance-id) (define (create-deployment conn user-id instance-id)
(value-at (value-at
(query conn (query conn
@@ -660,7 +661,8 @@ where user_id=$1;"
(5 . "adding-wordpress-app") (5 . "adding-wordpress-app")
(6 . "adding-lldap-app") (6 . "adding-lldap-app")
(7 . "adding-authelia-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) (define (run-pending-migrations conn)
(let* ((migration-ids (sort (map car *migrations*) <)) (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 (with-db/transaction
(lambda (db) (lambda (db)
(get-user-app-config db (session-user-id) instance-id)))) (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)))) (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)))) (backup-request-id (conc (truncate (time->seconds (current-time))) "-" (pseudo-random-integer 10000))))
(with-db/transaction (if first-deployment?
(lambda (db) (with-db/transaction
(update-deployment-progress db deployment-id '((instance-backup . in-progress))))) (lambda (db)
;; ;; TODO does this handle new deployments? We should not do a back up if this is new! (update-deployment-progress db deployment-id '((instance-backup . ignored)
(handle-exceptions (machine-destroy . ignored)
exn (ip-destroy . ignored)
(with-db/transaction (volume-destroy . ignored)))))
(lambda (db) (begin
(update-deployment-progress db deployment-id '((instance-backup . failed))))) (with-db/transaction
(send-instance-control-command (lambda (db)
(alist-ref 'root-domain app-config) (update-deployment-progress db deployment-id '((instance-backup . in-progress)))))
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config))) (handle-exceptions
"queue-restic-snapshot-no-restart" exn
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config))) (with-db/transaction
`((path . "/") (lambda (db)
(tag . "automated_pre_instance_update") (update-deployment-progress db deployment-id '((instance-backup . failed)))))
;; effectively a guid, we just want something unique (send-instance-control-command
(request_id . ,backup-request-id) (alist-ref 'root-domain app-config)
(version . 0)))) (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! (thread-start!
(lambda () (lambda ()
(let ((start-time (time->seconds (current-time)))) (when (not first-deployment?)
(let loop () (let ((start-time (time->seconds (current-time))))
(thread-sleep! 1) (let loop ()
(let* ((status-result (thread-sleep! 1)
(handle-exceptions (let* ((status-result
exn (handle-exceptions
'((status . "error")) exn
(send-instance-control-command '((status . "error"))
(alist-ref 'root-domain app-config) (send-instance-control-command
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config))) (alist-ref 'root-domain app-config)
"restic-snapshot-status" (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config))) "restic-snapshot-status"
`((request_id . ,backup-request-id) (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
(version . 0))))) `((request_id . ,backup-request-id)
(complete (string=? (alist-ref 'status status-result) "complete"))) (version . 0)))))
(if (or complete (> (- (time->seconds (current-time)) start-time) 120)) (complete (string=? (alist-ref 'status status-result) "complete")))
(with-db/transaction (if (or complete (> (- (time->seconds (current-time)) start-time) 120))
(lambda (db) (with-db/transaction
(update-deployment-progress db deployment-id `((instance-backup . ,(or (and complete 'complete) 'failed)))))) (lambda (db)
(loop))))) (update-deployment-progress db deployment-id `((instance-backup . ,(or (and complete 'complete) 'failed))))))
(loop))))))
(change-directory dir) (change-directory dir)
(let ((pid (process-run "make preapply && make apply > make-out 2>&1"))) (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))) (with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
@@ -2034,10 +2043,12 @@ chmod -R 777 /opt/keys")))
((complete) "Complete!") ((complete) "Complete!")
((failed) "Failed")))) ((failed) "Failed"))))
(ul ,@(map (lambda (x) (ul ,@(map (lambda (x)
`(li (HStack (@ (style ((align-items "center") (if (eq? (alist-ref (car x) progress) 'ignored)
(margin-bottom ,($ 'gap.gutter))))) '()
(Deployment-Status-Pill (@ (status ,(alist-ref (car x) progress)))) `((li (HStack (@ (style ((align-items "center")
,(cdr x)))) (margin-bottom ,($ 'gap.gutter)))))
(Deployment-Status-Pill (@ (status ,(alist-ref (car x) progress))))
,(cdr x))))))
'((instance-backup . "Backup Instance") '((instance-backup . "Backup Instance")
(generate-configs . "Generate Custom Image") (generate-configs . "Generate Custom Image")
(custom-image . "Upload Flatcar Image") (custom-image . "Upload Flatcar Image")