From 1a0252de1a54c73e94e75eb726314113c13d2d80 Mon Sep 17 00:00:00 2001 From: Thomas Hintz Date: Fri, 24 Jul 2026 12:29:22 -0700 Subject: [PATCH] Adding better support for undeployed instances. --- src/db.scm | 74 ++++---- src/nassella.scm | 444 +++++++++++++++++++++++++++-------------------- 2 files changed, 299 insertions(+), 219 deletions(-) diff --git a/src/db.scm b/src/db.scm index 77dc702..904a209 100644 --- a/src/db.scm +++ b/src/db.scm @@ -515,37 +515,51 @@ where usa.user_id=$1 and usa.instance_id=$2;" "select apps.app_name, usa.installed_version, usa.instance_id from user_selected_apps usa join apps on apps.id=usa.app_id where user_id=$1;" - user-id)))) - (map - (lambda (instance) - (cons `(apps . ,(alist-ref (alist-ref 'instance-id instance) instance-apps)) - instance)) + user-id))) + (undeployed-res + (query conn + (string-append + "select i.instance_id from instances as i " + "left join deployments d on d.instance_id = i.instance_id " + "where i.user_id=$1 and d.status is null " + "group by d.id, i.instance_id;") + user-id))) + (append (map - (lambda (row-num) - (map (lambda (item) - (let* ((key (car item)) - (value (cdr item)) - (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) - ;; (nassella_version . nassella) - ;; (log_viewer_version . log-viewer) - ;; (instance_control_version . instance-control) - ,@*deployments-reverse-column-map*)))) - `(,config . ,(if (sql-null? value) - #f - (if (and (string? value) (member config *deployments-column-map*)) - (string->symbol value) - (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))))))) + (lambda (instance) + (cons `(apps . ,(alist-ref (alist-ref 'instance-id instance) instance-apps)) + instance)) + (map + (lambda (row-num) + (cons '(deployed . #t) + (map (lambda (item) + (let* ((key (car item)) + (value (cdr item)) + (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) + ;; (nassella_version . nassella) + ;; (log_viewer_version . log-viewer) + ;; (instance_control_version . instance-control) + ,@*deployments-reverse-column-map*)))) + `(,config . ,(if (sql-null? value) + #f + (if (and (string? value) (member config *deployments-column-map*)) + (string->symbol value) + (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)))) + (map (lambda (id) `((instance-id . ,id) (deployed . #f))) + (if (> (row-count undeployed-res) 0) + (row-values undeployed-res) + '())))))) (define (update-user-terraform-state conn user-id instance-id state backup) (receive (user-key user-iv auth-user-id) diff --git a/src/nassella.scm b/src/nassella.scm index 75c94df..c53882e 100644 --- a/src/nassella.scm +++ b/src/nassella.scm @@ -1936,20 +1936,23 @@ chmod -R 777 /opt/keys"))) (get/widgets ("/dashboard") - `(App - (Main-Container - (VStack - (@ (element main)) - (h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Nassella - Instances") - (form - (@ (action "/config/wizard/create-instance") - (method POST)) - (Button "Setup New Instance")) - (ul (@ (style ((list-style "none") - (padding-left "0")))) - ,@(map (lambda (instance) - (let ((root-domain (alist-ref 'root-domain instance)) - (config (alist-ref 'config instance))) + (let* ((res (with-db/transaction + (lambda (db) + (get-dashboard db (session-user-id))))) + (deployed-instances (filter (lambda (x) (alist-ref 'deployed x)) res)) + (not-deployed-instances (filter (lambda (x) (not (alist-ref 'deployed x))) res))) + `(App + (Main-Container + (VStack + (@ (element main)) + (h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Nassella - Instances") + (form + (@ (action "/config/wizard/create-instance") + (method POST)) + (Button "Setup New Instance")) + (ul (@ (style ((list-style "none") + (padding-left "0")))) + ,@(map (lambda (instance) `(li (VStack (@ (style ((background "rgba(0,0,0,0.1)") @@ -1957,44 +1960,88 @@ chmod -R 777 /opt/keys"))) (padding ,($ 'space.75)) (margin-bottom ,($ 'space.100))))) (VStack - (h2 ,root-domain) - (Status-Pill (@ (type ,(instance-status->pill-type (alist-ref 'status instance)))) - ,(instance-status->display (alist-ref 'status instance)))) - (h3 "Apps") - (ul ,@(map (lambda (app-info) - (let ((app (alist-ref 'app-name app-info))) - `((li (a (@ (href "#") (style ((color ,($ 'color.primary.background-contrast))))) ,app) ;; TODO documentation URL - " (v" ,(alist-ref 'installed-version app-info) ") " - (a (@ (href "https://" - ,(alist-ref 'subdomain (alist-ref app config)) - "." ,root-domain) - (style ((color ,($ 'color.primary.background-contrast))))) - ,(alist-ref 'subdomain (alist-ref app config)) - "." ,root-domain))))) - (or (filter (lambda (app-info) - (case (alist-ref 'app-name app-info) - ((instance-control lldap authelia) #f) - (else #t))) - (alist-ref 'apps instance)) - '()))) - (h3 "Actions") + (h2 "Undeployed Instance")) (ul (li (a (@ (href "/config/wizard/services/" ,(alist-ref 'instance-id instance)) (style ((color ,($ 'color.primary.background-contrast))))) - "Modify Setup")) - ;; (li "Upgrade Now (pending automatic upgrades scheduled for: )") - (li (a (@ (href "/backups/" ,(alist-ref 'instance-id instance)) + "Resume Setup")) + (li (a (@ (href "/destroy-undeployed/" ,(alist-ref 'instance-id instance)) (style ((color ,($ 'color.primary.background-contrast))))) - "Manage Backups")) - (li (a (@ (href "/destroy/" ,(alist-ref 'instance-id instance)) - (style ((color ,($ 'color.primary.background-contrast))))) - "Destroy - deletes data and configuration (confirmation required)")) - (li (a (@ (href "/reset/" ,(alist-ref 'instance-id instance)) - (style ((color ,($ 'color.primary.background-contrast))))) - "Reset - deletes data (confirmation required)"))))))) - (with-db/transaction - (lambda (db) - (get-dashboard db (session-user-id)))))))))) + "Destroy - deletes data and configuration (confirmation required)")))))) + not-deployed-instances)) + (ul (@ (style ((list-style "none") + (padding-left "0")))) + ,@(map (lambda (instance) + (let ((root-domain (alist-ref 'root-domain instance)) + (config (alist-ref 'config instance))) + `(li + (VStack + (@ (style ((background "rgba(0,0,0,0.1)") + (border-radius ,($ 'radius.medium)) + (padding ,($ 'space.75)) + (margin-bottom ,($ 'space.100))))) + (VStack + (h2 ,root-domain) + ,@(if (alist-ref 'status instance) + `((Status-Pill (@ (type ,(instance-status->pill-type (alist-ref 'status instance)))) + ,(instance-status->display (alist-ref 'status instance)))) + '())) + (h3 "Apps") + (ul ,@(map (lambda (app-info) + (let ((app (alist-ref 'app-name app-info))) + `((li (a (@ (href "#") (style ((color ,($ 'color.primary.background-contrast))))) ,app) ;; TODO documentation URL + " (v" ,(alist-ref 'installed-version app-info) ") " + (a (@ (href "https://" + ,(alist-ref 'subdomain (alist-ref app config)) + "." ,root-domain) + (style ((color ,($ 'color.primary.background-contrast))))) + ,(alist-ref 'subdomain (alist-ref app config)) + "." ,root-domain))))) + (or (filter (lambda (app-info) + (case (alist-ref 'app-name app-info) + ((instance-control lldap authelia) #f) + (else #t))) + (alist-ref 'apps instance)) + '()))) + (h3 "Actions") + (ul (li (a (@ (href "/config/wizard/services/" + ,(alist-ref 'instance-id instance)) + (style ((color ,($ 'color.primary.background-contrast))))) + "Modify Setup")) + ;; (li "Upgrade Now (pending automatic upgrades scheduled for: )") + (li (a (@ (href "/backups/" ,(alist-ref 'instance-id instance)) + (style ((color ,($ 'color.primary.background-contrast))))) + "Manage Backups")) + (li (a (@ (href "/destroy/" ,(alist-ref 'instance-id instance)) + (style ((color ,($ 'color.primary.background-contrast))))) + "Destroy - deletes data and configuration (confirmation required)")) + (li (a (@ (href "/reset/" ,(alist-ref 'instance-id instance)) + (style ((color ,($ 'color.primary.background-contrast))))) + "Reset - deletes data (confirmation required)"))))))) + deployed-instances))))))) + +(get/widgets + ("/destroy-undeployed/:id") + (let* ((instance-id (alist-ref "id" (current-params) equal?))) + `(App + (h2 "Destroy Undeployed Instance") + (h3 "This action is NOT reversible.") + (form + (@ (action ,(conc "/destroy-undeployed-submit/" instance-id)) (method POST)) + (VStack + (Fieldset + (@ (title "Type the word 'DELETE' to confirm.")) + (Field (@ (name "confirm") (label ("Type DELETE")) (value "")))) + (Form-Nav (@ (back-to "/dashboard") (submit-button "Destroy")))))))) + +(post "/destroy-undeployed-submit/:id" + (let* ((instance-id (alist-ref "id" (current-params) equal?))) + (if (not (string=? (alist-ref 'confirm (current-params)) "DELETE")) + (redirect (conc "/destroy-undeployed/" instance-id)) + (begin (with-db/transaction + (lambda (db) + (destroy-instance db instance-id))) + (redirect "/dashboard"))))) (get/widgets ("/destroy/:id") @@ -2011,151 +2058,170 @@ chmod -R 777 /opt/keys"))) (@ (action ,(conc "/destroy-submit/" instance-id)) (method POST)) (VStack (Fieldset - (@ (title "Type the domain name of the instance to confirm.")) - (Field (@ (name "instance-domain") (label ("Domain")) (value "")))) + (@ (title "Type the domain name of the instance to confirm.")) + (Field (@ (name "instance-domain") (label ("Domain")) (value "")))) (Form-Nav (@ (back-to "/dashboard") (submit-button "Destroy")))))))) ;; TODO This is mostly a copy of the deployment POST action (post "/destroy-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)) - (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) instance-id))) - (if (not (string=? (alist-ref 'instance-domain (current-params)) root-domain)) - (redirect (conc "/destroy/" instance-id)) - (begin - (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))) - ("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config))) - ("NASSELLA_POSTGRES_DB" . "nassella") - ("NASSELLA_POSTGRES_USER" . "nassella") - ("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config))) - ("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia") - ("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia") - ("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config))) - ("NASSELLA_LLDAP_POSTGRES_DB" . "lldap") - ("NASSELLA_LLDAP_POSTGRES_USER" . "lldap") - ("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config))) - ("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config))) - ("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config))) - ("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config))) - ("NASSELLA_STRIPE_API_KEY" . ,(alist-ref 'stripe-api-key (alist-ref 'nassella config))) - ("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config))) - ("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella 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) - ("INSTANCE_CONTROL_WEBHOOKS_SECRET" . ,(alist-ref 'webhooks-secret (alist-ref 'instance-control config))))))) - (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" . "nassella") - ("datacenter" . ,(alist-ref 'digitalocean-region service-config)) - ;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}") - ("Flatcar_stable_version" . "4593.2.4"))) - ;; remove the newline that generating the ssh key adds - (display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]"))) - ;; TODO need a new table to track destroying? - ;; as this is creating a new "deployment" - ;; to attach state to - (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 instance-id))) - (thread-start! - (lambda () - (change-directory dir) - (let ((pid (process-run "make destroy > 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 instance-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 instance-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) - (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)) - (when exit-normal - (destroy-instance db instance-id)))))))))))) - (redirect (conc "/destroy-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 (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) instance-id))) + (if (not (string=? (alist-ref 'instance-domain (current-params)) root-domain)) + (redirect (conc "/destroy/" instance-id)) + (begin + (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-version) + (conc (if (eq? (car app-version) 'log-viewer) 'dozzle (car app-version)) + "," + (alist-ref 'subdomain (alist-ref (car app-version) config)) + "," + (cdr app-version))) + 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))) + ("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config))) + ("NASSELLA_POSTGRES_DB" . "nassella") + ("NASSELLA_POSTGRES_USER" . "nassella") + ("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config))) + ("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia") + ("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia") + ("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config))) + ("NASSELLA_LLDAP_POSTGRES_DB" . "lldap") + ("NASSELLA_LLDAP_POSTGRES_USER" . "lldap") + ("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config))) + ("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config))) + ("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config))) + ("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config))) + ("NASSELLA_STRIPE_API_KEY" . ,(alist-ref 'stripe-api-key (alist-ref 'nassella config))) + ("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config))) + ("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella config))) + ("WORDPRESS_DB_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'wordpress config))) + ("WORDPRESS_DB_ROOT_PASSWORD" . ,(alist-ref 'db-root-password (alist-ref 'wordpress config))) + ("LLDAP_POSTGRES_DB" . "lldap") + ("LLDAP_POSTGRES_USER" . "lldap") + ("LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'lldap config))) + ("LLDAP_JWT_SECRET" . ,(alist-ref 'jwt-secret (alist-ref 'lldap config))) + ("LLDAP_KEY_SEED" . ,(alist-ref 'key-seed (alist-ref 'lldap config))) + ("LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'lldap config))) + ("LLDAP_USER_EMAIL" . ,(alist-ref 'user-email (alist-ref 'lldap config))) + ("AUTHELIA_POSTGRES_DB" . "authelia") + ("AUTHELIA_POSTGRES_USER" . "authelia") + ("AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'authelia config))) + ("AUTHELIA_JWT_SECRET" . ,(alist-ref 'jwt-secret (alist-ref 'authelia config))) + ("AUTHELIA_SESSION_SECRET" . ,(alist-ref 'session-secret (alist-ref 'authelia config))) + ("AUTHELIA_ENCRYPTION_KEY" . ,(alist-ref 'encryption-key (alist-ref 'authelia 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) + ("INSTANCE_CONTROL_WEBHOOKS_SECRET" . ,(alist-ref 'webhooks-secret (alist-ref 'instance-control config))) + ,@(if (and restic-snapshot-id (not (string=? restic-snapshot-id ""))) `(("RESTIC_SNAPSHOT_ID" . ,restic-snapshot-id)) '()))))) + (with-output-to-file (string-append dir "/config/production.tfvars") + (lambda () + (map (lambda (e) + (write-terraform-config-entry (car e) (cdr e))) + `(("server_type" . ,(alist-ref 'digitalocean-size service-config)) + ("do_token" . ,(alist-ref 'digitalocean-api-token service-config)) + ("digitalocean_volume_size" . ,(alist-ref 'digitalocean-volume-size 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" . ,(string-append "nassella" (string-delete #\. root-domain))) ;; TODO update to: (import srfi-14) (string-filter char-set:letter+digit root-domain) + ("datacenter" . ,(alist-ref 'digitalocean-region service-config)) + ;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}") + ("flatcar_stable_version" . "4593.2.4"))) + ;; remove the newline that generating the ssh key adds + (display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]"))) + ;; TODO need a new table to track destroying? + ;; as this is creating a new "deployment" + ;; to attach state to + (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 instance-id))) + (thread-start! + (lambda () + (change-directory dir) + (let ((pid (process-run "make preapply && make destroy > 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 instance-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 instance-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) + (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)) + (when exit-normal + (destroy-instance db instance-id)))))))))))) + (redirect (conc "/destroy-success/" (alist-ref "id" (current-params) equal?))))))) (get/widgets ("/destroy-success/:id"