From 863d8395637d82ae3b02747f73c9df999067284c Mon Sep 17 00:00:00 2001 From: Thomas Hintz Date: Sun, 23 Aug 2026 12:06:15 -0700 Subject: [PATCH] wip --- src/Makefile | 2 +- src/db.scm | 10 +- src/nassella.scm | 589 +++++++++++++++++++++++++++++------------------ 3 files changed, 371 insertions(+), 230 deletions(-) diff --git a/src/Makefile b/src/Makefile index 88e49bc..b243763 100644 --- a/src/Makefile +++ b/src/Makefile @@ -15,7 +15,7 @@ # along with Nassella. If not, see . dockerall: - docker buildx build --platform linux/amd64,linux/arm64 -t nassella/b0.0.1 . + docker buildx build --platform linux/arm64 -t nassella/b0.0.1 . # linux/amd64, dockerlocal: docker buildx build -t nassella/b0.0.1 . diff --git a/src/db.scm b/src/db.scm index bc44a14..e1f6198 100644 --- a/src/db.scm +++ b/src/db.scm @@ -23,7 +23,7 @@ db-init db-clean create-user delete-user - get-user-id-by-username + get-user-id-by-username get-user-email-by-id create-instance destroy-instance get-user-instances get-instance-ssh-pub-key get-instance-ssh-priv-key update-instance-ssh-pub-key @@ -181,6 +181,12 @@ returning users.user_id;" (value-at res) #f))) + (define (get-user-email-by-id conn id) + (let ((res (query conn "select email from users where user_id=$1;" id))) + (if (> (row-count res) 0) + (value-at res) + #f))) + ;; 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 @@ -701,7 +707,7 @@ where user_id=$1;" (string-split (with-input-from-file "db-init.sql" read-string) ";")) (log-to (debug-log) "table creation finished") (log-to (debug-log) "creating test user") - (create-user db "me@example.com" "username") + (create-user db "me@example.com" "username") ;; TODO should this be removed? (log-to (debug-log) "test user creation finished"))) ;; originally there was no migrations table, so first add it if it doesn't exist (if (value-at (query db "SELECT EXISTS (SELECT FROM pg_tables WHERE schemaname = 'public' AND tablename = 'migrations');")) diff --git a/src/nassella.scm b/src/nassella.scm index 7c8a9e7..8d65dca 100644 --- a/src/nassella.scm +++ b/src/nassella.scm @@ -350,6 +350,9 @@ h1, h2, h3, h4, h5, h6 { (define (session-user-id) (alist-ref 'user-id (current-params))) +(define (session-username) + (alist-ref 'username (current-params))) + (define-syntax get/widgets (syntax-rules () ((_ (path) body ...) @@ -670,6 +673,21 @@ h1, h2, h3, h4, h5, h6 { #f read-json)) +(define (b2-create-bucket api-url account-token account-id bucket-name) + (with-input-from-request + (make-request method: 'POST + uri: (uri-reference (string-append api-url "/b2api/v4/b2_create_bucket")) + headers: (headers `((authorization #(,account-token raw)) + (content-type application/json)))) + (lambda () + (write-json + `((accountId . ,account-id) + (bucketName . ,bucket-name) + (bucketType . "allPrivate") + (lifecycleRules . #(((daysFromHidingToDeleting . 1) + (fileNamePrefix . ""))))))) + read-json)) + ;; request response looks like ;; (((accountId . "xxx") (bucketId . "xxx") (bucketInfo) (bucketName . "xxx") (bucketType . "allPrivate") (corsRules) (defaultServerSideEncryption (isClientAuthorizedToRead . #t) (value (algorithm . null) (mode . null))) (fileLockConfiguration (isClientAuthorizedToRead . #t) (value (defaultRetention (mode . null) (period . null)) (isFileLockEnabled . #f))) (lifecycleRules ((daysFromHidingToDeleting . 1) (daysFromStartingToCancelingUnfinishedLargeFiles . null) (daysFromUploadingToHiding . null) (fileNamePrefix . ""))) (options "s3") (replicationConfiguration (isClientAuthorizedToRead . #t) (value . null)) (revision . 3)) ((accountId . "yyy") (bucketId . "yyy") (bucketInfo) (bucketName . "yyy") (bucketType . "allPrivate") (corsRules) (defaultServerSideEncryption (isClientAuthorizedToRead . #t) (value (algorithm . null) (mode . null))) (fileLockConfiguration (isClientAuthorizedToRead . #t) (value (defaultRetention (mode . null) (period . null)) (isFileLockEnabled . #f))) (lifecycleRules ((daysFromHidingToDeleting . 1) (daysFromStartingToCancelingUnfinishedLargeFiles . null) (daysFromUploadingToHiding . null) (fileNamePrefix . ""))) (options "s3") (replicationConfiguration (isClientAuthorizedToRead . #t) (value . null)) (revision . 3))) (define (b2-list-buckets api-url account-token account-id) @@ -1186,6 +1204,231 @@ chmod -R 777 /opt/keys"))) (write-json data)) read-json))) +(define (perform-review-submit instance-id) + (let* ((status (string->symbol + (->string + (with-db/transaction + (lambda (db) + (get-most-recent-deployment-status db (session-user-id) instance-id))))))) + (when (or (not (or (eq? status 'queued) (eq? status 'in-progress))) + (equal? (alist-ref 'force (current-params)) "true")) + (let* ((restic-snapshot-id (alist-ref 'restic-snapshot-id (current-params))) + (results + (with-db/transaction + (lambda (db) + `((selected-apps . ,(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))) + (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)) + "," + (or (alist-ref 'subdomain (alist-ref (car app-version) config)) + "nassella-ignore") ;; a hack to get authelia to work for now + "," + (cdr app-version))) + selected-apps) + " ")) + ("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config))) + ("HOST_ADMIN_PASSWORD" . ,(create-authelia-password-hash (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 "\"]")))) + (let* ((user-id (session-user-id)) + (app-config + (with-db/transaction + (lambda (db) + (get-user-app-config db (session-user-id) instance-id)))) + (first-deployment? (not (with-db/transaction (lambda (db) (get-most-recent-deployment-status db user-id instance-id))))) + (deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id)))) + (dir (deployment-directory user-id instance-id)) + (backup-request-id (conc (truncate (time->seconds (current-time))) "-" (pseudo-random-integer 10000)))) + (if first-deployment? + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id '((instance-backup . ignored) + (machine-destroy . ignored) + (ip-destroy . ignored) + (volume-destroy . ignored))))) + (begin + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id '((instance-backup . in-progress))))) + (handle-exceptions + exn + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id '((instance-backup . failed))))) + (send-instance-control-command + (alist-ref 'root-domain app-config) + (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config))) + "queue-restic-snapshot-no-restart" + (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config))) + `((path . "/") + (tag . "automated_pre_instance_update") + ;; effectively a guid, we just want something unique + (request_id . ,backup-request-id) + (version . 0)))))) + (thread-start! + (lambda () + (when (not first-deployment?) + (let ((start-time (time->seconds (current-time)))) + (let loop () + (thread-sleep! 1) + (let* ((status-result + (handle-exceptions + exn + '((status . "error")) + (send-instance-control-command + (alist-ref 'root-domain app-config) + (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config))) + "restic-snapshot-status" + (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config))) + `((request_id . ,backup-request-id) + (version . 0))))) + (complete (string=? (alist-ref 'status status-result) "complete"))) + (if (or complete (> (- (time->seconds (current-time)) start-time) 120)) + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id `((instance-backup . ,(or (and complete 'complete) 'failed)))))) + (loop)))))) + (change-directory dir) + (let ((pid (process-run "make preapply && 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 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-user-terraform-state db user-id instance-id + (if (eof-object? tf-state) "" tf-state) + (if (eof-object? tf-state-backup) "" tf-state-backup)) + (if (= status 0) + (update-deployment-progress db deployment-id `((instance-up . in-progress))) + (update-deployment-status + db user-id deployment-id + 'failed + (with-input-from-file (string-append dir "/make-out") read-string))))) + (when (= status 0) + (let ((instance-up (instance-up? (string-append "https://" + (alist-ref 'subdomain (alist-ref 'log-viewer (alist-ref 'config app-config))) + "." + (alist-ref 'root-domain app-config))))) + (with-db/transaction + (lambda (db) + (update-deployment-progress db deployment-id `((instance-up . ,(if instance-up 'complete 'failed)))) + (update-deployment-status + db user-id deployment-id + (if instance-up + 'complete + 'failed) + (with-input-from-file (string-append dir "/make-out") read-string)))))))))))))))) + (redirect (conc "/config/wizard/success/" instance-id))) + (with-schematra-app app (lambda () @@ -1219,6 +1462,122 @@ chmod -R 777 /opt/keys"))) (generate-restic-password)))))) (redirect (conc "/config/wizard/services/" instance-id)))) + +;; TODOs +;; backblaze: create bucket then generate a new key restricted to that bucket and only use that key +;; postmark: +;; - use API to create an email server for instance +;; - use API to generate SMTP settings for instance +;; nassella: +;; - generate instance name and verify it does not already exist +;; - store that instance name in a new db column +;; - update dashboard to use instance name +;; - (later) detect closest digitalocean region to user +;; - (later) ensure can select the correct digitalocean size +'x +(post "/config/wizard/create-instance-full" + (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))))) + (instance-name "red1") + (root-domain "nassellatest.com") + (backblaze-bucket-name (string-append "nassella-instance-" instance-name)) + (backblaze-application-key "K004v8YQPbm/MdmyoffQBH8Cof9Wt7M") ;; TODO need to generate a restricted key with access to only the new bucket and use that one so we don't leak our key + (backblaze-key-id "004da8e20ea1d5e000000000f") + (backblaze-auth (b2-authorize-account backblaze-key-id backblaze-application-key)) + (backblaze-bucket-response + (b2-create-bucket (alist-ref 'apiUrl (alist-ref 'storageApi (alist-ref 'apiInfo backblaze-auth))) + (alist-ref 'authorizationToken backblaze-auth) + (alist-ref 'accountId backblaze-auth) + backblaze-bucket-name)) + (backblaze-s3-url (alist-ref 's3ApiUrl (alist-ref 'storageApi (alist-ref 'apiInfo backblaze-auth))))) + (with-db/transaction + (lambda (db) + (update-user-service-config + db + (session-user-id) + instance-id + `((cloudflare-api-token . "cfut_ykuHdXr5P8Nm3SFCM2uQTErxKZ24pZzb98wZ7cUC76189f76") + (cloudflare-account-id . "f6542e441e20c201803398433cb923a8") + (cloudflare-zone-id . "e126d94dc5cdd32503749b55a9d64faf") + (digitalocean-api-token . "dop_v1_44a6f12f1bab78c9c3a4ba4edc7d91c3c98b4ddd0e08f3c80e0689431feb88d0") + (backblaze-application-key . ,backblaze-application-key) + (backblaze-key-id . ,backblaze-key-id) + (backblaze-bucket-name . ,backblaze-bucket-name) + (backblaze-bucket-id . ,(alist-ref 'bucketId backblaze-bucket-response)) + (backblaze-bucket-url . ,(string-append backblaze-s3-url "/" backblaze-bucket-name)) + (digitalocean-region . "sfo3") ;; TODO detect closest region to user + (digitalocean-size . "s-2vcpu-2gb") ;; TODO make sure size is available, align to nassella plan? + (digitalocean-volume-size . "60") ;; TODO align to plan? + )) + (update-root-domain db (session-user-id) instance-id root-domain) + (update-user-selected-apps + db + (session-user-id) + instance-id + (filter (lambda (app/version) (cdr app/version)) ;; filter out unused apps + `((wg-easy . #f) + (nextcloud . "34") + (ghost . #f) + (nassella . #f) + (wordpress . #f) + (lldap . #f) + (authelia . "4") + (instance-control . "b0.0.1") + (log-viewer . "20")))) + (update-user-app-config + db + (session-user-id) + instance-id + `((nextcloud . ((subdomain . ,(string-append "nextcloud." instance-name)) + (admin-user . ,(session-username)) + (admin-password . "Foodisgood4!") ;; TODO + (postgres-password . ,(generate-postgres-password)) + (redis-password . ,(generate-redis-password)))) + (authelia . ((subdomain . #f) + (db-password . ,(generate-postgres-password)) + (jwt-secret . ,(generate-jwt-secret)) + (session-secret . ,(generate-authelia-key-seed)) + (encryption-key . ,(generate-authelia-key-seed)))) + (log-viewer . ((subdomain . ,(string-append "logs." instance-name)) + (user . ,(session-username)) + (password . "Foodisgood4!"))) ;; TODO + (all-apps . ((smtp-host . "smtp.postmarkapp.com") + (smtp-port . "587") + (smtp-auth-user . "PM-T-outbound-L0Ps1dQBMdx2u20RZ9-BsF") ;; TODO + (smtp-auth-password . "alb0YXkEOmp0htTm4-kV_OGLjQbjb7NRwLN2") ;; TODO + (smtp-from . ,(string-append "admin@" root-domain)))) + (instance-control . ((subdomain . ,(string-append "nassella-instance-control." instance-name)) + (webhooks-secret . ,(generate-jwt-secret)))) + ;; unused but rest of system expects to be set + (ghost . ((subdomain . #f) + (postgres-root-password . ,(generate-postgres-password)) + (postgres-password . ,(generate-postgres-password)))) + (wg-easy . ((subdomain . #f))) + (nassella . ((subdomain . #f) + (postgres-password . ,(generate-postgres-password)) + (authelia-postgres-password . ,(generate-postgres-password)) + (lldap-postgres-password . ,(generate-postgres-password)) + (lldap-jwt-secret . ,(generate-jwt-secret)) + (lldap-key-seed . ,(generate-key-seed)) + (lldap-subdomain . #f) + (lldap-admin-password . "") + (stripe-api-key . "") + (authelia-jwt-secret . ,(generate-jwt-secret)) + (authelia-key-seed . ,(generate-authelia-key-seed)))) + (wordpress . ((subdomain . #f) + (db-password . ,(generate-postgres-password)) + (db-root-password . ,(generate-postgres-password)))) + (lldap . ((subdomain . #f) + (db-password . ,(generate-postgres-password)) + (jwt-secret . ,(generate-jwt-secret)) + (key-seed . ,(generate-key-seed)) + (admin-password . "") + (user-email . ""))))))) + (perform-review-submit instance-id))) + (get/widgets ("/config/wizard/services/:id") (let* ((instance-id (alist-ref "id" (current-params) equal?)) @@ -1796,232 +2155,7 @@ chmod -R 777 /opt/keys"))) (Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch"))))))))) (post "/config/wizard/review-submit/:id" - (let* ((instance-id (alist-ref "id" (current-params) equal?)) - (status (string->symbol - (->string - (with-db/transaction - (lambda (db) - (get-most-recent-deployment-status db (session-user-id) instance-id))))))) - (when (or (not (or (eq? status 'queued) (eq? status 'in-progress))) - (equal? (alist-ref 'force (current-params)) "true")) - (let* ((instance-id (alist-ref "id" (current-params) equal?)) - (restic-snapshot-id (alist-ref 'restic-snapshot-id (current-params))) - (results - (with-db/transaction - (lambda (db) - `((selected-apps . ,(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))) - (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)) - "," - (or (alist-ref 'subdomain (alist-ref (car app-version) config)) - "nassella-ignore") ;; a hack to get authelia to work for now - "," - (cdr app-version))) - selected-apps) - " ")) - ("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config))) - ("HOST_ADMIN_PASSWORD" . ,(create-authelia-password-hash (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 "\"]")))) - (let* ((instance-id (alist-ref "id" (current-params) equal?)) - (user-id (session-user-id)) - (app-config - (with-db/transaction - (lambda (db) - (get-user-app-config db (session-user-id) instance-id)))) - (first-deployment? (not (with-db/transaction (lambda (db) (get-most-recent-deployment-status db user-id instance-id))))) - (deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id)))) - (dir (deployment-directory user-id instance-id)) - (backup-request-id (conc (truncate (time->seconds (current-time))) "-" (pseudo-random-integer 10000)))) - (if first-deployment? - (with-db/transaction - (lambda (db) - (update-deployment-progress db deployment-id '((instance-backup . ignored) - (machine-destroy . ignored) - (ip-destroy . ignored) - (volume-destroy . ignored))))) - (begin - (with-db/transaction - (lambda (db) - (update-deployment-progress db deployment-id '((instance-backup . in-progress))))) - (handle-exceptions - exn - (with-db/transaction - (lambda (db) - (update-deployment-progress db deployment-id '((instance-backup . failed))))) - (send-instance-control-command - (alist-ref 'root-domain app-config) - (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config))) - "queue-restic-snapshot-no-restart" - (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config))) - `((path . "/") - (tag . "automated_pre_instance_update") - ;; effectively a guid, we just want something unique - (request_id . ,backup-request-id) - (version . 0)))))) - (thread-start! - (lambda () - (when (not first-deployment?) - (let ((start-time (time->seconds (current-time)))) - (let loop () - (thread-sleep! 1) - (let* ((status-result - (handle-exceptions - exn - '((status . "error")) - (send-instance-control-command - (alist-ref 'root-domain app-config) - (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config))) - "restic-snapshot-status" - (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config))) - `((request_id . ,backup-request-id) - (version . 0))))) - (complete (string=? (alist-ref 'status status-result) "complete"))) - (if (or complete (> (- (time->seconds (current-time)) start-time) 120)) - (with-db/transaction - (lambda (db) - (update-deployment-progress db deployment-id `((instance-backup . ,(or (and complete 'complete) 'failed)))))) - (loop)))))) - (change-directory dir) - (let ((pid (process-run "make preapply && 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 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-user-terraform-state db user-id instance-id - (if (eof-object? tf-state) "" tf-state) - (if (eof-object? tf-state-backup) "" tf-state-backup)) - (if (= status 0) - (update-deployment-progress db deployment-id `((instance-up . in-progress))) - (update-deployment-status - db user-id deployment-id - 'failed - (with-input-from-file (string-append dir "/make-out") read-string))))) - (when (= status 0) - (let ((instance-up (instance-up? (string-append "https://" - (alist-ref 'subdomain (alist-ref 'log-viewer (alist-ref 'config app-config))) - "." - (alist-ref 'root-domain app-config))))) - (with-db/transaction - (lambda (db) - (update-deployment-progress db deployment-id `((instance-up . ,(if instance-up 'complete 'failed)))) - (update-deployment-status - db user-id deployment-id - (if instance-up - 'complete - 'failed) - (with-input-from-file (string-append dir "/make-out") read-string)))))))))))))))) - (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?)))) + (perform-review-submit (alist-ref "id" (current-params) equal?))) (get/widgets ("/config/wizard/success/:id" @@ -2115,7 +2249,8 @@ chmod -R 777 /opt/keys"))) (@ (element main)) (h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Nassella - Instances") (form - (@ (action "/config/wizard/create-instance") + (@ ;; (action "/config/wizard/create-instance") + (action "/config/wizard/create-instance-full") (method POST)) (Button "Setup New Instance")) (ul (@ (style ((list-style "none")