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

Refactor to support multiple instances.

Browse Source
This commit is contained in:
Thomas Hintz
2025-11-30 20:13:51 -08:00
parent e372f2157b
commit 284b4c37f4
4 changed files with 418 additions and 327 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
src/db-init.sql
View File

@@ -4,12 +4,20 @@ create table users(
email varchar(255) not null, email varchar(255) not null,
username varchar(255) not null unique, username varchar(255) not null unique,
key_key varchar(255), key_key varchar(255),
key_iv varchar(255)); key_iv varchar(255)
);
create unique index users_auth_user_id_idx on users (auth_user_id); create unique index users_auth_user_id_idx on users (auth_user_id);
create table instances(
instance_id bigserial primary key,
user_id integer not null references users on delete cascade
);
create unique index instances_user_id_instance_id_idx on instances (instance_id, user_id);
create table user_service_configs( create table user_service_configs(
id bigserial primary key, id bigserial primary key,
user_id integer unique not null references users on delete cascade, user_id integer not null references users on delete cascade,
instance_id integer not null references instances on delete cascade,
cloudflare_api_token_enc varchar(255), cloudflare_api_token_enc varchar(255),
cloudflare_account_id_enc varchar(255), cloudflare_account_id_enc varchar(255),
cloudflare_zone_id_enc varchar(255), cloudflare_zone_id_enc varchar(255),
@@ -20,25 +28,27 @@ create table user_service_configs(
backblaze_key_id_enc varchar(255), backblaze_key_id_enc varchar(255),
backblaze_bucket_url_enc varchar(255) backblaze_bucket_url_enc varchar(255)
); );
create unique index user_service_configs_user_id_idx on user_service_configs (user_id); create unique index user_service_configs_user_id_instance_id_idx on user_service_configs (user_id, instance_id);
create table user_selected_apps( create table user_selected_apps(
id bigserial primary key, id bigserial primary key,
user_id integer unique not null references users on delete cascade, user_id integer not null references users on delete cascade,
instance_id integer not null references instances on delete cascade,
wg_easy_version varchar(100), wg_easy_version varchar(100),
nextcloud_version varchar(100), nextcloud_version varchar(100),
log_viewer_version varchar(100) log_viewer_version varchar(100)
); );
create unique index user_selected_apps_user_id_idx on user_selected_apps (user_id); create unique index user_selected_apps_user_id_instance_id_idx on user_selected_apps (user_id, instance_id);
create table user_app_configs( create table user_app_configs(
id bigserial primary key, id bigserial primary key,
user_id integer unique not null references users on delete cascade, user_id integer not null references users on delete cascade,
instance_id integer not null references instances on delete cascade,
root_domain varchar(100), root_domain varchar(100),
config_enc text config_enc text
); );
create unique index user_app_configs_user_id_idx on user_app_configs (user_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 ('queued', 'in-progress', 'complete', 'failed');
@@ -46,6 +56,7 @@ create type deployment_status as enum ('queued', 'in-progress', 'complete', 'fai
create table deployments( create table deployments(
id bigserial primary key, id bigserial primary key,
user_id integer not null references users on delete cascade, user_id integer not null references users on delete cascade,
instance_id integer not null references instances on delete cascade,
started timestamptz, started timestamptz,
finished timestamptz, finished timestamptz,
status deployment_status not null default 'queued', status deployment_status not null default 'queued',
@@ -62,13 +73,14 @@ create table deployments(
log_enc text log_enc text
); );
create index deployments_user_id_idx on deployments (user_id); create index deployments_user_id_instance_id_idx on deployments (user_id, instance_id);
create table user_terraform_state( create table user_terraform_state(
id bigserial primary key, id bigserial primary key,
user_id integer unique not null references users on delete cascade, user_id integer not null references users on delete cascade,
instance_id integer not null references instances on delete cascade,
state_enc text, state_enc text,
state_backup_enc text state_backup_enc text
); );
create unique index user_terraform_state_user_id_idx on user_terraform_state (user_id); create unique index user_terraform_state_user_id_instance_id_idx on user_terraform_state (user_id, instance_id);

175
src/db.scm
View File

@@ -6,6 +6,7 @@
with-db with-db/transaction with-db with-db/transaction
create-user delete-user create-user delete-user
create-instance get-user-instances
update-user-service-config get-user-service-config update-user-service-config get-user-service-config
update-user-selected-apps get-user-selected-apps update-user-selected-apps get-user-selected-apps
update-user-app-config get-user-app-config update-user-app-config get-user-app-config
@@ -135,15 +136,25 @@ returning users.user_id;"
(string-append (blob->hexstring/uppercase (string->blob enc-user-key)) (string-append (blob->hexstring/uppercase (string->blob enc-user-key))
(blob->hexstring/uppercase (string->blob tag))) (blob->hexstring/uppercase (string->blob tag)))
user-iv)))) user-iv))))
(query conn "insert into user_service_configs(user_id) values ($1);" user-id)
(query conn "insert into user_selected_apps(user_id) values ($1);" user-id)
(query conn "insert into user_app_configs(user_id) values ($1);" user-id)
(query conn "insert into user_terraform_state(user_id) values ($1);" user-id)
user-id)))) user-id))))
(define (delete-user conn user-id) (define (delete-user conn user-id)
(query conn "delete from users where user_id=$1;" user-id)) (query conn "delete from users where user_id=$1;" user-id))
(define (create-instance conn user-id)
(let ((instance-id
(value-at
(query conn
"insert into instances(user_id) values ($1) returning instances.instance_id;" user-id))))
(query conn "insert into user_service_configs(user_id, instance_id) values ($1, $2);" user-id instance-id)
(query conn "insert into user_selected_apps(user_id, instance_id) values ($1, $2);" user-id instance-id)
(query conn "insert into user_app_configs(user_id, instance_id) values ($1, $2);" user-id instance-id)
(query conn "insert into user_terraform_state(user_id, instance_id) values ($1, $2);" user-id instance-id)
instance-id))
(define (get-user-instances conn user-id)
(column-values (query conn "select instance_id from instances where user_id=$1;" user-id)))
(define *user-service-configs-column-map* (define *user-service-configs-column-map*
'((cloudflare-api-token . ("cloudflare_api_token_enc" #t)) '((cloudflare-api-token . ("cloudflare_api_token_enc" #t))
(cloudflare-account-id . ("cloudflare_account_id_enc" #t)) (cloudflare-account-id . ("cloudflare_account_id_enc" #t))
@@ -160,7 +171,7 @@ returning users.user_id;"
`(,(string->symbol (cadr config)) . (,(car config) ,(caddr config)))) `(,(string->symbol (cadr config)) . (,(car config) ,(caddr config))))
*user-service-configs-column-map*)) *user-service-configs-column-map*))
(define (update-user-service-config conn user-id update-alist) (define (update-user-service-config conn user-id instance-id update-alist)
(let ((valid-keys (map car *user-service-configs-column-map*))) (let ((valid-keys (map car *user-service-configs-column-map*)))
(for-each (lambda (update) (for-each (lambda (update)
(if (not (memq (car update) valid-keys)) (if (not (memq (car update) valid-keys))
@@ -176,17 +187,18 @@ returning users.user_id;"
(conc (car (alist-ref (car update) *user-service-configs-column-map*)) (conc (car (alist-ref (car update) *user-service-configs-column-map*))
"=$" i)) "=$" i))
update-alist update-alist
(iota (length update-alist) 2)) (iota (length update-alist) 3))
", ") ", ")
" where user_id=$1;") " where user_id=$1 and instance_id=$2;")
(cons user-id `(,user-id
(map-in-order (lambda (update) ,instance-id
(if (cadr (alist-ref (car update) *user-service-configs-column-map*)) ,@(map-in-order (lambda (update)
(user-encrypt-for-db (cdr update) user-key user-iv user-id) (if (cadr (alist-ref (car update) *user-service-configs-column-map*))
(cdr update))) (user-encrypt-for-db (cdr update) user-key user-iv user-id)
update-alist))))) (cdr update)))
update-alist)))))
(define (get-user-service-config conn user-id) (define (get-user-service-config conn user-id instance-id)
(receive (user-key user-iv auth-user-id) (receive (user-key user-iv auth-user-id)
(get-decrypted-user-key-and-iv conn user-id) (get-decrypted-user-key-and-iv conn user-id)
(let ((res (row-alist (let ((res (row-alist
@@ -198,8 +210,8 @@ returning users.user_id;"
(car (alist-ref (car update) *user-service-configs-column-map*))) (car (alist-ref (car update) *user-service-configs-column-map*)))
*user-service-configs-column-map*) *user-service-configs-column-map*)
", ") ", ")
" from user_service_configs where user_id=$1;") " from user_service_configs where user_id=$1 and instance_id=$2;")
user-id)))) user-id instance-id))))
(map (lambda (item) (map (lambda (item)
(let* ((key (car item)) (let* ((key (car item))
(value (cdr item)) (value (cdr item))
@@ -221,7 +233,7 @@ returning users.user_id;"
`(,(string->symbol (cdr config)) . ,(car config))) `(,(string->symbol (cdr config)) . ,(car config)))
*user-selected-apps-column-map*)) *user-selected-apps-column-map*))
(define (update-user-selected-apps conn user-id app-alist) (define (update-user-selected-apps conn user-id instance-id app-alist)
(let ((valid-keys (map car *user-selected-apps-column-map*))) (let ((valid-keys (map car *user-selected-apps-column-map*)))
(for-each (lambda (app) (for-each (lambda (app)
(if (not (memq (car app) valid-keys)) (if (not (memq (car app) valid-keys))
@@ -235,13 +247,14 @@ returning users.user_id;"
(conc (alist-ref (car app) *user-selected-apps-column-map*) (conc (alist-ref (car app) *user-selected-apps-column-map*)
"=$" i)) "=$" i))
app-alist app-alist
(iota (length app-alist) 2)) (iota (length app-alist) 3))
", ") ", ")
" where user_id=$1;") " where user_id=$1 and instance_id=$2;")
(cons user-id `(,user-id
(map-in-order cdr app-alist)))) ,instance-id
,@(map-in-order cdr app-alist))))
(define (get-user-selected-apps conn user-id) (define (get-user-selected-apps conn user-id instance-id)
(let ((res (row-alist (let ((res (row-alist
(query conn (query conn
(string-append (string-append
@@ -249,8 +262,8 @@ returning users.user_id;"
(string-intersperse (string-intersperse
(map-in-order cdr *user-selected-apps-column-map*) (map-in-order cdr *user-selected-apps-column-map*)
", ") ", ")
" from user_selected_apps where user_id=$1;") " from user_selected_apps where user_id=$1 and instance_id=$2;")
user-id)))) user-id instance-id))))
(map (lambda (item) (map (lambda (item)
(let* ((key (car item)) (let* ((key (car item))
(value (cdr item)) (value (cdr item))
@@ -260,30 +273,31 @@ returning users.user_id;"
value)))) value))))
res))) res)))
(define (update-user-app-config conn user-id config) (define (update-user-app-config conn user-id instance-id config)
(receive (user-key user-iv auth-user-id) (receive (user-key user-iv auth-user-id)
(get-decrypted-user-key-and-iv conn user-id) (get-decrypted-user-key-and-iv conn user-id)
(query conn (query conn
"update user_app_configs set config_enc=$1 where user_id=$2;" "update user_app_configs set config_enc=$1 where user_id=$2 and instance_id=$3;"
(user-encrypt-for-db (user-encrypt-for-db
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(write config))) (write config)))
user-key user-iv user-id) user-key user-iv user-id)
user-id))) user-id instance-id)))
(define (update-root-domain conn user-id root-domain) (define (update-root-domain conn user-id instance-id root-domain)
(query conn (query conn
"update user_app_configs set root_domain=$1 where user_id=$2;" "update user_app_configs set root_domain=$1 where user_id=$2 and instance_id=$3;"
root-domain root-domain
user-id)) user-id
instance-id))
(define (get-user-app-config conn user-id) (define (get-user-app-config conn user-id instance-id)
(receive (user-key user-iv auth-user-id) (receive (user-key user-iv auth-user-id)
(get-decrypted-user-key-and-iv conn user-id) (get-decrypted-user-key-and-iv conn user-id)
(let ((res (row-alist (query conn (let ((res (row-alist (query conn
"select root_domain, config_enc from user_app_configs where user_id=$1;" "select root_domain, config_enc from user_app_configs where user_id=$1 and instance_id=$2;"
user-id)))) user-id instance-id))))
`((root-domain . ,(if (sql-null? (alist-ref 'root_domain res)) `((root-domain . ,(if (sql-null? (alist-ref 'root_domain res))
#f #f
(alist-ref 'root_domain res))) (alist-ref 'root_domain res)))
@@ -298,11 +312,11 @@ returning users.user_id;"
(in-progress . "in-progress") (in-progress . "in-progress")
(complete . "complete") (complete . "complete")
(failed . "failed"))) (failed . "failed")))
(define (create-deployment conn user-id) (define (create-deployment conn user-id instance-id)
(value-at (value-at
(query conn (query conn
"insert into deployments(user_id, started) values($1, now()) returning deployments.id;" "insert into deployments(user_id, instance_id, started) values($1, $2, now()) returning deployments.id;"
user-id))) user-id instance-id)))
(define (update-deployment-in-progress conn deployment-id pid) (define (update-deployment-in-progress conn deployment-id pid)
(query conn (query conn
"update deployments set status=$1, pid=$2 where id=$3;" "update deployments set status=$1, pid=$2 where id=$3;"
@@ -319,8 +333,8 @@ returning users.user_id;"
(define (get-deployment-status conn deployment-id) (define (get-deployment-status conn deployment-id)
(value-at (query conn "select status from deployments where id=$1;" deployment-id))) (value-at (query conn "select status from deployments where id=$1;" deployment-id)))
(define (get-most-recent-deployment-status conn user-id) (define (get-most-recent-deployment-status conn user-id instance-id)
(value-at (query conn "select status from deployments where user_id=$1 order by id DESC limit 1;" user-id))) (value-at (query conn "select status from deployments where user_id=$1 and instance_id=$2 order by id DESC limit 1;" user-id instance-id)))
(define *deployments-column-map* (define *deployments-column-map*
'((generate-configs . "generate_configs") '((generate-configs . "generate_configs")
@@ -328,7 +342,8 @@ returning users.user_id;"
(machine-create . "terraform_machine_create") (machine-create . "terraform_machine_create")
(machine-destroy . "terraform_machine_destroy") (machine-destroy . "terraform_machine_destroy")
(status . "status") (status . "status")
(id . "id"))) (id . "id")
(instance-id . "instance_id")))
(define *deployments-reverse-column-map* (define *deployments-reverse-column-map*
(map (lambda (config) (map (lambda (config)
@@ -374,7 +389,7 @@ returning users.user_id;"
(string->symbol value))))) (string->symbol value)))))
res))) res)))
(define (get-most-recent-deployment-progress conn user-id) (define (get-most-recent-deployment-progress conn user-id instance-id)
(let ((res (row-alist (let ((res (row-alist
(query conn (query conn
(string-append (string-append
@@ -382,57 +397,64 @@ returning users.user_id;"
(string-intersperse (string-intersperse
(map-in-order cdr *deployments-column-map*) (map-in-order cdr *deployments-column-map*)
", ") ", ")
" from deployments where user_id=$1 order by id DESC limit 1;") " from deployments where user_id=$1 and instance_id=$2 order by id DESC limit 1;")
user-id)))) user-id instance-id))))
(map (lambda (item) (map (lambda (item)
(let* ((key (car item)) (let* ((key (car item))
(value (cdr item)) (value (cdr item))
(config (alist-ref key *deployments-reverse-column-map*))) (config (alist-ref key *deployments-reverse-column-map*)))
`(,config . ,(if (sql-null? value) `(,config . ,(if (sql-null? value)
#f #f
(string->symbol value))))) (if (string? value)
(string->symbol value)
value)))))
res))) res)))
(define (get-user-deployments conn user-id) (define (get-user-deployments conn user-id)
(let ((res (row-alist (let* ((res-raw
(query conn (query conn
(string-append (string-append
"select " "select "
(string-intersperse (string-intersperse
(map-in-order (lambda (d) (string-append "d." (cdr d))) *deployments-column-map*) (map-in-order (lambda (d) (string-append "d." (cdr d))) *deployments-column-map*)
", ") ", ")
", uac.root_domain" ", uac.root_domain"
" from deployments as d " " from deployments as d "
"join user_app_configs uac on uac.user_id = d.user_id" "join user_app_configs uac on uac.user_id = d.user_id and uac.instance_id = d.instance_id"
" where d.user_id=$1 order by d.id DESC limit 1;") " where d.user_id=$1 order by d.id DESC limit 1;")
user-id)))) user-id))
(list (res (if (> (row-count res-raw) 0) (row-alist res-raw) '())))
(map (lambda (item) (if (null? res)
(let* ((key (car item)) '()
(value (cdr item)) ;; I think this is just a hack as currently we only return 1 deployment
(config (alist-ref key (cons '(root_domain . root-domain) *deployments-reverse-column-map*)))) (list
`(,config . ,(if (sql-null? value) (map (lambda (item)
#f (let* ((key (car item))
(if (string? value) (value (cdr item))
(string->symbol value) (config (alist-ref key (cons '(root_domain . root-domain) *deployments-reverse-column-map*))))
value))))) `(,config . ,(if (sql-null? value)
res)))) #f
(if (string? value)
(string->symbol value)
value)))))
res)))))
(define (update-user-terraform-state conn user-id state backup) (define (update-user-terraform-state conn user-id instance-id state backup)
(receive (user-key user-iv auth-user-id) (receive (user-key user-iv auth-user-id)
(get-decrypted-user-key-and-iv conn user-id) (get-decrypted-user-key-and-iv conn user-id)
(query conn (query conn
"update user_terraform_state set state_enc=$1, state_backup_enc=$2 where user_id=$3;" "update user_terraform_state set state_enc=$1, state_backup_enc=$2 where user_id=$3 and instance_id=$4;"
(user-encrypt-for-db state user-key user-iv user-id) (user-encrypt-for-db state user-key user-iv user-id)
(user-encrypt-for-db backup user-key user-iv user-id) (user-encrypt-for-db backup user-key user-iv user-id)
user-id))) user-id
instance-id)))
(define (get-user-terraform-state conn user-id) (define (get-user-terraform-state conn user-id instance-id)
(receive (user-key user-iv auth-user-id) (receive (user-key user-iv auth-user-id)
(get-decrypted-user-key-and-iv conn user-id) (get-decrypted-user-key-and-iv conn user-id)
(let ((res (row-alist (query conn (let ((res (row-alist (query conn
"select state_enc, state_backup_enc from user_terraform_state where user_id=$1;" "select state_enc, state_backup_enc from user_terraform_state where user_id=$1 and instance_id=$2;"
user-id)))) user-id instance-id))))
`((state . ,(if (sql-null? (alist-ref 'config_enc res)) `((state . ,(if (sql-null? (alist-ref 'config_enc res))
"" ""
(user-decrypt-from-db (alist-ref 'state_enc res) user-key user-iv user-id))) (user-decrypt-from-db (alist-ref 'state_enc res) user-key user-iv user-id)))
@@ -440,15 +462,15 @@ returning users.user_id;"
"" ""
(user-decrypt-from-db (alist-ref 'state_backup_enc res) user-key user-iv user-id))))))) (user-decrypt-from-db (alist-ref 'state_backup_enc res) user-key user-iv user-id)))))))
;; (with-db/transaction (lambda (db) (get-user-deployments db 7))) ;; (with-db/transaction (lambda (db) (get-user-deployments db 1)))
;; (with-db/transaction (lambda (db) (get-most-recent-deployment-progress db 7))) ;; (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) (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-deployment-progress db 14 '((generate-configs . complete) (custom-image . in-progress) (machine-create . queued)))))
;; (with-db/transaction ;; (with-db/transaction
;; (lambda (db) ;; (lambda (db)
;; (update-user-terraform-state db 7 ;; (update-user-terraform-state db 1 22
;; (with-input-from-file "src/deploy-bak/terraform.tfstate" read-string) ;; (with-input-from-file "src/deploy-7/terraform.tfstate" read-string)
;; (with-input-from-file "src/deploy-bak/terraform.tfstate.backup" read-string)))) ;; (with-input-from-file "src/deploy-7/terraform.tfstate.backup" read-string))))
;; (with-db/transaction (lambda (db) (get-user-terraform-state db 7))) ;; (with-db/transaction (lambda (db) (get-user-terraform-state db 7)))
;; (with-db/transaction (lambda (db) (create-deployment db 7))) ;; (with-db/transaction (lambda (db) (create-deployment db 7)))
@@ -458,6 +480,7 @@ returning users.user_id;"
;; (with-db/transaction (lambda (db) (get-most-recent-deployment-status db 7))) ;; (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"))) ;; (with-db/transaction (lambda (db) (create-user db 1 "t@thintz.com" "thecombjelly")))
;; (with-db/transaction (lambda (db) (create-instance db 2)))
;; (let ((user-id 7)) ;; (let ((user-id 7))
;; (with-db/transaction ;; (with-db/transaction

334
src/nassella.scm
View File

@@ -288,7 +288,7 @@ h1, h2, h3, h4, h5, h6 {
(lambda () (lambda ()
(use-middleware! (session-middleware "your-secret-key-here")))) ;; TODO generate better one (use-middleware! (session-middleware "your-secret-key-here")))) ;; TODO generate better one
(define test-user-id (make-parameter 7)) (define test-user-id (make-parameter 1))
(define (session-user-id) (define (session-user-id)
(or (session-get "user-id") (test-user-id))) (or (session-get "user-id") (test-user-id)))
@@ -576,14 +576,26 @@ h1, h2, h3, h4, h5, h6 {
(with-schematra-app app (with-schematra-app app
(lambda () (lambda ()
(post "/config/wizard/create-instance"
(let ((instance-id (with-db/transaction
(lambda (db)
(create-instance db (session-user-id))))))
(redirect (conc "/config/wizard/services/" instance-id))))
;; TODO should all these key related form fields be of type password
;; so the browser doesn't save them???
(get/widgets (get/widgets
("/config/wizard/services") ("/config/wizard/services/:id")
(let ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-user-id)))))) (let* ((instance-id (alist-ref "id" (current-params) equal?))
(config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-user-id)
instance-id)))))
`(App `(App
(Configuration-Wizard (Configuration-Wizard
(@ (step "Services")) (@ (step "Services"))
(form (form
(@ (action "/config/wizard/services-submit") (@ (action ,(conc "/config/wizard/services-submit/" instance-id))
(method POST)) (method POST))
(VStack (VStack
(Fieldset (Fieldset
@@ -601,102 +613,111 @@ h1, h2, h3, h4, h5, h6 {
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url config))))) (Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url config)))))
(Form-Nav))))))) (Form-Nav)))))))
(post "/config/wizard/services-submit" (post "/config/wizard/services-submit/:id"
(with-db/transaction (let ((instance-id (alist-ref "id" (current-params) equal?)))
(lambda (db) (with-db/transaction
(update-user-service-config (lambda (db)
db (update-user-service-config
(session-user-id) db
`((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (current-params))) (session-user-id)
(cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (current-params))) instance-id
(cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (current-params))) `((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (current-params)))
(digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (current-params))) (cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (current-params)))
(backblaze-application-key . ,(alist-ref 'backblaze-application-key (current-params))) (cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (current-params)))
(backblaze-key-id . ,(alist-ref 'backblaze-key-id (current-params))) (digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (current-params)))
(backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (current-params))))))) (backblaze-application-key . ,(alist-ref 'backblaze-application-key (current-params)))
(redirect "/config/wizard/services-success")) (backblaze-key-id . ,(alist-ref 'backblaze-key-id (current-params)))
(backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (current-params)))))))
(redirect (conc "/config/wizard/services-success/" instance-id))))
(get/widgets (get/widgets
("/config/wizard/services-success") ("/config/wizard/services-success/:id")
`(App (let ((instance-id (alist-ref "id" (current-params) equal?)))
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/apps"))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(h3 "Connected")
(p "Your Cloudflare account was successfully connected!"))
(Fieldset
(@ (title "DigitalOcean"))
(h3 "Connected")
(p "Your DigitalOcean account was successfully connected!"))
(Fieldset
(@ (title "Backblaze"))
(h3 "Connected")
(p "Your Backblaze account was successfully connected!"))
(Form-Nav (@ (back-to "/config/wizard/services"))))))))
(get/widgets
("/config/wizard/apps")
(let ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-user-id)))))
(app-config . ,(get-user-app-config db (session-user-id))))))))
`(App `(App
(Configuration-Wizard (Configuration-Wizard
(@ (step "Apps")) (@ (step "Services"))
(form (form
(@ (action "/config/wizard/apps-submit") (method POST)) (@ (action ,(conc "/config/wizard/apps/" instance-id)))
(VStack (VStack
(Fieldset (Fieldset
(@ (title "Root Domain")) (@ (title "Cloudflare"))
(Field (@ (element select) (name "root-domain")) (h3 "Connected")
(option (@ (value ,(alist-ref 'root-domain (alist-ref 'app-config results)))) "nassella.cc"))) ;; TODO fetch from cloudflare API? (p "Your Cloudflare account was successfully connected!"))
(Fieldset (Fieldset
(@ (title "Selected Apps")) (@ (title "DigitalOcean"))
(Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps results))))) (h3 "Connected")
(Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'nextcloud (alist-ref 'selected-apps results))))) (p "Your DigitalOcean account was successfully connected!"))
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled")))) (Fieldset
(Form-Nav (@ (back-to "/config/wizard/services-success"))))))))) (@ (title "Backblaze"))
(h3 "Connected")
(p "Your Backblaze account was successfully connected!"))
(Form-Nav (@ (back-to ,(conc "/config/wizard/services/" instance-id))))))))))
(post "/config/wizard/apps-submit"
(with-db/transaction
(lambda (db)
(update-user-selected-apps
db
(session-user-id)
`((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "0.0") (sql-null)))
(nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "0.0") (sql-null)))))
(update-root-domain db
(session-user-id)
(alist-ref 'root-domain (current-params)))))
(redirect "/config/wizard/apps2"))
;; TODO should this even allow changing existing username/passwords like for db?
;; wouldn't that break the db connection and you would lose data?
(get/widgets (get/widgets
("/config/wizard/apps2") ("/config/wizard/apps/:id")
(let* ((results (let* ((instance-id (alist-ref "id" (current-params) equal?))
(results
(with-db/transaction (with-db/transaction
(lambda (db) (lambda (db)
`((selected-apps . ,(map `((selected-apps . ,(map
car car
(filter cdr (filter cdr
(get-user-selected-apps db (session-user-id))))) (get-user-selected-apps db (session-user-id) instance-id))))
(app-config . ,(get-user-app-config db (session-user-id))))))) (app-config . ,(get-user-app-config db (session-user-id) instance-id)))))))
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action ,(conc "/config/wizard/apps-submit/" instance-id)) (method POST))
(VStack
(Fieldset
(@ (title "Root Domain"))
(Field (@ (element select) (name "root-domain"))
(option (@ (value ,(or (alist-ref 'root-domain (alist-ref 'app-config results)) "nassella.cc"))) "nassella.cc"))) ;; TODO fetch from cloudflare API?
(Fieldset
(@ (title "Selected Apps"))
(Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps results)))))
(Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'nextcloud (alist-ref 'selected-apps results)))))
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/services-success/" instance-id))))))))))
(post "/config/wizard/apps-submit/:id"
(display "root domain: ") (print (alist-ref 'root-domain (current-params)))
(let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction
(lambda (db)
(update-user-selected-apps
db
(session-user-id)
instance-id
`((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "0.0") (sql-null)))
(nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "0.0") (sql-null)))))
(update-root-domain db
(session-user-id)
instance-id
(alist-ref 'root-domain (current-params)))))
(redirect (conc "/config/wizard/apps2/" instance-id))))
;; TODO should this even allow changing existing username/passwords like for db?
;; wouldn't that break the db connection and you would lose data?
(get/widgets
("/config/wizard/apps2/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-user-id) instance-id))))
(app-config . ,(get-user-app-config db (session-user-id) instance-id))))))
(selected-apps (alist-ref 'selected-apps results)) (selected-apps (alist-ref 'selected-apps results))
(app-config (alist-ref 'config (alist-ref 'app-config results)))) (app-config (alist-ref 'config (alist-ref 'app-config results))))
`(App `(App
(Configuration-Wizard (Configuration-Wizard
(@ (step "Apps")) (@ (step "Apps"))
(form (form
(@ (action "/config/wizard/apps2-submit") (method POST)) (@ (action ,(conc "/config/wizard/apps2-submit/" instance-id)) (method POST))
(VStack (VStack
,@(if (member 'wg-easy selected-apps) ,@(if (member 'wg-easy selected-apps)
`((Fieldset `((Fieldset
@@ -721,33 +742,36 @@ h1, h2, h3, h4, h5, h6 {
(value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? "")))) (value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
(Field (@ (name "log-viewer-password") (label ("Password")) (type "password") (Field (@ (name "log-viewer-password") (label ("Password")) (type "password")
(value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? ""))))) (value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? "")))))
(Form-Nav (@ (back-to "/config/wizard/apps"))))))))) (Form-Nav (@ (back-to ,(conc "/config/wizard/apps/" instance-id))))))))))
(post "/config/wizard/apps2-submit" (post "/config/wizard/apps2-submit/:id"
(with-db/transaction (let ((instance-id (alist-ref "id" (current-params) equal?)))
(lambda (db) (with-db/transaction
(update-user-app-config (lambda (db)
db (update-user-app-config
(session-user-id) db
`((wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params))))) (session-user-id)
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params))) instance-id
(admin-user . ,(alist-ref 'nextcloud-admin-user (current-params))) `((wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params)))))
(admin-password . ,(alist-ref 'nextcloud-admin-password (current-params))))) (nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params)))
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params))) (admin-user . ,(alist-ref 'nextcloud-admin-user (current-params)))
(user . ,(alist-ref 'log-viewer-user (current-params))) (admin-password . ,(alist-ref 'nextcloud-admin-password (current-params)))))
(password . ,(alist-ref 'log-viewer-password (current-params))))))))) (log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
(redirect "/config/wizard/machine")) (user . ,(alist-ref 'log-viewer-user (current-params)))
(password . ,(alist-ref 'log-viewer-password (current-params)))))))))
(redirect (conc "/config/wizard/machine/" instance-id))))
(get/widgets (get/widgets
("/config/wizard/machine") ("/config/wizard/machine/:id")
(let ((config (with-db/transaction (let* ((instance-id (alist-ref "id" (current-params) equal?))
(lambda (db) (config (with-db/transaction
(get-user-service-config db (session-user-id)))))) (lambda (db)
(get-user-service-config db (session-user-id) instance-id)))))
`(App `(App
(Configuration-Wizard (Configuration-Wizard
(@ (step "Machine")) (@ (step "Machine"))
(form (form
(@ (action "/config/wizard/machine-submit") (@ (action ,(conc "/config/wizard/machine-submit/" instance-id))
(method POST)) (method POST))
(VStack (VStack
(Fieldset (Fieldset
@@ -757,22 +781,25 @@ h1, h2, h3, h4, h5, h6 {
,@(map (lambda (r) ,@(map (lambda (r)
`(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r))) `(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r)))
(get-digital-ocean-regions (alist-ref 'digitalocean-api-token config))))) (get-digital-ocean-regions (alist-ref 'digitalocean-api-token config)))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2")))))))))) (Form-Nav (@ (back-to ,(conc "/config/wizard/apps2/" instance-id))))))))))
(post "/config/wizard/machine-submit" (post "/config/wizard/machine-submit/:id"
(with-db/transaction (let ((instance-id (alist-ref "id" (current-params) equal?)))
(lambda (db) (with-db/transaction
(update-user-service-config (lambda (db)
db (update-user-service-config
(session-user-id) db
`((digitalocean-region . ,(alist-ref 'region (current-params))))))) (session-user-id)
(redirect "/config/wizard/machine2")) instance-id
`((digitalocean-region . ,(alist-ref 'region (current-params)))))))
(redirect (conc "/config/wizard/machine2/" instance-id))))
(get/widgets (get/widgets
("/config/wizard/machine2") ("/config/wizard/machine2/:id")
(let* ((config (with-db/transaction (let* ((instance-id (alist-ref "id" (current-params) equal?))
(config (with-db/transaction
(lambda (db) (lambda (db)
(get-user-service-config db (session-user-id))))) (get-user-service-config db (session-user-id) instance-id))))
(region (alist-ref 'digitalocean-region config)) (region (alist-ref 'digitalocean-region config))
(all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token config))) (all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token config)))
(sizes (filter (lambda (s) (member region (alist-ref 'regions s))) all-sizes))) (sizes (filter (lambda (s) (member region (alist-ref 'regions s))) all-sizes)))
@@ -780,7 +807,7 @@ h1, h2, h3, h4, h5, h6 {
(Configuration-Wizard (Configuration-Wizard
(@ (step "Machine")) (@ (step "Machine"))
(form (form
(@ (action "/config/wizard/machine2-submit") (@ (action ,(conc "/config/wizard/machine2-submit/" instance-id))
(method POST)) (method POST))
(VStack (VStack
(Fieldset (Fieldset
@@ -794,28 +821,31 @@ h1, h2, h3, h4, h5, h6 {
" Disk: " ,(alist-ref 'disk s) " Disk: " ,(alist-ref 'disk s)
") " ,(alist-ref 'description s))) ") " ,(alist-ref 'description s)))
sizes))) sizes)))
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine")))))))))) (Form-Nav (@ (back-to ,(conc "/config/wizard/machine/" instance-id))))))))))
(post "/config/wizard/machine2-submit" (post "/config/wizard/machine2-submit/:id"
(with-db/transaction (let ((instance-id (alist-ref "id" (current-params) equal?)))
(lambda (db) (with-db/transaction
(update-user-service-config (lambda (db)
db (update-user-service-config
(session-user-id) db
`((digitalocean-size . ,(alist-ref 'size (current-params))))))) (session-user-id)
(redirect "/config/wizard/review")) instance-id
`((digitalocean-size . ,(alist-ref 'size (current-params)))))))
(redirect (conc "/config/wizard/review/" instance-id))))
(get/widgets (get/widgets
("/config/wizard/review") ("/config/wizard/review/:id")
(let* ((results (let* ((instance-id (alist-ref "id" (current-params) equal?))
(results
(with-db/transaction (with-db/transaction
(lambda (db) (lambda (db)
`((selected-apps . ,(map `((selected-apps . ,(map
car car
(filter cdr (filter cdr
(get-user-selected-apps db (session-user-id))))) (get-user-selected-apps db (session-user-id) instance-id))))
(app-config . ,(get-user-app-config db (session-user-id))) (app-config . ,(get-user-app-config db (session-user-id) instance-id))
(service-config . ,(get-user-service-config db (session-user-id))))))) (service-config . ,(get-user-service-config db (session-user-id) instance-id))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results))) (selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results)) (app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config)) (config (alist-ref 'config app-config))
@@ -836,21 +866,24 @@ h1, h2, h3, h4, h5, h6 {
(ul (li "Region: " ,(alist-ref 'digitalocean-region service-config)) (ul (li "Region: " ,(alist-ref 'digitalocean-region service-config))
(li "Size: " ,(alist-ref 'digitalocean-size service-config))) (li "Size: " ,(alist-ref 'digitalocean-size service-config)))
(form (form
(@ (action "/config/wizard/review-submit") (method POST)) (@ (action ,(conc "/config/wizard/review-submit/" instance-id)) (method POST))
(VStack (VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2")) (submit-button "Launch"))))))))) (Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch")))))))))
(post "/config/wizard/review-submit" ;; TODO this can only handle a user deploying one instance at a time!
(let* ((results ;; the folder used should be the user-id PLUS the instance id
(post "/config/wizard/review-submit/:id"
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(results
(with-db/transaction (with-db/transaction
(lambda (db) (lambda (db)
`((selected-apps . ,(map `((selected-apps . ,(map
car car
(filter cdr (filter cdr
(get-user-selected-apps db (session-user-id))))) (get-user-selected-apps db (session-user-id) instance-id))))
(app-config . ,(get-user-app-config db (session-user-id))) (app-config . ,(get-user-app-config db (session-user-id) instance-id))
(service-config . ,(get-user-service-config db (session-user-id))) (service-config . ,(get-user-service-config db (session-user-id) instance-id))
(terraform-state . ,(get-user-terraform-state db (session-user-id))))))) (terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results))) (selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results)) (app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config)) (config (alist-ref 'config app-config))
@@ -896,8 +929,9 @@ h1, h2, h3, h4, h5, h6 {
("datacenter" . ,(alist-ref 'digitalocean-region service-config)) ("datacenter" . ,(alist-ref 'digitalocean-region service-config))
("flatcar_stable_version" . "4230.2.3"))) ("flatcar_stable_version" . "4230.2.3")))
(display "ssh_keys=[\"") (display (with-input-from-file (string-append dir "/config/ssh-keys") read-string)) (print "\"]")))) (display "ssh_keys=[\"") (display (with-input-from-file (string-append dir "/config/ssh-keys") read-string)) (print "\"]"))))
(let* ((user-id (session-user-id)) (let* ((instance-id (alist-ref "id" (current-params) equal?))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id)))) (user-id (session-user-id))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
(dir (deployment-directory user-id))) (dir (deployment-directory user-id)))
(thread-start! (thread-start!
(lambda () (lambda ()
@@ -918,9 +952,9 @@ h1, h2, h3, h4, h5, h6 {
(update-deployment-progress db deployment-id progress)))) (update-deployment-progress db deployment-id progress))))
(loop)) (loop))
(let ((progress (parse-deployment-log (let ((progress (parse-deployment-log
(with-input-from-file (with-input-from-file
(string-append (deployment-directory user-id) "/make-out") (string-append (deployment-directory user-id) "/make-out")
read-string)))) read-string))))
(with-db/transaction (with-db/transaction
(lambda (db) (lambda (db)
(update-deployment-progress db deployment-id progress) (update-deployment-progress db deployment-id progress)
@@ -934,17 +968,18 @@ h1, h2, h3, h4, h5, h6 {
db user-id deployment-id db user-id deployment-id
(if exit-normal 'complete 'failed) (if exit-normal 'complete 'failed)
(with-input-from-file (string-append dir "/make-out") read-string)) (with-input-from-file (string-append dir "/make-out") read-string))
(update-user-terraform-state db user-id (update-user-terraform-state db user-id instance-id
(with-input-from-file (string-append dir "/terraform.tfstate") read-string) (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))))))))))))
(redirect "/config/wizard/success")) (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))
(get/widgets (get/widgets
("/config/wizard/success") ("/config/wizard/success/:id")
(let* ((res (with-db/transaction (let* ((instance-id (alist-ref "id" (current-params) equal?))
(res (with-db/transaction
(lambda (db) (lambda (db)
`((status . ,(get-most-recent-deployment-status db (session-user-id))) `((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))
(progress . ,(get-most-recent-deployment-progress db (session-user-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)) "/make-out") read-string)) (output (with-input-from-file (string-append (deployment-directory (session-user-id)) "/make-out") read-string))
(progress (alist-ref 'progress res)) (progress (alist-ref 'progress res))
(status (alist-ref 'status res))) (status (alist-ref 'status res)))
@@ -967,10 +1002,13 @@ h1, h2, h3, h4, h5, h6 {
`(App `(App
(Main-Container (Main-Container
(main (main
(h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Deployments") (h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Instances")
(Button "Setup New Deployment") (form
(@ (action "/config/wizard/create-instance")
(method POST))
(Button "Setup New Instance"))
(ul ,@(map (lambda (deployment) (ul ,@(map (lambda (deployment)
`(li (a (@ (href ,(string-append "/deployments/" (number->string (alist-ref 'id deployment))))) `(li (a (@ (href ,(conc "/deployments/" (alist-ref 'id deployment))))
,(alist-ref 'root-domain deployment)) ,(alist-ref 'root-domain deployment))
" - ",(alist-ref 'status deployment))) " - ",(alist-ref 'status deployment)))
(with-db/transaction (with-db/transaction

204
src/test.scm
View File

File diff suppressed because one or more lines are too long