diff --git a/cl.yaml b/cl.yaml index afc97d6..1be9d70 100644 --- a/cl.yaml +++ b/cl.yaml @@ -31,7 +31,7 @@ systemd: [Service] Type=oneshot EnvironmentFile=/restic-env - ExecStart=/usr/bin/bash -c "docker run --rm --volume /nassella:/nassella --volume /restic-password:/restic-password -e AWS_ACCESS_KEY_ID=${AWS_ACCESS_KEY_ID} -e AWS_SECRET_ACCESS_KEY=${AWS_SECRET_ACCESS_KEY} -i restic/restic:0.18.0 backup --verbose --repo s3:s3.us-west-004.backblazeb2.com/nassella-test-bucket --password-file /restic-password /nassella" + ExecStart=/usr/bin/bash -c "docker run --rm --volume /nassella:/nassella --volume /restic-password:/restic-password -e AWS_ACCESS_KEY_ID=${AWS_ACCESS_KEY_ID} -e AWS_SECRET_ACCESS_KEY=${AWS_SECRET_ACCESS_KEY} -i restic/restic:0.18.0 backup --verbose --repo s3:${BACKBLAZE_BUCKET_URL} --password-file /restic-password /nassella" ExecStopPost=systemctl start app.service - name: restic-backup.timer diff --git a/main.tf b/main.tf index 64df1b5..9985379 100644 --- a/main.tf +++ b/main.tf @@ -137,6 +137,7 @@ resource "digitalocean_droplet" "machine" { size = var.server_type ssh_keys = [digitalocean_ssh_key.first.fingerprint] user_data = file("ignition.json") + graceful_shutdown = true lifecycle { create_before_destroy = true } diff --git a/make-restic-generated.sh b/make-restic-generated.sh index 3957aea..9319d00 100755 --- a/make-restic-generated.sh +++ b/make-restic-generated.sh @@ -6,3 +6,4 @@ set -e echo "AWS_ACCESS_KEY_ID=\"$BACKBLAZE_KEY_ID\"" echo "AWS_SECRET_ACCESS_KEY=\"$BACKBLAZE_APPLICATION_KEY\"" +echo "BACKBLAZE_BUCKET_URL=\"$BACKBLAZE_BUCKET_URL\"" diff --git a/src/db-init.sql b/src/db-init.sql index 52e82a6..1fc6d55 100644 --- a/src/db-init.sql +++ b/src/db-init.sql @@ -10,7 +10,10 @@ 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 + user_id integer not null references users on delete cascade, + ssh_key_priv_enc text, + ssh_key_pub_enc text, + restic_password_enc varchar(255) ); create unique index instances_user_id_instance_id_idx on instances (instance_id, user_id); diff --git a/src/db.scm b/src/db.scm index 9bf0e5c..5cda4b5 100644 --- a/src/db.scm +++ b/src/db.scm @@ -7,6 +7,9 @@ create-user delete-user create-instance get-user-instances + get-instance-ssh-pub-key get-instance-ssh-priv-key + update-instance-ssh-pub-key + get-instance-restic-password update-user-service-config get-user-service-config update-user-selected-apps get-user-selected-apps update-user-app-config get-user-app-config @@ -18,7 +21,7 @@ update-deployment-progress get-deployment-progress get-most-recent-deployment-progress update-user-terraform-state get-user-terraform-state - get-user-deployments + get-dashboard ) (import scheme @@ -106,7 +109,7 @@ (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)))) + (encrypt message user-key user-iv (string->blob (->string user-id)))) (define (user-encrypt-for-db message user-key user-iv user-id) (receive (message tag) @@ -115,7 +118,7 @@ (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)))) + (decrypt message tag user-key user-iv (string->blob (->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)))) @@ -141,16 +144,57 @@ returning users.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)) +;; We also encrypt the ssh pub key not to hide it but to make it +;; more difficult for someone to tamper with it which could allow +;; an attacker to poison an instance with an ssh key that they have +;; access to +(define (create-instance conn user-id ssh-key-priv ssh-key-pub restic-password) + (receive (user-key user-iv auth-user-id) + (get-decrypted-user-key-and-iv conn user-id) + (let ((instance-id + (value-at + (query conn + "insert into instances(user_id, ssh_key_priv_enc, ssh_key_pub_enc, restic_password_enc) values ($1, $2, $3, $4) returning instances.instance_id;" + user-id + (user-encrypt-for-db ssh-key-priv user-key user-iv user-id) + (user-encrypt-for-db ssh-key-pub user-key user-iv user-id) + (user-encrypt-for-db restic-password user-key user-iv 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-instance-ssh-priv-key conn user-id instance-id) + (receive (user-key user-iv auth-user-id) + (get-decrypted-user-key-and-iv conn user-id) + (user-decrypt-from-db + (value-at (query conn "select ssh_key_priv_enc from instances where user_id=$1 and instance_id=$2;" + user-id instance-id)) + user-key user-iv user-id))) + +(define (get-instance-ssh-pub-key conn user-id instance-id) + (receive (user-key user-iv auth-user-id) + (get-decrypted-user-key-and-iv conn user-id) + (user-decrypt-from-db + (value-at (query conn "select ssh_key_pub_enc from instances where user_id=$1 and instance_id=$2;" + user-id instance-id)) + user-key user-iv user-id))) + +(define (update-instance-ssh-pub-key conn user-id instance-id ssh-pub-key) + (receive (user-key user-iv auth-user-id) + (get-decrypted-user-key-and-iv conn user-id) + (query conn "update instances set ssh_key_pub_enc=$3 where user_id=$1 and instance_id=$2;" + user-id instance-id + (user-encrypt-for-db ssh-pub-key user-key user-iv user-id)))) + +(define (get-instance-restic-password conn user-id instance-id) + (receive (user-key user-iv auth-user-id) + (get-decrypted-user-key-and-iv conn user-id) + (user-decrypt-from-db + (value-at (query conn "select restic_password_enc from instances where user_id=$1 and instance_id=$2;" + user-id instance-id)) + user-key user-iv user-id))) (define (get-user-instances conn user-id) (column-values (query conn "select instance_id from instances where user_id=$1;" user-id))) @@ -411,34 +455,50 @@ returning users.user_id;" value))))) res))) -(define (get-user-deployments conn user-id) - (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 +(define (get-dashboard conn user-id) + (receive (user-key user-iv auth-user-id) + (get-decrypted-user-key-and-iv conn user-id) + (let ((res + (query conn + (string-append + "select " + (string-intersperse + (map-in-order (lambda (d) (string-append "d." (cdr d))) *deployments-column-map*) + ", ") + ", uac.root_domain, uac.config_enc, uac.instance_id, " + "usa.wg_easy_version, usa.nextcloud_version, usa.log_viewer_version, usa.ghost_version " + "from instances as i " + "join (select instance_id, max(id) as id from deployments group by instance_id) d2 " + "on d2.instance_id = i.instance_id " + "join deployments d on d.id = d2.id " + "join user_app_configs uac on uac.user_id = d.user_id and uac.instance_id = d.instance_id " + "join user_selected_apps usa on usa.instance_id = uac.instance_id " + "where i.user_id=$1;") + user-id))) + (map + (lambda (row-num) (map (lambda (item) (let* ((key (car item)) (value (cdr item)) - (config (alist-ref key (cons '(root_domain . root-domain) *deployments-reverse-column-map*)))) + (config (alist-ref key `((root_domain . root-domain) + (config_enc . config) + (instance_id . instance-id) + (wg_easy_version . wg-easy) + (nextcloud_version . nextcloud) + (ghost_version . ghost) + (log_viewer_version . log-viewer) + ,@*deployments-reverse-column-map*)))) `(,config . ,(if (sql-null? value) #f - (if (string? value) + (if (and (string? value) (member config *deployments-column-map*)) (string->symbol value) - value))))) - res))))) + (if (eq? key 'config_enc) + (with-input-from-string + (user-decrypt-from-db value user-key user-iv user-id) + read) + value)))))) + (row-alist res row-num))) + (iota (row-count res)))))) (define (update-user-terraform-state conn user-id instance-id state backup) (receive (user-key user-iv auth-user-id) @@ -456,10 +516,12 @@ returning users.user_id;" (let ((res (row-alist (query conn "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)) + `((state . ,(if (or (sql-null? (alist-ref 'config_enc res)) + (sql-null? (alist-ref 'state_enc res))) "" (user-decrypt-from-db (alist-ref 'state_enc res) user-key user-iv user-id))) - (backup . ,(if (sql-null? (alist-ref 'config_enc res)) + (backup . ,(if (or (sql-null? (alist-ref 'config_enc res)) + (sql-null? (alist-ref 'state_backup_enc res))) "" (user-decrypt-from-db (alist-ref 'state_backup_enc res) user-key user-iv user-id))))))) diff --git a/src/nassella.scm b/src/nassella.scm index 9751910..5272c2f 100644 --- a/src/nassella.scm +++ b/src/nassella.scm @@ -9,9 +9,13 @@ (chicken process-context) (chicken irregex) (chicken file) + (chicken condition) (rename srfi-1 (delete srfi1:delete)) + srfi-13 srfi-18 + srfi-158 + srfi-194 html-widgets sxml-transforms @@ -23,7 +27,8 @@ medea intarweb nassella-db - sql-null) + sql-null + openssl) (define app (schematra/make-app)) @@ -295,11 +300,16 @@ h1, h2, h3, h4, h5, h6 { (define-syntax get/widgets (syntax-rules () ((_ (path) body ...) + (get/widgets (path '()) body ...)) + ((_ (path headers) body ...) (get path (with-output-to-string (lambda () (widget-sxml->html - '((meta (@ (name "viewport") (content "width=device-width")))) + (cons + '(meta (@ (name "viewport") (content "width=device-width"))) + headers) + ;; `((meta (@ (name "viewport") (content "width=device-width")))) (begin ;; TODO remove once sessions are integrated (session-set! "user-id" (test-user-id)) @@ -470,16 +480,23 @@ h1, h2, h3, h4, h5, h6 { ,(if (equal? type "checkbox") input label) ,(if (equal? type "checkbox") label input)))) -(define-widget (Button ((type "submit")) contents) +(define-widget (Button ((type "submit") (enabled #t)) contents) `(button (@ (type ,type) - (style ((background ,($ 'color.primary)) - (color ,($ 'color.primary.contrast)) + ,@(if enabled '() '((disabled))) + (style ((background ,(if enabled + ($ 'color.primary) + ($ 'color.primary.contrast))) + (color ,(if enabled + ($ 'color.primary.contrast) + ($ 'color.primary))) (border-radius ,($ 'radius.medium)) (border-color ,($ 'color.primary.shade)) - (cursor "pointer")))) + ,@(if enabled + '((cursor "pointer")) + '())))) ,@contents)) -(define-widget (Form-Nav ((back-to #f) (submit-button "Next"))) +(define-widget (Form-Nav ((back-to #f) (submit-button "Next") (submit-enabled #t))) `(HStack (@ (style ((justify-content "space-between")))) (a (@ (href ,(or back-to "")) @@ -496,7 +513,7 @@ h1, h2, h3, h4, h5, h6 { '() '((pointer-events "none")))))) "Back") - (Button ,submit-button))) + (Button (@ (enabled ,submit-enabled)) ,submit-button))) ;; Parsing JSON arrays as lists instead of vectors (define array-as-list-parser @@ -534,6 +551,78 @@ h1, h2, h3, h4, h5, h6 { (Authorization ,(conc "Bearer " api-token))))))) (with-input-from-request req #f read-json)))))) +(define (get-cloudflare-domains api-token) + (map + (lambda (x) + (alist-ref 'name x)) + (alist-ref + 'result + (let* ((uri (uri-reference "https://api.cloudflare.com/client/v4/zones")) + (req (make-request method: 'GET + uri: uri + headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw))))))) + (with-input-from-request req #f read-json) + ;; (handle-exceptions exn (get-condition-property exn 'client-error 'body) + ;; (with-input-from-request req #f read-json)) + )))) + +;; TODO this currently only supports the first page +;; Example return json: +;; ((result ((id . "aaa") (name . "example.org") (status . "active") +;; (paused . #f) (type . "full") (development_mode . 0) +;; (name_servers "abby.ns.cloudflare.com" "toby.ns.cloudflare.com") +;; (original_name_servers . null) (original_registrar . null) (original_dnshost . null) +;; (modified_on . "2025-08-13T17:17:10.664419Z") (created_on . "2025-08-13T17:17:05.956271Z") +;; (activated_on . "2025-08-13T17:17:10.476671Z") (vanity_name_servers) +;; (vanity_name_servers_ips . null) +;; (meta (step . 4) (custom_certificate_quota . 0) (page_rule_quota . 3) (phishing_detected . #f)) +;; (owner (id . null) (type . "user") (email . null)) +;; (account (id . "aaa") (name . "XXX's Account")) +;; (tenant (id . null) (name . null)) (tenant_unit (id . null)) +;; (permissions "#dns_records:edit" "#dns_records:read" "#zone:read") +;; (plan (id . "0feeeeeeeeeeeeeeeeeeeeeeeeeeeeee") (name . "Free Website") (price . 0) +;; (currency . "USD") (frequency . "") (is_subscribed . #f) (can_subscribe . #f) +;; (legacy_id . "free") (legacy_discount . #f) (externally_managed . #f)))) +;; (result_info (page . 1) (per_page . 20) (total_pages . 1) (count . 1) (total_count . 1)) +;; (success . #t) (errors) (messages)) +(define (test-cloudflare-connection api-token zone-id account-id) + (let* ((uri (uri-reference "https://api.cloudflare.com/client/v4/zones")) + (req (make-request method: 'GET + uri: uri + headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw))))))) + (let ((res (handle-exceptions exn (read-json (get-condition-property exn 'client-error 'body)) + (with-input-from-request req #f read-json)))) + (if (alist-ref 'success res) + (let ((matches + (filter (lambda (x) (and (string=? (alist-ref 'id x) zone-id) + (string=? (alist-ref 'id (alist-ref 'account x)) account-id))) + (alist-ref 'result res)))) + (if (null? matches) + '((success . #f) + (errors ((message . "Account ID and/or Zone ID does not match API Token.")))) + '((success . #t) + (result ,matches)))) + res)))) + +(define (test-digitalocean-connection api-token) + (let* ((uri (uri-reference "https://api.digitalocean.com/v2/account")) + (req (make-request method: 'GET + uri: uri + headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw))))))) + (let ((res (handle-exceptions exn (read-json (get-condition-property exn 'client-error 'body)) + (with-input-from-request req #f read-json)))) + (if (alist-ref 'account res) + (if (string=? (alist-ref 'status (alist-ref 'account res)) "active") + `((success . #t) + (result ,res)) + '((success . #f) + (errors ((message . "Token is valid but account status is not 'active'."))))) + `((success . #f) + (errors ((message . ,(alist-ref 'message res))))))))) + +;; (define (test-backblaze-connection key-id application-key bucket-url) +;; ) + (define (deployment-directory user-id) (string-append "deploy-" (number->string user-id))) @@ -579,13 +668,84 @@ h1, h2, h3, h4, h5, h6 { ((complete) "complete") ((failed) "failed"))) +;; (with-db/transaction +;; (lambda (db) +;; (update-instance-ssh-pub-key db 1 22 ""))) + +;; (with-db/transaction +;; (lambda (db) +;; (get-instance-ssh-pub-key db 1 22))) + +;; Generates an ssh key via ssh-keygen running in docker +;; Returns a list with the first element being the private key +;; and the second element being the corresponding public key. +;; Does not leave a trace of the generated keys on the filesystem. +(define (generate-ssh-key user-id) + (define (generate-ssh-key_ filepath counter) + (if (directory-exists? (conc filepath counter)) + (generate-ssh-key_ filepath (+ counter 1)) + (conc filepath counter))) + (let ((key-path (generate-ssh-key_ (conc "temp-ssh-keys-" user-id "-") 0))) + (create-directory key-path) + (receive (in-port out-port pid err-port) + ;; There are docker images that exist that include ssh-keygen + ;; but none of them are "official". For something sensitive like + ;; this it seems much better to only use an official image so there + ;; is less chance of an image doing something malicious and we don't + ;; notice when updating the image this command uses. + ;; + ;; This command maps a volume to the unique directory we created above + ;; and uses that to store the generated ssh keys. + ;; Later on this directory gets deleted after we read the keys into + ;; strings to return from this function. + (process* "docker" `("run" "--rm" "--volume" + ,(conc (current-directory) "/" key-path ":/opt/keys") + "debian:12-slim" "bash" "-c" "apt update +apt install -y openssh-client +ssh-keygen -t ed25519 -f /opt/keys/key -N \"\" +chmod -R 777 /opt/keys")) + (let ((thread + (thread-start! + (lambda () + (let loop () + (thread-sleep! 1) + ;; We do a non-blocking wait here so that we don't + ;; block the entire web process. + (receive (wait-pid exit-normal status) (process-wait pid #t) + (if (= wait-pid 0) ;; wait-pid is 0 until the process has finished + (loop) + (let ((priv-key (with-input-from-file (conc key-path "/key") read-string)) + (pub-key (with-input-from-file (conc key-path "/key.pub") read-string))) + (with-input-from-port in-port read-string) ;; left here for debugging and to clear ports + (with-input-from-port err-port read-string) ;; left here for debugging and to clear ports + (delete-directory key-path #t) + (list priv-key pub-key))))))))) + (thread-join! thread))))) + +(define (generate-restic-password) + (generator->string (gtake (make-random-char-generator + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?") + 30))) + +(define (generate-postgres-password) + (generator->string (gtake (make-random-char-generator + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") + 40))) + +(define (generate-redis-password) + (generator->string (gtake (make-random-char-generator + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") + 40))) + (with-schematra-app app (lambda () (post "/config/wizard/create-instance" - (let ((instance-id (with-db/transaction - (lambda (db) - (create-instance db (session-user-id)))))) + (let* ((ssh-keys (generate-ssh-key (session-user-id))) + (instance-id (with-db/transaction + (lambda (db) + (create-instance db (session-user-id) (first ssh-keys) (second ssh-keys) + (generate-restic-password)))))) (redirect (conc "/config/wizard/services/" instance-id)))) ;; TODO should all these key related form fields be of type password @@ -638,7 +798,15 @@ h1, h2, h3, h4, h5, h6 { (get/widgets ("/config/wizard/services-success/:id") - (let ((instance-id (alist-ref "id" (current-params) equal?))) + (let* ((instance-id (alist-ref "id" (current-params) equal?)) + (service-config + (with-db/transaction + (lambda (db) + (get-user-service-config db (session-user-id) instance-id)))) + (cloudflare-result (test-cloudflare-connection (alist-ref 'cloudflare-api-token service-config) + (alist-ref 'cloudflare-zone-id service-config) + (alist-ref 'cloudflare-account-id service-config))) + (digitalocean-result (test-digitalocean-connection (alist-ref 'digitalocean-api-token service-config)))) `(App (Configuration-Wizard (@ (step "Services")) @@ -647,17 +815,37 @@ h1, h2, h3, h4, h5, h6 { (VStack (Fieldset (@ (title "Cloudflare")) - (h3 "Connected") - (p "Your Cloudflare account was successfully connected!")) + ,@(if (alist-ref 'success cloudflare-result) + `((h3 "Connected") + (p "Your Cloudflare account was successfully connected!")) + `((h3 "Connection Failed") + (p "Unable to make a connection via Cloudflare API. Message is: \"" + ,(string-intersperse + (map (lambda (err) + (alist-ref 'message err)) + (alist-ref 'errors cloudflare-result)) + "\" & \"") + "\"")))) (Fieldset (@ (title "DigitalOcean")) - (h3 "Connected") - (p "Your DigitalOcean account was successfully connected!")) + ,@(if (alist-ref 'success digitalocean-result) + `((h3 "Connected") + (p "Your DigitalOcean account was successfully connected!")) + `((h3 "Connection Failed") + (p "Unable to make a connection via DigitalOcean API. Message is: \"" + ,(string-intersperse + (map (lambda (err) + (alist-ref 'message err)) + (alist-ref 'errors digitalocean-result)) + "\" & \"") + "\"")))) (Fieldset (@ (title "Backblaze")) (h3 "Connected") (p "Your Backblaze account was successfully connected!")) - (Form-Nav (@ (back-to ,(conc "/config/wizard/services/" instance-id)))))))))) + (Form-Nav (@ (back-to ,(conc "/config/wizard/services/" instance-id)) + (submit-enabled ,(and (alist-ref 'success cloudflare-result) + (alist-ref 'success digitalocean-result))))))))))) (get/widgets ("/config/wizard/apps/:id") @@ -669,7 +857,8 @@ h1, h2, h3, h4, h5, h6 { 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))))))) + (app-config . ,(get-user-app-config db (session-user-id) instance-id)) + (service-config . ,(get-user-service-config db (session-user-id) instance-id))))))) `(App (Configuration-Wizard (@ (step "Apps")) @@ -679,13 +868,24 @@ h1, h2, h3, h4, h5, h6 { (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? + ,@(map (lambda (domain) + `(option (@ (value ,domain) + ,@(if (equal? domain + (alist-ref 'root-domain (alist-ref 'app-config results))) + '(selected) + '())) + ,domain)) + (get-cloudflare-domains (alist-ref 'cloudflare-api-token + (alist-ref 'service-config results)))) + )) (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 "ghost") (type "checkbox") (label ("Ghost")) (checked ,(member 'ghost (alist-ref 'selected-apps results))))) (Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled")))) + ;; TODO add config for when automatic upgrades are scheduled for? + ;; TODO add config for server timezone? (Form-Nav (@ (back-to ,(conc "/config/wizard/services-success/" instance-id)))))))))) (post "/config/wizard/apps-submit/:id" @@ -696,9 +896,9 @@ h1, h2, h3, h4, h5, h6 { 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))) - (ghost . ,(or (and (alist-ref 'ghost (current-params)) "0.0") (sql-null))))) + `((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "15.1.0") (sql-null))) + (nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "31.0.8") (sql-null))) + (ghost . ,(or (and (alist-ref 'ghost (current-params)) "6.10.0") (sql-null))))) (update-root-domain db (session-user-id) instance-id @@ -774,23 +974,36 @@ h1, h2, h3, h4, h5, h6 { (let ((instance-id (alist-ref "id" (current-params) equal?))) (with-db/transaction (lambda (db) - (update-user-app-config - db - (session-user-id) - instance-id - `((ghost . ((subdomain . ,(alist-ref 'ghost-subdomain (current-params))))) - (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))))) - (all-apps . ((smtp-host . ,(alist-ref 'smtp-host (current-params))) - (smtp-port . ,(alist-ref 'smtp-port (current-params))) - (smtp-auth-user . ,(alist-ref 'smtp-auth-user (current-params))) - (smtp-auth-password . ,(alist-ref 'smtp-auth-password (current-params))) - (smtp-from . ,(alist-ref 'smtp-from (current-params))))))))) + (let ((config (alist-ref 'config (get-user-app-config db (session-user-id) instance-id)))) + (update-user-app-config + db + (session-user-id) + instance-id + `((ghost . ((subdomain . ,(alist-ref 'ghost-subdomain (current-params))) + (postgres-root-password . ,(or (alist-ref 'postgres-root-password + (alist-ref 'ghost config eq? '())) + (generate-postgres-password))) + (postgres-password . ,(or (alist-ref 'postgres-password + (alist-ref 'ghost config eq? '())) + (generate-postgres-password))))) + (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))) + (postgres-password . ,(or (alist-ref 'postgres-password + (alist-ref 'nextcloud config eq? '())) + (generate-postgres-password))) + (redis-password . ,(or (alist-ref 'redis-password + (alist-ref 'nextcloud config eq? '())) + (generate-redis-password))))) + (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))))) + (all-apps . ((smtp-host . ,(alist-ref 'smtp-host (current-params))) + (smtp-port . ,(alist-ref 'smtp-port (current-params))) + (smtp-auth-user . ,(alist-ref 'smtp-auth-user (current-params))) + (smtp-auth-password . ,(alist-ref 'smtp-auth-password (current-params))) + (smtp-from . ,(alist-ref 'smtp-from (current-params)))))))))) (redirect (conc "/config/wizard/machine/" instance-id)))) (get/widgets @@ -815,16 +1028,18 @@ h1, h2, h3, h4, h5, h6 { (get-digital-ocean-regions (alist-ref 'digitalocean-api-token config))))) (Form-Nav (@ (back-to ,(conc "/config/wizard/apps2/" instance-id)))))))))) +;; TODO if the region is changed, all of the data is DELETED because the +;; volume is deleted and re-created (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)))) + (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/:id") @@ -902,118 +1117,142 @@ h1, h2, h3, h4, h5, h6 { (VStack (Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch"))))))))) +;; TODO run restic-init if needed (like the first run or if the backblaze +;; config changes ;; 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 +;; TODO should this perform a backup and then run the systemctl stop app command first? (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) 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)) - (root-domain (alist-ref 'root-domain app-config)) - (service-config (alist-ref 'service-config results)) - (terraform-state (alist-ref 'terraform-state results)) - (dir (deployment-directory (session-user-id)))) - (setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state)) - (with-output-to-file (string-append dir "/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") ;; TODO generate - ("NEXTCLOUD_REDIS_PASSWORD" . "redispassword") ;; TODO generate - ("GHOST_DATABASE_ROOT_PASSWORD" . "reallysecurerootpassword") ;; TODO generate - ("GHOST_DATABASE_PASSWORD" . "ghostpassword") ;; TODO generate - ("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config))) - ("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config))) - ("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config))) - ("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config))) - ("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config))) - ("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"))))) ;; TODO generate or get from user - (with-output-to-file (string-append dir "/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" . "4459.2.1"))) - (display "ssh_keys=[\"") (display (with-input-from-file (string-append dir "/config/ssh-keys") read-string)) (print "\"]")))) - (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 () - (change-directory dir) - (let ((pid (process-run "make apply > make-out"))) - (with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid))) - (change-directory "../") - (let loop () - (thread-sleep! 5) - (receive (pid exit-normal status) (process-wait pid #t) - (if (= pid 0) - (begin (let ((progress (parse-deployment-log - (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)))) - (loop)) - (let ((progress (parse-deployment-log - (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) - ;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES - ;; like the random digital ocean error saying the IP can't be - ;; updated because another operation is in progress. - ;; it still registers as "success". - ;; probably need to also write stderr to a file and read/store/parse that? - ;; Should we parse make-out for string "Apply complete!" ? - (update-deployment-status - 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 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 (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?)))) + (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)) + (service-config . ,(get-user-service-config db (session-user-id) instance-id)) + (terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id)) + (ssh-pub-key . ,(get-instance-ssh-pub-key db (session-user-id) instance-id)) + (restic-password . ,(get-instance-restic-password 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)) + (root-domain (alist-ref 'root-domain app-config)) + (service-config (alist-ref 'service-config results)) + (terraform-state (alist-ref 'terraform-state results)) + (ssh-pub-key (alist-ref 'ssh-pub-key results)) + (restic-password (alist-ref 'restic-password results)) + (dir (deployment-directory (session-user-id)))) + (setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state)) + (with-output-to-file (string-append dir "/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" . ,(alist-ref 'postgres-password (alist-ref 'nextcloud config))) + ("NEXTCLOUD_REDIS_PASSWORD" . ,(alist-ref 'redis-password (alist-ref 'nextcloud config))) + ("GHOST_DATABASE_ROOT_PASSWORD" . ,(alist-ref 'postgres-root-password (alist-ref 'ghost config))) + ("GHOST_DATABASE_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'ghost config))) + ("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config))) + ("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config))) + ("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config))) + ("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config))) + ("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config))) + ("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" . ,restic-password))))) + (with-output-to-file (string-append dir "/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" . "4459.2.1"))) + ;; remove the newline that generating the ssh key adds + (display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]")))) + (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 () + (change-directory dir) + (let ((pid (process-run "make apply > make-out 2>&1"))) + (with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid))) + (change-directory "../") + (let loop () + (thread-sleep! 5) + (receive (pid exit-normal status) (process-wait pid #t) + (if (= pid 0) ;; process is still running + (begin (let ((progress (parse-deployment-log + (with-input-from-file + (string-append (deployment-directory user-id) "/make-out") + read-string))) + (tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string)) + (tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string))) + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id progress) + (when (file-exists? (string-append dir "/terraform.tfstate")) + (update-user-terraform-state db user-id instance-id + (if (eof-object? tf-state) "" tf-state) + (if (eof-object? tf-state-backup) "" tf-state-backup)))))) + (loop)) + (let ((progress (parse-deployment-log + (with-input-from-file + (string-append (deployment-directory user-id) "/make-out") + read-string))) + (tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string)) + (tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string))) + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id progress) + ;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES + ;; like the random digital ocean error saying the IP can't be + ;; updated because another operation is in progress. + ;; it still registers as "success". + ;; probably need to also write stderr to a file and read/store/parse that? + ;; Should we parse make-out for string "Apply complete!" ? + (update-deployment-status + 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 instance-id + (if (eof-object? tf-state) "" tf-state) + (if (eof-object? tf-state-backup) "" tf-state-backup)))))))))))) + (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?)))) (get/widgets - ("/config/wizard/success/:id") + ("/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) instance-id)))))) + (status (string->symbol (alist-ref 'status res)))) + (if (or (eq? status 'complete) (eq? status 'failed)) + '() + '((meta (@ (http-equiv "refresh") (content "5"))))))) (let* ((instance-id (alist-ref "id" (current-params) equal?)) (res (with-db/transaction (lambda (db) @@ -1022,19 +1261,28 @@ h1, h2, h3, h4, h5, h6 { (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))) - `(VStack - (h1 - ,(case (string->symbol status) - ((queued) "Deployment queued") - ((in-progress) "Deployment in progress") - ((complete) "Deployment complete!") - ((failed) "Deployment failed"))) - (ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress))) - (li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress))) - (li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress))) - (li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress)))) - (pre ,output) - ))) + `(App + (Main-Container + (VStack + (h1 + ,(case (string->symbol status) + ((queued) "Deployment queued") + ((in-progress) "Deployment in progress") + ((complete) "Deployment complete!") + ((failed) "Deployment failed"))) + (ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress))) + (li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress))) + (li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress))) + (li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress)))) + (div + (a (@ (href "/dashboard")) "Dashboard") + ,@(if (or (eq? (string->symbol status) 'complete) (eq? (string->symbol status) 'failed)) + '() + " (deployment will continue in the background if you leave this page)")) + (hr) + (pre (@ (style ((overflow-x "scroll")))) + ,output) + ))))) (get/widgets ("/dashboard") @@ -1046,13 +1294,45 @@ h1, h2, h3, h4, h5, h6 { (@ (action "/config/wizard/create-instance") (method POST)) (Button "Setup New Instance")) - (ul ,@(map (lambda (deployment) - `(li (a (@ (href ,(conc "/deployments/" (alist-ref 'id deployment)))) - ,(alist-ref 'root-domain deployment)) - " - ",(alist-ref 'status deployment))) + (ul ,@(map (lambda (instance) + (let ((root-domain (alist-ref 'root-domain instance)) + (config (alist-ref 'config instance))) + `(li (VStack + (h2 ,root-domain) + (HStack + "status: " ,(if (equal? (alist-ref 'status instance) "complete") + "deployed successfully" + (alist-ref 'status instance))) + (h3 "Apps") + (ul ,@(filter + identity + (map (lambda (app-map) + (let ((app (car app-map)) + (doc-url (cdr app-map))) + (if (or (alist-ref app instance) + (eq? app 'log-viewer)) + `((li (a (@ (href ,doc-url)) ,app) + " (v" ,(alist-ref app instance eq? "-") ") " + (a (@ (href "https://" + ,(alist-ref 'subdomain (alist-ref app config)) + "." ,root-domain)) + ,(alist-ref 'subdomain (alist-ref app config)) + "." ,root-domain))) + #f))) + '((wg-easy . "https://wg-easy.github.io/wg-easy/Pre-release/") + (nextcloud . "https://nextcloud.com/support/") + (ghost . "https://nextcloud.com/support/") + (log-viewer . "https://nextcloud.com/support/"))))) + (h3 "Actions") + (ul (li (a (@ (href "/config/wizard/services/" + ,(alist-ref 'instance-id instance))) + "Modify Setup")) + (li "Upgrade Now (pending automatic upgrades scheduled for: )") + (li "Manage Backups") + (li "Destroy")))))) (with-db/transaction (lambda (db) - (get-user-deployments db (session-user-id)))))))))) + (get-dashboard db (session-user-id)))))))))) (schematra-install)