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,
username varchar(255) not null unique,
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 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(
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_account_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_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(
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),
nextcloud_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(
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),
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');
@@ -46,6 +56,7 @@ create type deployment_status as enum ('queued', 'in-progress', 'complete', 'fai
create table deployments(
id bigserial primary key,
user_id integer not null references users on delete cascade,
instance_id integer not null references instances on delete cascade,
started timestamptz,
finished timestamptz,
status deployment_status not null default 'queued',
@@ -62,13 +73,14 @@ create table deployments(
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(
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_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
create-user delete-user
create-instance get-user-instances
update-user-service-config get-user-service-config
update-user-selected-apps get-user-selected-apps
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))
(blob->hexstring/uppercase (string->blob tag)))
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))))
(define (delete-user conn 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*
'((cloudflare-api-token . ("cloudflare_api_token_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))))
*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*)))
(for-each (lambda (update)
(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*))
"=$" i))
update-alist
(iota (length update-alist) 2))
(iota (length update-alist) 3))
", ")
" where user_id=$1;")
(cons user-id
(map-in-order (lambda (update)
(if (cadr (alist-ref (car update) *user-service-configs-column-map*))
(user-encrypt-for-db (cdr update) user-key user-iv user-id)
(cdr update)))
update-alist)))))
" where user_id=$1 and instance_id=$2;")
`(,user-id
,instance-id
,@(map-in-order (lambda (update)
(if (cadr (alist-ref (car update) *user-service-configs-column-map*))
(user-encrypt-for-db (cdr update) user-key user-iv user-id)
(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)
(get-decrypted-user-key-and-iv conn user-id)
(let ((res (row-alist
@@ -198,8 +210,8 @@ returning users.user_id;"
(car (alist-ref (car update) *user-service-configs-column-map*)))
*user-service-configs-column-map*)
", ")
" from user_service_configs where user_id=$1;")
user-id))))
" from user_service_configs where user_id=$1 and instance_id=$2;")
user-id instance-id))))
(map (lambda (item)
(let* ((key (car item))
(value (cdr item))
@@ -221,7 +233,7 @@ returning users.user_id;"
`(,(string->symbol (cdr config)) . ,(car config)))
*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*)))
(for-each (lambda (app)
(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*)
"=$" i))
app-alist
(iota (length app-alist) 2))
(iota (length app-alist) 3))
", ")
" where user_id=$1;")
(cons user-id
(map-in-order cdr app-alist))))
" where user_id=$1 and instance_id=$2;")
`(,user-id
,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
(query conn
(string-append
@@ -249,8 +262,8 @@ returning users.user_id;"
(string-intersperse
(map-in-order cdr *user-selected-apps-column-map*)
", ")
" from user_selected_apps where user_id=$1;")
user-id))))
" from user_selected_apps where user_id=$1 and instance_id=$2;")
user-id instance-id))))
(map (lambda (item)
(let* ((key (car item))
(value (cdr item))
@@ -260,30 +273,31 @@ returning users.user_id;"
value))))
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)
(get-decrypted-user-key-and-iv conn user-id)
(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
(with-output-to-string
(lambda ()
(write config)))
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
"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
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)
(get-decrypted-user-key-and-iv conn user-id)
(let ((res (row-alist (query conn
"select root_domain, config_enc from user_app_configs where user_id=$1;"
user-id))))
"select root_domain, config_enc from user_app_configs where user_id=$1 and instance_id=$2;"
user-id instance-id))))
`((root-domain . ,(if (sql-null? (alist-ref 'root_domain res))
#f
(alist-ref 'root_domain res)))
@@ -298,11 +312,11 @@ returning users.user_id;"
(in-progress . "in-progress")
(complete . "complete")
(failed . "failed")))
(define (create-deployment conn user-id)
(define (create-deployment conn user-id instance-id)
(value-at
(query conn
"insert into deployments(user_id, started) values($1, now()) returning deployments.id;"
user-id)))
"insert into deployments(user_id, instance_id, started) values($1, $2, now()) returning deployments.id;"
user-id instance-id)))
(define (update-deployment-in-progress conn deployment-id pid)
(query conn
"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)
(value-at (query conn "select status from deployments where id=$1;" deployment-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 (get-most-recent-deployment-status conn user-id instance-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*
'((generate-configs . "generate_configs")
@@ -328,7 +342,8 @@ returning users.user_id;"
(machine-create . "terraform_machine_create")
(machine-destroy . "terraform_machine_destroy")
(status . "status")
(id . "id")))
(id . "id")
(instance-id . "instance_id")))
(define *deployments-reverse-column-map*
(map (lambda (config)
@@ -374,7 +389,7 @@ returning users.user_id;"
(string->symbol value)))))
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
(query conn
(string-append
@@ -382,57 +397,64 @@ returning users.user_id;"
(string-intersperse
(map-in-order cdr *deployments-column-map*)
", ")
" from deployments where user_id=$1 order by id DESC limit 1;")
user-id))))
" from deployments where user_id=$1 and instance_id=$2 order by id DESC limit 1;")
user-id instance-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)))))
(if (string? value)
(string->symbol value)
value)))))
res)))
(define (get-user-deployments conn user-id)
(let ((res (row-alist
(query conn
(string-append
"select "
(string-intersperse
(map-in-order (lambda (d) (string-append "d." (cdr d))) *deployments-column-map*)
", ")
", uac.root_domain"
" from deployments as d "
"join user_app_configs uac on uac.user_id = d.user_id"
" where d.user_id=$1 order by d.id DESC limit 1;")
user-id))))
(list
(map (lambda (item)
(let* ((key (car item))
(value (cdr item))
(config (alist-ref key (cons '(root_domain . root-domain) *deployments-reverse-column-map*))))
`(,config . ,(if (sql-null? value)
#f
(if (string? value)
(string->symbol value)
value)))))
res))))
(let* ((res-raw
(query conn
(string-append
"select "
(string-intersperse
(map-in-order (lambda (d) (string-append "d." (cdr d))) *deployments-column-map*)
", ")
", uac.root_domain"
" from deployments as d "
"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;")
user-id))
(res (if (> (row-count res-raw) 0) (row-alist res-raw) '())))
(if (null? res)
'()
;; I think this is just a hack as currently we only return 1 deployment
(list
(map (lambda (item)
(let* ((key (car item))
(value (cdr item))
(config (alist-ref key (cons '(root_domain . root-domain) *deployments-reverse-column-map*))))
`(,config . ,(if (sql-null? value)
#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)
(get-decrypted-user-key-and-iv conn user-id)
(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 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)
(get-decrypted-user-key-and-iv conn user-id)
(let ((res (row-alist (query conn
"select state_enc, state_backup_enc from user_terraform_state where user_id=$1;"
user-id))))
"select state_enc, state_backup_enc from user_terraform_state where user_id=$1 and instance_id=$2;"
user-id instance-id))))
`((state . ,(if (sql-null? (alist-ref 'config_enc res))
""
(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)))))))
;; (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-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
;; (with-input-from-file "src/deploy-bak/terraform.tfstate" read-string)
;; (with-input-from-file "src/deploy-bak/terraform.tfstate.backup" read-string))))
;; (update-user-terraform-state db 1 22
;; (with-input-from-file "src/deploy-7/terraform.tfstate" 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) (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) (create-user db 1 "t@thintz.com" "thecombjelly")))
;; (with-db/transaction (lambda (db) (create-instance db 2)))
;; (let ((user-id 7))
;; (with-db/transaction

334
src/nassella.scm
View File

@@ -288,7 +288,7 @@ h1, h2, h3, h4, h5, h6 {
(lambda ()
(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)
(or (session-get "user-id") (test-user-id)))
@@ -576,14 +576,26 @@ h1, h2, h3, h4, h5, h6 {
(with-schematra-app app
(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
("/config/wizard/services")
(let ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-user-id))))))
("/config/wizard/services/: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
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/services-submit")
(@ (action ,(conc "/config/wizard/services-submit/" instance-id))
(method POST))
(VStack
(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)))))
(Form-Nav)))))))
(post "/config/wizard/services-submit"
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
`((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (current-params)))
(cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (current-params)))
(cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (current-params)))
(digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (current-params)))
(backblaze-application-key . ,(alist-ref 'backblaze-application-key (current-params)))
(backblaze-key-id . ,(alist-ref 'backblaze-key-id (current-params)))
(backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (current-params)))))))
(redirect "/config/wizard/services-success"))
(post "/config/wizard/services-submit/:id"
(let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
instance-id
`((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (current-params)))
(cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (current-params)))
(cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (current-params)))
(digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (current-params)))
(backblaze-application-key . ,(alist-ref 'backblaze-application-key (current-params)))
(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
("/config/wizard/services-success")
`(App
(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))))))))
("/config/wizard/services-success/:id")
(let ((instance-id (alist-ref "id" (current-params) equal?)))
`(App
(Configuration-Wizard
(@ (step "Apps"))
(@ (step "Services"))
(form
(@ (action "/config/wizard/apps-submit") (method POST))
(@ (action ,(conc "/config/wizard/apps/" instance-id)))
(VStack
(Fieldset
(@ (title "Root Domain"))
(Field (@ (element select) (name "root-domain"))
(option (@ (value ,(alist-ref 'root-domain (alist-ref 'app-config results)))) "nassella.cc"))) ;; TODO fetch from cloudflare API?
(@ (title "Cloudflare"))
(h3 "Connected")
(p "Your Cloudflare account was successfully connected!"))
(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 "/config/wizard/services-success")))))))))
(@ (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 ,(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
("/config/wizard/apps2")
(let* ((results
("/config/wizard/apps/: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)))))
(app-config . ,(get-user-app-config db (session-user-id)))))))
(get-user-selected-apps db (session-user-id) instance-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))
(app-config (alist-ref 'config (alist-ref 'app-config results))))
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps2-submit") (method POST))
(@ (action ,(conc "/config/wizard/apps2-submit/" instance-id)) (method POST))
(VStack
,@(if (member 'wg-easy selected-apps)
`((Fieldset
@@ -721,33 +742,36 @@ h1, h2, h3, h4, h5, h6 {
(value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
(Field (@ (name "log-viewer-password") (label ("Password")) (type "password")
(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"
(with-db/transaction
(lambda (db)
(update-user-app-config
db
(session-user-id)
`((wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params)))))
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params)))
(admin-user . ,(alist-ref 'nextcloud-admin-user (current-params)))
(admin-password . ,(alist-ref 'nextcloud-admin-password (current-params)))))
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
(user . ,(alist-ref 'log-viewer-user (current-params)))
(password . ,(alist-ref 'log-viewer-password (current-params)))))))))
(redirect "/config/wizard/machine"))
(post "/config/wizard/apps2-submit/:id"
(let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction
(lambda (db)
(update-user-app-config
db
(session-user-id)
instance-id
`((wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params)))))
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params)))
(admin-user . ,(alist-ref 'nextcloud-admin-user (current-params)))
(admin-password . ,(alist-ref 'nextcloud-admin-password (current-params)))))
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
(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
("/config/wizard/machine")
(let ((config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-user-id))))))
("/config/wizard/machine/: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
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine-submit")
(@ (action ,(conc "/config/wizard/machine-submit/" instance-id))
(method POST))
(VStack
(Fieldset
@@ -757,22 +781,25 @@ h1, h2, h3, h4, h5, h6 {
,@(map (lambda (r)
`(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r)))
(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"
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
`((digitalocean-region . ,(alist-ref 'region (current-params)))))))
(redirect "/config/wizard/machine2"))
(post "/config/wizard/machine-submit/:id"
(let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
instance-id
`((digitalocean-region . ,(alist-ref 'region (current-params)))))))
(redirect (conc "/config/wizard/machine2/" instance-id))))
(get/widgets
("/config/wizard/machine2")
(let* ((config (with-db/transaction
("/config/wizard/machine2/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(config (with-db/transaction
(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))
(all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token config)))
(sizes (filter (lambda (s) (member region (alist-ref 'regions s))) all-sizes)))
@@ -780,7 +807,7 @@ h1, h2, h3, h4, h5, h6 {
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine2-submit")
(@ (action ,(conc "/config/wizard/machine2-submit/" instance-id))
(method POST))
(VStack
(Fieldset
@@ -794,28 +821,31 @@ h1, h2, h3, h4, h5, h6 {
" Disk: " ,(alist-ref 'disk s)
") " ,(alist-ref 'description s)))
sizes)))
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine"))))))))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine/" instance-id))))))))))
(post "/config/wizard/machine2-submit"
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
`((digitalocean-size . ,(alist-ref 'size (current-params)))))))
(redirect "/config/wizard/review"))
(post "/config/wizard/machine2-submit/:id"
(let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
instance-id
`((digitalocean-size . ,(alist-ref 'size (current-params)))))))
(redirect (conc "/config/wizard/review/" instance-id))))
(get/widgets
("/config/wizard/review")
(let* ((results
("/config/wizard/review/: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)))))
(app-config . ,(get-user-app-config db (session-user-id)))
(service-config . ,(get-user-service-config db (session-user-id)))))))
(get-user-selected-apps db (session-user-id) instance-id))))
(app-config . ,(get-user-app-config db (session-user-id) instance-id))
(service-config . ,(get-user-service-config db (session-user-id) instance-id))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results))
(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))
(li "Size: " ,(alist-ref 'digitalocean-size service-config)))
(form
(@ (action "/config/wizard/review-submit") (method POST))
(@ (action ,(conc "/config/wizard/review-submit/" instance-id)) (method POST))
(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"
(let* ((results
;; TODO this can only handle a user deploying one instance at a time!
;; 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
(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)))
(service-config . ,(get-user-service-config db (session-user-id)))
(terraform-state . ,(get-user-terraform-state db (session-user-id)))))))
(get-user-selected-apps db (session-user-id) instance-id))))
(app-config . ,(get-user-app-config db (session-user-id) instance-id))
(service-config . ,(get-user-service-config db (session-user-id) instance-id))
(terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config))
@@ -896,8 +929,9 @@ h1, h2, h3, h4, h5, h6 {
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
("flatcar_stable_version" . "4230.2.3")))
(display "ssh_keys=[\"") (display (with-input-from-file (string-append dir "/config/ssh-keys") read-string)) (print "\"]"))))
(let* ((user-id (session-user-id))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id))))
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(user-id (session-user-id))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
(dir (deployment-directory user-id)))
(thread-start!
(lambda ()
@@ -918,9 +952,9 @@ h1, h2, h3, h4, h5, h6 {
(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-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)
@@ -934,17 +968,18 @@ h1, h2, h3, h4, h5, h6 {
db user-id deployment-id
(if exit-normal 'complete 'failed)
(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.backup") read-string))))))))))))
(redirect "/config/wizard/success"))
(redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))
(get/widgets
("/config/wizard/success")
(let* ((res (with-db/transaction
("/config/wizard/success/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(res (with-db/transaction
(lambda (db)
`((status . ,(get-most-recent-deployment-status db (session-user-id)))
(progress . ,(get-most-recent-deployment-progress 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) instance-id))))))
(output (with-input-from-file (string-append (deployment-directory (session-user-id)) "/make-out") read-string))
(progress (alist-ref 'progress res))
(status (alist-ref 'status res)))
@@ -967,10 +1002,13 @@ h1, h2, h3, h4, h5, h6 {
`(App
(Main-Container
(main
(h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Deployments")
(Button "Setup New Deployment")
(h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Instances")
(form
(@ (action "/config/wizard/create-instance")
(method POST))
(Button "Setup New Instance"))
(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 'status deployment)))
(with-db/transaction

204
src/test.scm
View File

File diff suppressed because one or more lines are too long