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

Postgres db integration.

Browse Source
This commit is contained in:
Thomas Hintz
2025-11-10 13:13:59 -08:00
parent 8595014fde
commit fb9c3f8daf
4 changed files with 637 additions and 166 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
src/compose.yaml Normal file
View File

@@ -0,0 +1,15 @@
services:
db:
image: postgres
restart: always
environment:
POSTGRES_USER: nassella
POSTGRES_PASSWORD: password
POSTGRES_DB: nassella
healthcheck:
test: ["CMD-SHELL", "pg_isready", "-U", "nassella"]
interval: 1s
timeout: 5s
retries: 10
ports:
- "5432:5432"

41
src/db-init.sql Normal file
View File

@@ -0,0 +1,41 @@
create table users(
user_id bigserial primary key,
auth_user_id int unique not null,
email varchar(255) not null,
username varchar(255) not null unique,
key_key varchar(255),
key_iv varchar(255));
create unique index users_auth_user_id_idx on users (auth_user_id);
create table user_service_configs(
id bigserial primary key,
user_id integer unique not null references users on delete cascade,
cloudflare_api_token_enc varchar(255),
cloudflare_account_id_enc varchar(255),
cloudflare_zone_id_enc varchar(255),
digitalocean_api_token_enc varchar(255),
digitalocean_region varchar(255),
digitalocean_size varchar(255),
backblaze_application_key_enc varchar(255),
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 table user_selected_apps(
id bigserial primary key,
user_id integer unique not null references users 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 table user_app_configs(
id bigserial primary key,
user_id integer unique not null references users 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);

327
src/db.scm Normal file
View File

@@ -0,0 +1,327 @@
(module nassella-db
(;; parameters
connection-spec
;;functions
with-db with-db/transaction
create-user
update-user-service-config get-user-service-config
update-user-selected-apps get-user-selected-apps
update-user-app-config get-user-app-config
update-root-domain
)
(import scheme
(chicken base)
(chicken blob)
(chicken file)
(chicken string)
(chicken port)
postgresql
sql-null
srfi-1
srfi-13
(openssl cipher)
(openssl random)
crypto-tools)
(define connection-spec (make-parameter '((dbname . "nassella") (user . "nassella") (password . "password") (host . "127.0.0.1"))))
(define db-connection (make-parameter #f))
(define (with-db proc)
(if (db-connection)
(begin (db-connection)
(proc (db-connection)))
(let ((conn #f))
(dynamic-wind
(lambda ()
(set! conn (connect (connection-spec))))
(lambda () (proc conn))
(lambda ()
(when (and (connection? conn) (connected? conn))
(disconnect conn)))))))
(define (with-db/transaction proc)
(with-db
(lambda (conn)
(with-transaction conn
(lambda () (proc conn))))))
;; (with-db (lambda (db) (row-values (query db "select * from users;"))))
(define aes-256-gcm (cipher-by-name "aes-256-gcm"))
(define tag-length 16)
(define (generate-param accessor)
(random-bytes (accessor aes-256-gcm)))
(define (generate-key) (generate-param cipher-key-length))
(define (generate-iv) (generate-param cipher-iv-length))
(define (encrypt message key iv #!optional auth-data)
(string-encrypt-and-digest aes-256-gcm message key iv
tag-length: tag-length
auth-data: auth-data))
(define (decrypt message tag key iv #!optional auth-data)
(string-decrypt-and-verify aes-256-gcm message tag key iv
auth-data: auth-data))
(define *root-key-file* "root-key")
(define (generate-root-key) (generate-key))
(define (save-root-key)
(with-output-to-file *root-key-file* (lambda () (write (blob->hexstring/uppercase (generate-root-key))))))
(define (load-root-key)
(hexstring->blob (with-input-from-file *root-key-file* read)))
(define *root-key-iv* (hexstring->blob "1EBBCF6B50C68593C559EF93"))
(define (ensure-root-key)
(when (not (file-exists? *root-key-file*))
(save-root-key))
(load-root-key))
(define *root-key-key* (ensure-root-key))
(define (get-user-key-and-iv conn user-id)
(row-alist (query conn "select auth_user_id, key_key, key_iv from users where user_id=$1;" user-id)))
(define (get-decrypted-user-key-and-iv conn user-id)
(let* ((auth-user-id-and-user-key-and-iv (get-user-key-and-iv conn user-id))
(raw-user-key-and-tag (alist-ref 'key_key auth-user-id-and-user-key-and-iv))
(raw-user-key (hexstring->blob (string-drop-right raw-user-key-and-tag (* tag-length 2))))
(raw-user-tag (hexstring->blob (string-take-right raw-user-key-and-tag (* tag-length 2))))
(user-key (decrypt (blob->string raw-user-key) (blob->string raw-user-tag) *root-key-key* *root-key-iv*
(string->blob (number->string (alist-ref 'auth_user_id auth-user-id-and-user-key-and-iv)))))
(user-iv (alist-ref 'key_iv auth-user-id-and-user-key-and-iv))
(auth-user-id (alist-ref 'auth_user_id auth-user-id-and-user-key-and-iv)))
(values (hexstring->blob user-key) (hexstring->blob user-iv) auth-user-id)))
(define (user-encrypt message user-key user-iv user-id)
(encrypt message user-key user-iv (string->blob (number->string user-id))))
(define (user-encrypt-for-db message user-key user-iv user-id)
(receive (message tag)
(user-encrypt message user-key user-iv user-id)
(string-append (blob->hexstring/uppercase (string->blob message))
(blob->hexstring/uppercase (string->blob tag)))))
(define (user-decrypt message tag user-key user-iv user-id)
(decrypt message tag user-key user-iv (string->blob (number->string user-id))))
(define (user-decrypt-from-db message-and-tag user-key user-iv user-id)
(let ((raw-message (hexstring->blob (string-drop-right message-and-tag (* tag-length 2))))
(raw-tag (hexstring->blob (string-take-right message-and-tag (* tag-length 2)))))
(user-decrypt (blob->string raw-message) (blob->string raw-tag) user-key user-iv user-id)))
(define (create-user conn auth-user-id email username)
(let ((user-key (blob->hexstring/uppercase (generate-key)))
(user-iv (blob->hexstring/uppercase (generate-iv))))
(receive (enc-user-key tag)
(encrypt user-key *root-key-key* *root-key-iv* (string->blob (number->string auth-user-id)))
;; (write user-key)
;; (newline)
;; (write user-iv)
;; (newline)
;; (write (blob->hexstring/uppercase (string->blob enc-user-key)))
;; (newline)
;; (write (blob->hexstring/uppercase (string->blob tag)))
(let ((user-id
(value-at
(query conn
"insert into users(auth_user_id, email, username, key_key, key_iv) values ($1, $2, $3, $4, $5)
returning users.user_id;"
auth-user-id email username
(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)))))
(define *user-service-configs-column-map*
'((cloudflare-api-token . ("cloudflare_api_token_enc" #t))
(cloudflare-account-id . ("cloudflare_account_id_enc" #t))
(cloudflare-zone-id . ("cloudflare_zone_id_enc" #t))
(digitalocean-api-token . ("digitalocean_api_token_enc" #t))
(digitalocean-region . ("digitalocean_region" #f))
(digitalocean-size . ("digitalocean_size" #f))
(backblaze-application-key . ("backblaze_application_key_enc" #t))
(backblaze-key-id . ("backblaze_key_id_enc" #t))
(backblaze-bucket-url . ("backblaze_bucket_url_enc" #t))))
(define *user-service-configs-reverse-column-map*
(map (lambda (config)
`(,(string->symbol (cadr config)) . (,(car config) ,(caddr config))))
*user-service-configs-column-map*))
(define (update-user-service-config conn user-id update-alist)
(let ((valid-keys (map car *user-service-configs-column-map*)))
(for-each (lambda (update)
(if (not (memq (car update) valid-keys))
(error (string-append "Not a valid update key: " (->string (car update))))))
update-alist))
(receive (user-key user-iv auth-user-id)
(get-decrypted-user-key-and-iv conn user-id)
(query* conn
(string-append
"update user_service_configs set "
(string-intersperse
(map-in-order (lambda (update i)
(conc (car (alist-ref (car update) *user-service-configs-column-map*))
"=$" i))
update-alist
(iota (length update-alist) 2))
", ")
" 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)))))
(define (get-user-service-config conn user-id)
(receive (user-key user-iv auth-user-id)
(get-decrypted-user-key-and-iv conn user-id)
(let ((res (row-alist
(query conn
(string-append
"select "
(string-intersperse
(map-in-order (lambda (update)
(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))))
(map (lambda (item)
(let* ((key (car item))
(value (cdr item))
(config (alist-ref key *user-service-configs-reverse-column-map*)))
`(,(car config) . ,(if (sql-null? value)
""
(if (cadr config)
(user-decrypt-from-db value user-key user-iv user-id)
value)))))
res))))
(define *user-selected-apps-column-map*
'((wg-easy . "wg_easy_version")
(nextcloud . "nextcloud_version")
(log-viewer . "log_viewer_version")))
(define *user-selected-apps-reverse-column-map*
(map (lambda (config)
`(,(string->symbol (cdr config)) . ,(car config)))
*user-selected-apps-column-map*))
(define (update-user-selected-apps conn user-id app-alist)
(let ((valid-keys (map car *user-selected-apps-column-map*)))
(for-each (lambda (app)
(if (not (memq (car app) valid-keys))
(error (string-append "Not a valid app key: " (->string (car app))))))
app-alist))
(query* conn
(string-append
"update user_selected_apps set "
(string-intersperse
(map-in-order (lambda (app i)
(conc (alist-ref (car app) *user-selected-apps-column-map*)
"=$" i))
app-alist
(iota (length app-alist) 2))
", ")
" where user_id=$1;")
(cons user-id
(map-in-order cdr app-alist))))
(define (get-user-selected-apps conn user-id)
(let ((res (row-alist
(query conn
(string-append
"select "
(string-intersperse
(map-in-order cdr *user-selected-apps-column-map*)
", ")
" from user_selected_apps where user_id=$1;")
user-id))))
(map (lambda (item)
(let* ((key (car item))
(value (cdr item))
(config (alist-ref key *user-selected-apps-reverse-column-map*)))
`(,config . ,(if (sql-null? value)
#f
value))))
res)))
(define (update-user-app-config conn user-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;"
(user-encrypt-for-db
(with-output-to-string
(lambda ()
(write config)))
user-key user-iv user-id)
user-id)))
(define (update-root-domain conn user-id root-domain)
(query conn
"update user_app_configs set root_domain=$1 where user_id=$2;"
root-domain
user-id))
(define (get-user-app-config conn user-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))))
`((root-domain . ,(if (sql-null? (alist-ref 'root_domain res))
#f
(alist-ref 'root_domain res)))
(config . ,(if (sql-null? (alist-ref 'config_enc res))
'()
(with-input-from-string
(user-decrypt-from-db (alist-ref 'config_enc res) user-key user-iv user-id)
read)))))))
;; (with-db/transaction (lambda (db) (create-user db 1 "t@thintz.com" "thecombjelly")))
;; (let ((user-id 7))
;; (with-db/transaction
;; (lambda (db)
;; (receive (user-key user-iv auth-user-id)
;; (get-decrypted-user-key-and-iv db user-id)
;; (receive (message tag)
;; (user-encrypt "hello!" user-key user-iv user-id)
;; (user-decrypt message tag user-key user-iv user-id))))))
;; (with-db/transaction
;; (lambda (db)
;; (update-user-service-config db 7 '((cloudflare-api-token . ")
;; (digitalocean-region . "sfo3")))))
;; (with-db/transaction
;; (lambda (db)
;; (get-user-service-config db 7)))
;; (with-db/transaction
;; (lambda (db)
;; (update-user-selected-apps db 7 '((wg-easy . "0.1")
;; (nextcloud . "1.3")))))
;; (with-db/transaction
;; (lambda (db)
;; (get-user-selected-apps db 7)))
;; (with-db/transaction
;; (lambda (db)
;; (update-user-app-config db 7 "domain.com" '())))
;; (with-db/transaction
;; (lambda (db)
;; (get-user-app-config db 7)))
)

420
src/nassella.scm
View File

@@ -1,18 +1,25 @@
(import sxml-transforms (chicken string) (chicken port) html-widgets
(load "db.scm")
(import (chicken string)
(chicken port)
(chicken io)
(chicken pretty-print)
(chicken process)
(chicken process-context)
(rename srfi-1 (delete srfi1:delete))
html-widgets
sxml-transforms
(prefix schematra schematra:)
schematra-body-parser
schematra-session
(rename srfi-1 (delete srfi1:delete))
uri-common
http-client
medea
intarweb
(chicken io)
openssl
(chicken pretty-print)
(chicken io)
(chicken process)
(chicken process-context))
nassella-db
sql-null)
(schematra:use-middleware! (body-parser-middleware))
@@ -273,7 +280,7 @@ h1, h2, h3, h4, h5, h6 {
'((meta (@ (name "viewport") (content "width=device-width"))))
(begin
;; TODO remove once sessions are integrated
(session-set! "user-id" "12345")
(session-set! "user-id" 7)
(session-set! "username" "me")
body ...))))))))
@@ -456,41 +463,44 @@ h1, h2, h3, h4, h5, h6 {
(cursor "pointer"))))
,submit-button)))
(define *data*
'())
(get
("/config/wizard/services")
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/services-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(Field (@ (name "cloudflare-api-token") (label ("API Token")) (value ,(alist-ref 'cloudflare-api-token *data*))))
(Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (value ,(alist-ref 'cloudflare-zone-id *data*))))
(Field (@ (name "cloudflare-account-id") (label ("Account ID")) (value ,(alist-ref 'cloudflare-account-id *data*)))))
(Fieldset
(@ (title "DigitalOcean"))
(Field (@ (name "digitalocean-api-token") (label ("API Token")) (value ,(alist-ref 'digitalocean-api-token *data*)))))
(Fieldset
(@ (title "Backblaze"))
(Field (@ (name "backblaze-application-key") (label ("Application Key")) (value ,(alist-ref 'backblaze-application-key *data*))))
(Field (@ (name "backblaze-key-id") (label ("Key ID")) (value ,(alist-ref 'backblaze-key-id *data*))))
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url *data*)))))
(Form-Nav))))))
(let ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-get "user-id"))))))
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/services-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(Field (@ (name "cloudflare-api-token") (label ("API Token")) (value ,(alist-ref 'cloudflare-api-token config))))
(Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (value ,(alist-ref 'cloudflare-zone-id config))))
(Field (@ (name "cloudflare-account-id") (label ("Account ID")) (value ,(alist-ref 'cloudflare-account-id config)))))
(Fieldset
(@ (title "DigitalOcean"))
(Field (@ (name "digitalocean-api-token") (label ("API Token")) (value ,(alist-ref 'digitalocean-api-token config)))))
(Fieldset
(@ (title "Backblaze"))
(Field (@ (name "backblaze-application-key") (label ("Application Key")) (value ,(alist-ref 'backblaze-application-key config))))
(Field (@ (name "backblaze-key-id") (label ("Key ID")) (value ,(alist-ref 'backblaze-key-id config))))
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url config)))))
(Form-Nav)))))))
(schematra:post ("/config/wizard/services-submit")
(set! *data* (alist-update 'cloudflare-api-token (alist-ref 'cloudflare-api-token (schematra:current-params)) *data*))
(set! *data* (alist-update 'cloudflare-account-id (alist-ref 'cloudflare-account-id (schematra:current-params)) *data*))
(set! *data* (alist-update 'cloudflare-zone-id (alist-ref 'cloudflare-zone-id (schematra:current-params)) *data*))
(set! *data* (alist-update 'digitalocean-api-token (alist-ref 'digitalocean-api-token (schematra:current-params)) *data*))
(set! *data* (alist-update 'backblaze-application-key (alist-ref 'backblaze-application-key (schematra:current-params)) *data*))
(set! *data* (alist-update 'backblaze-key-id (alist-ref 'backblaze-key-id (schematra:current-params)) *data*))
(set! *data* (alist-update 'backblaze-bucket-url (alist-ref 'backblaze-bucket-url (schematra:current-params)) *data*))
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-get "user-id")
`((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (schematra:current-params)))
(cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (schematra:current-params)))
(cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (schematra:current-params)))
(digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (schematra:current-params)))
(backblaze-application-key . ,(alist-ref 'backblaze-application-key (schematra:current-params)))
(backblaze-key-id . ,(alist-ref 'backblaze-key-id (schematra:current-params)))
(backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (schematra:current-params)))))))
(schematra:redirect "/config/wizard/services-success"))
(get
@@ -517,64 +527,98 @@ h1, h2, h3, h4, h5, h6 {
(get
("/config/wizard/apps")
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps-submit") (method POST))
(VStack
(Fieldset
(@ (title "Root Domain"))
(Field (@ (element select) (name "root-domain"))
(option (@ (value (alist-ref 'root-domain *data*))) "nassella.cc")))
(Fieldset
(@ (title "Selected Apps"))
(Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps *data*)))))
(Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'wg-easy (alist-ref 'selected-apps *data*)))))
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
(Form-Nav (@ (back-to "/config/wizard/services-success"))))))))
(let ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id"))))))))
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps-submit") (method POST))
(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?
(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")))))))))
(schematra:post ("/config/wizard/apps-submit")
(set! *data* (alist-update 'root-domain (alist-ref 'root-domain (schematra:current-params)) *data*))
(set! *data* (alist-update 'selected-apps
`(,@(if (alist-ref 'wg-easy (schematra:current-params)) '(wg-easy) '())
,@(if (alist-ref 'nextcloud (schematra:current-params)) '(nextcloud) '())
log-viewer)
*data*))
(with-db/transaction
(lambda (db)
(update-user-selected-apps
db
(session-get "user-id")
`((wg-easy . ,(or (and (alist-ref 'wg-easy (schematra:current-params)) "0.0") (sql-null)))
(nextcloud . ,(or (and (alist-ref 'nextcloud (schematra:current-params)) "0.0") (sql-null)))))
(update-root-domain db (session-get "user-id") (alist-ref 'root-domain (schematra:current-params)))))
(schematra:redirect "/config/wizard/apps2"))
(get
("/config/wizard/apps2")
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps2-submit") (method POST))
(VStack
,@(if (member 'wg-easy (alist-ref 'selected-apps *data*))
`((Fieldset
(@ (title "WG-Easy"))
(Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (value ,(alist-ref 'wg-easy-subdomain *data*))))))
'())
,@(if (member 'nextcloud (alist-ref 'selected-apps *data*))
`((Fieldset
(@ (title "NextCloud"))
(Field (@ (name "nextcloud-subdomain") (label ("Subdomain")) (value ,(alist-ref 'nextcloud-subdomain *data*))))
(Field (@ (name "nextcloud-admin-user") (label ("Admin Username")) (value ,(alist-ref 'nextcloud-admin-user *data*))))
(Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password") (value ,(alist-ref 'nextcloud-admin-password *data*))))))
'())
(Fieldset
(@ (title "Log Viewer"))
(Field (@ (name "log-viewer-subdomain") (label ("Subdomain")) (value ,(alist-ref 'log-viewer-subdomain *data*))))
(Field (@ (name "log-viewer-user") (label ("Username")) (value ,(alist-ref 'log-viewer-user *data*))))
(Field (@ (name "log-viewer-password") (label ("Password")) (type "password") (value ,(alist-ref 'log-viewer-password *data*)))))
(Form-Nav (@ (back-to "/config/wizard/apps"))))))))
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id")))))))
(selected-apps (alist-ref 'selected-apps results))
(app-config (alist-ref 'app-config results)))
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps2-submit") (method POST))
(VStack
,@(if (member 'wg-easy selected-apps)
`((Fieldset
(@ (title "WG-Easy"))
(Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'wg-easy app-config eq? '()) eq? "wg-easy"))))))
'())
,@(if (member 'nextcloud selected-apps)
`((Fieldset
(@ (title "NextCloud"))
(Field (@ (name "nextcloud-subdomain") (label ("Subdomain"))
(value ,(alist-ref 'subdomain (alist-ref 'nextcloud app-config eq? '()) eq? "nextcloud"))))
(Field (@ (name "nextcloud-admin-user") (label ("Admin Username"))
(value ,(alist-ref 'admin-user (alist-ref 'nextcloud app-config eq? '()) eq? "admin"))))
(Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password")
(value ,(alist-ref 'admin-password (alist-ref 'nextcloud app-config eq? '()) eq? ""))))))
'())
(Fieldset
(@ (title "Log Viewer"))
(Field (@ (name "log-viewer-subdomain") (label ("Subdomain"))
(value ,(alist-ref 'subdomain (alist-ref 'log-viewer app-config eq? '()) eq? "logs"))))
(Field (@ (name "log-viewer-user") (label ("Username"))
(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")))))))))
(schematra:post ("/config/wizard/apps2-submit")
(set! *data* (alist-update 'nextcloud-admin-user (alist-ref 'nextcloud-admin-user (schematra:current-params)) *data*))
(set! *data* (alist-update 'nextcloud-admin-password (alist-ref 'nextcloud-admin-password (schematra:current-params)) *data*))
(set! *data* (alist-update 'log-viewer-user (alist-ref 'log-viewer-user (schematra:current-params)) *data*))
(set! *data* (alist-update 'log-viewer-password (alist-ref 'log-viewer-password (schematra:current-params)) *data*))
(with-db/transaction
(lambda (db)
(update-user-app-config
db
(session-get "user-id")
`((wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (schematra:current-params)))))
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (schematra:current-params)))
(admin-user . ,(alist-ref 'nextcloud-admin-user (schematra:current-params)))
(admin-password . ,(alist-ref 'nextcloud-admin-password (schematra:current-params)))))
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (schematra:current-params)))
(user . ,(alist-ref 'log-viewer-user (schematra:current-params)))
(password . ,(alist-ref 'log-viewer-password (schematra:current-params)))))))))
(schematra:redirect "/config/wizard/machine"))
;; Parsing JSON arrays as lists instead of vectors
@@ -611,30 +655,41 @@ h1, h2, h3, h4, h5, h6 {
(get
("/config/wizard/machine")
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Region"))
(Field (@ (element select) (name "region"))
(option (@ (value "")) "")
,@(map (lambda (r)
`(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r)))
(get-digital-ocean-regions (alist-ref 'digitalocean-api-token *data*)))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2")))))))))
(let ((config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-get "user-id"))))))
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Region"))
(Field (@ (element select) (name "region"))
(option (@ (value "")) "")
,@(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"))))))))))
(schematra:post ("/config/wizard/machine-submit")
(set! *data* (alist-update 'digitalocean-region (alist-ref 'region (schematra:current-params)) *data*))
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-get "user-id")
`((digitalocean-region . ,(alist-ref 'region (schematra:current-params)))))))
(schematra:redirect "/config/wizard/machine2"))
(get
("/config/wizard/machine2")
(let* ((region (alist-ref 'digitalocean-region *data*))
(all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token *data*)))
(let* ((config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-get "user-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)))
`(App
(Configuration-Wizard
@@ -657,74 +712,107 @@ h1, h2, h3, h4, h5, h6 {
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine"))))))))))
(schematra:post ("/config/wizard/machine2-submit")
(set! *data* (alist-update 'digitalocean-size (alist-ref 'size (schematra:current-params)) *data*))
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-get "user-id")
`((digitalocean-size . ,(alist-ref 'size (schematra:current-params)))))))
(schematra:redirect "/config/wizard/review"))
(get
("/config/wizard/review")
`(App
(Configuration-Wizard
(@ (step "Review"))
(h2 "Root Domain")
,(alist-ref 'root-domain *data*)
(h2 "Apps")
(ul ,@(map (lambda (app) `(li ,app " @ "
,(alist-ref (string->symbol (conc (symbol->string app) "-subdomain")) *data*)
"."
,(alist-ref 'root-domain *data*)))
(alist-ref 'selected-apps *data*)))
(h2 "Machine")
(ul (li "Region: " ,(alist-ref 'digitalocean-region *data*))
(li "Size: " ,(alist-ref 'digitalocean-size *data*)))
(form
(@ (action "/config/wizard/review-submit") (method POST))
(VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2")) (submit-button "Launch"))))))))
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id")))
(service-config . ,(get-user-service-config db (session-get "user-id")))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config))
(root-domain (alist-ref 'root-domain app-config))
(service-config (alist-ref 'service-config results)))
`(App
(Configuration-Wizard
(@ (step "Review"))
(h2 "Root Domain")
,root-domain
(h2 "Apps")
(ul ,@(map (lambda (app) `(li ,app " @ "
,(alist-ref 'subdomain (alist-ref app config))
"."
,root-domain))
selected-apps))
(h2 "Machine")
(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))
(VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2")) (submit-button "Launch")))))))))
(define (write-config-entry name key-or-value)
(define (write-config-entry name value)
(display name)
(display "=\"")
(display (if (symbol? key-or-value) (alist-ref key-or-value *data*) key-or-value))
(display value)
(print "\""))
(schematra:post ("/config/wizard/review-submit")
(with-output-to-file "deploy/config/apps.config"
(lambda ()
(map (lambda (e)
(write-config-entry (car e) (cdr e)))
`(("ROOT_DOMAIN" . root-domain)
("APP_CONFIGS" . ,(string-intersperse
(map (lambda (app)
(conc (if (eq? app 'log-viewer) 'dozzle app)
","
(alist-ref (string->symbol (conc (symbol->string app) "-subdomain")) *data*)))
(alist-ref 'selected-apps *data*))
" "))
("HOST_ADMIN_USER" . log-viewer-user)
("HOST_ADMIN_PASSWORD" . log-viewer-password)
("NEXTCLOUD_ADMIN_USER" . nextcloud-admin-user)
("NEXTCLOUD_ADMIN_PASSWORD" . nextcloud-admin-password)
("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
("NEXTCLOUD_POSTGRES_PASSWORD" . "dbpassword")
("NEXTCLOUD_REDIS_PASSWORD" . "redispassword")
("BACKBLAZE_KEY_ID" . backblaze-key-id)
("BACKBLAZE_APPLICATION_KEY" . backblaze-application-key)
("BACKBLAZE_BUCKET_URL" . backblaze-bucket-url)
("RESTIC_PASSWORD" . "foodisgood")))))
(with-output-to-file "deploy/config/production.tfvars"
(lambda ()
(map (lambda (e)
(write-config-entry (car e) (cdr e)))
`(("server_type" . digitalocean-size)
("do_token" . digitalocean-api-token)
("cloudflare_api_token" . cloudflare-api-token)
("cloudflare_zone_id" . cloudflare-zone-id)
("cloudflare_account_id" . cloudflare-account-id)
("cluster_name" . "mycluster")
("datacenter" . digitalocean-region)
("flatcar_stable_version" . "4230.2.3")))
(display "ssh_keys=[\"") (display (with-input-from-file "deploy/config/ssh-keys" read-string)) (print "\"]")))
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id")))
(service-config . ,(get-user-service-config db (session-get "user-id")))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config))
(root-domain (alist-ref 'root-domain app-config))
(service-config (alist-ref 'service-config results)))
(with-output-to-file "deploy/config/apps.config"
(lambda ()
(map (lambda (e)
(write-config-entry (car e) (cdr e)))
`(("ROOT_DOMAIN" . ,root-domain)
("APP_CONFIGS" . ,(string-intersperse
(map (lambda (app)
(conc (if (eq? app 'log-viewer) 'dozzle app)
","
(alist-ref 'subdomain (alist-ref app config))))
selected-apps)
" "))
("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config)))
("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
("NEXTCLOUD_POSTGRES_PASSWORD" . "dbpassword")
("NEXTCLOUD_REDIS_PASSWORD" . "redispassword")
("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
("RESTIC_PASSWORD" . "foodisgood")))))
(with-output-to-file "deploy/config/production.tfvars"
(lambda ()
(map (lambda (e)
(write-config-entry (car e) (cdr e)))
`(("server_type" . ,(alist-ref 'digitalocean-size service-config))
("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
("cluster_name" . "mycluster")
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
("flatcar_stable_version" . "4230.2.3")))
(display "ssh_keys=[\"") (display (with-input-from-file "deploy/config/ssh-keys" read-string)) (print "\"]"))))
(change-directory "deploy")
(session-set! "pid" (process-run "make apply > make-out"))
(change-directory "../")