diff --git a/src/compose.yaml b/src/compose.yaml new file mode 100644 index 0000000..5e15033 --- /dev/null +++ b/src/compose.yaml @@ -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" diff --git a/src/db-init.sql b/src/db-init.sql new file mode 100644 index 0000000..aee491b --- /dev/null +++ b/src/db-init.sql @@ -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); diff --git a/src/db.scm b/src/db.scm new file mode 100644 index 0000000..7f35612 --- /dev/null +++ b/src/db.scm @@ -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))) + +) diff --git a/src/nassella.scm b/src/nassella.scm index f184979..948741b 100644 --- a/src/nassella.scm +++ b/src/nassella.scm @@ -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 "../")