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

Backblaze, db bugfixes and connection testing.

Browse Source
main
Thomas Hintz 2 weeks ago
parent 103beca17d
commit b285ad3980
6 changed files with 559 additions and 212 deletions
Show Stats Download Patch File Download Diff File

2
cl.yaml
Unescape Escape View File

@ -31,7 +31,7 @@ systemd:
[Service] [Service]
Type=oneshot Type=oneshot
EnvironmentFile=/restic-env 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 ExecStopPost=systemctl start app.service
- name: restic-backup.timer - name: restic-backup.timer

1
main.tf
Unescape Escape View File

@ -137,6 +137,7 @@ resource "digitalocean_droplet" "machine" {
size = var.server_type size = var.server_type
ssh_keys = [digitalocean_ssh_key.first.fingerprint] ssh_keys = [digitalocean_ssh_key.first.fingerprint]
user_data = file("ignition.json") user_data = file("ignition.json")
graceful_shutdown = true
lifecycle { lifecycle {
create_before_destroy = true create_before_destroy = true
} }

1
make-restic-generated.sh
Unescape Escape View File

@ -6,3 +6,4 @@ set -e
echo "AWS_ACCESS_KEY_ID=\"$BACKBLAZE_KEY_ID\"" echo "AWS_ACCESS_KEY_ID=\"$BACKBLAZE_KEY_ID\""
echo "AWS_SECRET_ACCESS_KEY=\"$BACKBLAZE_APPLICATION_KEY\"" echo "AWS_SECRET_ACCESS_KEY=\"$BACKBLAZE_APPLICATION_KEY\""
echo "BACKBLAZE_BUCKET_URL=\"$BACKBLAZE_BUCKET_URL\""

5
src/db-init.sql
Unescape Escape View File

@ -10,7 +10,10 @@ create unique index users_auth_user_id_idx on users (auth_user_id);
create table instances( create table instances(
instance_id bigserial primary key, 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); create unique index instances_user_id_instance_id_idx on instances (instance_id, user_id);

136
src/db.scm
Unescape Escape View File

@ -7,6 +7,9 @@
create-user delete-user create-user delete-user
create-instance get-user-instances 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-service-config get-user-service-config
update-user-selected-apps get-user-selected-apps update-user-selected-apps get-user-selected-apps
update-user-app-config get-user-app-config update-user-app-config get-user-app-config
@ -18,7 +21,7 @@
update-deployment-progress get-deployment-progress update-deployment-progress get-deployment-progress
get-most-recent-deployment-progress get-most-recent-deployment-progress
update-user-terraform-state get-user-terraform-state update-user-terraform-state get-user-terraform-state
get-user-deployments get-dashboard
) )
(import scheme (import scheme
@ -106,7 +109,7 @@
(values (hexstring->blob user-key) (hexstring->blob user-iv) auth-user-id))) (values (hexstring->blob user-key) (hexstring->blob user-iv) auth-user-id)))
(define (user-encrypt message user-key user-iv 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) (define (user-encrypt-for-db message user-key user-iv user-id)
(receive (message tag) (receive (message tag)
@ -115,7 +118,7 @@
(blob->hexstring/uppercase (string->blob tag))))) (blob->hexstring/uppercase (string->blob tag)))))
(define (user-decrypt message tag user-key user-iv user-id) (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) (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)))) (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) (define (delete-user conn user-id)
(query conn "delete from users where user_id=$1;" user-id)) (query conn "delete from users where user_id=$1;" user-id))
(define (create-instance conn user-id) ;; We also encrypt the ssh pub key not to hide it but to make it
(let ((instance-id ;; more difficult for someone to tamper with it which could allow
(value-at ;; an attacker to poison an instance with an ssh key that they have
(query conn ;; access to
"insert into instances(user_id) values ($1) returning instances.instance_id;" user-id)))) (define (create-instance conn user-id ssh-key-priv ssh-key-pub restic-password)
(query conn "insert into user_service_configs(user_id, instance_id) values ($1, $2);" user-id instance-id) (receive (user-key user-iv auth-user-id)
(query conn "insert into user_selected_apps(user_id, instance_id) values ($1, $2);" user-id instance-id) (get-decrypted-user-key-and-iv conn user-id)
(query conn "insert into user_app_configs(user_id, instance_id) values ($1, $2);" user-id instance-id) (let ((instance-id
(query conn "insert into user_terraform_state(user_id, instance_id) values ($1, $2);" user-id instance-id) (value-at
instance-id)) (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) (define (get-user-instances conn user-id)
(column-values (query conn "select instance_id from instances where user_id=$1;" 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))))) value)))))
res))) res)))
(define (get-user-deployments conn user-id) (define (get-dashboard conn user-id)
(let* ((res-raw (receive (user-key user-iv auth-user-id)
(query conn (get-decrypted-user-key-and-iv conn user-id)
(string-append (let ((res
"select " (query conn
(string-intersperse (string-append
(map-in-order (lambda (d) (string-append "d." (cdr d))) *deployments-column-map*) "select "
", ") (string-intersperse
", uac.root_domain" (map-in-order (lambda (d) (string-append "d." (cdr d))) *deployments-column-map*)
" from deployments as d " ", ")
"join user_app_configs uac on uac.user_id = d.user_id and uac.instance_id = d.instance_id" ", uac.root_domain, uac.config_enc, uac.instance_id, "
" where d.user_id=$1 order by d.id DESC limit 1;") "usa.wg_easy_version, usa.nextcloud_version, usa.log_viewer_version, usa.ghost_version "
user-id)) "from instances as i "
(res (if (> (row-count res-raw) 0) (row-alist res-raw) '()))) "join (select instance_id, max(id) as id from deployments group by instance_id) d2 "
(if (null? res) "on d2.instance_id = i.instance_id "
'() "join deployments d on d.id = d2.id "
;; I think this is just a hack as currently we only return 1 deployment "join user_app_configs uac on uac.user_id = d.user_id and uac.instance_id = d.instance_id "
(list "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) (map (lambda (item)
(let* ((key (car item)) (let* ((key (car item))
(value (cdr 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) `(,config . ,(if (sql-null? value)
#f #f
(if (string? value) (if (and (string? value) (member config *deployments-column-map*))
(string->symbol value) (string->symbol value)
value))))) (if (eq? key 'config_enc)
res))))) (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) (define (update-user-terraform-state conn user-id instance-id state backup)
(receive (user-key user-iv auth-user-id) (receive (user-key user-iv auth-user-id)
@ -456,10 +516,12 @@ returning users.user_id;"
(let ((res (row-alist (query conn (let ((res (row-alist (query conn
"select state_enc, state_backup_enc from user_terraform_state where user_id=$1 and instance_id=$2;" "select state_enc, state_backup_enc from user_terraform_state where user_id=$1 and instance_id=$2;"
user-id instance-id)))) 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))) (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))))))) (user-decrypt-from-db (alist-ref 'state_backup_enc res) user-key user-iv user-id)))))))

626
src/nassella.scm
Unescape Escape View File

@ -9,9 +9,13 @@
(chicken process-context) (chicken process-context)
(chicken irregex) (chicken irregex)
(chicken file) (chicken file)
(chicken condition)
(rename srfi-1 (delete srfi1:delete)) (rename srfi-1 (delete srfi1:delete))
srfi-13
srfi-18 srfi-18
srfi-158
srfi-194
html-widgets html-widgets
sxml-transforms sxml-transforms
@ -23,7 +27,8 @@
medea medea
intarweb intarweb
nassella-db nassella-db
sql-null) sql-null
openssl)
(define app (schematra/make-app)) (define app (schematra/make-app))
@ -295,11 +300,16 @@ h1, h2, h3, h4, h5, h6 {
(define-syntax get/widgets (define-syntax get/widgets
(syntax-rules () (syntax-rules ()
((_ (path) body ...) ((_ (path) body ...)
(get/widgets (path '()) body ...))
((_ (path headers) body ...)
(get path (get path
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(widget-sxml->html (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 (begin
;; TODO remove once sessions are integrated ;; TODO remove once sessions are integrated
(session-set! "user-id" (test-user-id)) (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") input label)
,(if (equal? type "checkbox") label input)))) ,(if (equal? type "checkbox") label input))))
(define-widget (Button ((type "submit")) contents) (define-widget (Button ((type "submit") (enabled #t)) contents)
`(button (@ (type ,type) `(button (@ (type ,type)
(style ((background ,($ 'color.primary)) ,@(if enabled '() '((disabled)))
(color ,($ 'color.primary.contrast)) (style ((background ,(if enabled
($ 'color.primary)
($ 'color.primary.contrast)))
(color ,(if enabled
($ 'color.primary.contrast)
($ 'color.primary)))
(border-radius ,($ 'radius.medium)) (border-radius ,($ 'radius.medium))
(border-color ,($ 'color.primary.shade)) (border-color ,($ 'color.primary.shade))
(cursor "pointer")))) ,@(if enabled
'((cursor "pointer"))
'()))))
,@contents)) ,@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 `(HStack
(@ (style ((justify-content "space-between")))) (@ (style ((justify-content "space-between"))))
(a (@ (href ,(or back-to "")) (a (@ (href ,(or back-to ""))
@ -496,7 +513,7 @@ h1, h2, h3, h4, h5, h6 {
'() '()
'((pointer-events "none")))))) '((pointer-events "none"))))))
"Back") "Back")
(Button ,submit-button))) (Button (@ (enabled ,submit-enabled)) ,submit-button)))
;; Parsing JSON arrays as lists instead of vectors ;; Parsing JSON arrays as lists instead of vectors
(define array-as-list-parser (define array-as-list-parser
@ -534,6 +551,78 @@ h1, h2, h3, h4, h5, h6 {
(Authorization ,(conc "Bearer " api-token))))))) (Authorization ,(conc "Bearer " api-token)))))))
(with-input-from-request req #f read-json)))))) (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) (define (deployment-directory user-id)
(string-append "deploy-" (number->string user-id))) (string-append "deploy-" (number->string user-id)))
@ -579,13 +668,84 @@ h1, h2, h3, h4, h5, h6 {
((complete) "complete") ((complete) "complete")
((failed) "failed"))) ((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 (with-schematra-app app
(lambda () (lambda ()
(post "/config/wizard/create-instance" (post "/config/wizard/create-instance"
(let ((instance-id (with-db/transaction (let* ((ssh-keys (generate-ssh-key (session-user-id)))
(lambda (db) (instance-id (with-db/transaction
(create-instance db (session-user-id)))))) (lambda (db)
(create-instance db (session-user-id) (first ssh-keys) (second ssh-keys)
(generate-restic-password))))))
(redirect (conc "/config/wizard/services/" instance-id)))) (redirect (conc "/config/wizard/services/" instance-id))))
;; TODO should all these key related form fields be of type password ;; TODO should all these key related form fields be of type password
@ -638,7 +798,15 @@ h1, h2, h3, h4, h5, h6 {
(get/widgets (get/widgets
("/config/wizard/services-success/:id") ("/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 `(App
(Configuration-Wizard (Configuration-Wizard
(@ (step "Services")) (@ (step "Services"))
@ -647,17 +815,37 @@ h1, h2, h3, h4, h5, h6 {
(VStack (VStack
(Fieldset (Fieldset
(@ (title "Cloudflare")) (@ (title "Cloudflare"))
(h3 "Connected") ,@(if (alist-ref 'success cloudflare-result)
(p "Your Cloudflare account was successfully connected!")) `((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 (Fieldset
(@ (title "DigitalOcean")) (@ (title "DigitalOcean"))
(h3 "Connected") ,@(if (alist-ref 'success digitalocean-result)
(p "Your DigitalOcean account was successfully connected!")) `((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 (Fieldset
(@ (title "Backblaze")) (@ (title "Backblaze"))
(h3 "Connected") (h3 "Connected")
(p "Your Backblaze account was successfully 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 (get/widgets
("/config/wizard/apps/:id") ("/config/wizard/apps/:id")
@ -669,7 +857,8 @@ h1, h2, h3, h4, h5, h6 {
car car
(filter cdr (filter cdr
(get-user-selected-apps db (session-user-id) instance-id)))) (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 `(App
(Configuration-Wizard (Configuration-Wizard
(@ (step "Apps")) (@ (step "Apps"))
@ -679,13 +868,24 @@ h1, h2, h3, h4, h5, h6 {
(Fieldset (Fieldset
(@ (title "Root Domain")) (@ (title "Root Domain"))
(Field (@ (element select) (name "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 (Fieldset
(@ (title "Selected Apps")) (@ (title "Selected Apps"))
(Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps results))))) (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 "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 "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")))) (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)))))))))) (Form-Nav (@ (back-to ,(conc "/config/wizard/services-success/" instance-id))))))))))
(post "/config/wizard/apps-submit/:id" (post "/config/wizard/apps-submit/:id"
@ -696,9 +896,9 @@ h1, h2, h3, h4, h5, h6 {
db db
(session-user-id) (session-user-id)
instance-id instance-id
`((wg-easy . ,(or (and (alist-ref 'wg-easy (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)) "0.0") (sql-null))) (nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "31.0.8") (sql-null)))
(ghost . ,(or (and (alist-ref 'ghost (current-params)) "0.0") (sql-null))))) (ghost . ,(or (and (alist-ref 'ghost (current-params)) "6.10.0") (sql-null)))))
(update-root-domain db (update-root-domain db
(session-user-id) (session-user-id)
instance-id instance-id
@ -774,23 +974,36 @@ h1, h2, h3, h4, h5, h6 {
(let ((instance-id (alist-ref "id" (current-params) equal?))) (let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction (with-db/transaction
(lambda (db) (lambda (db)
(update-user-app-config (let ((config (alist-ref 'config (get-user-app-config db (session-user-id) instance-id))))
db (update-user-app-config
(session-user-id) db
instance-id (session-user-id)
`((ghost . ((subdomain . ,(alist-ref 'ghost-subdomain (current-params))))) instance-id
(wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params))))) `((ghost . ((subdomain . ,(alist-ref 'ghost-subdomain (current-params)))
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params))) (postgres-root-password . ,(or (alist-ref 'postgres-root-password
(admin-user . ,(alist-ref 'nextcloud-admin-user (current-params))) (alist-ref 'ghost config eq? '()))
(admin-password . ,(alist-ref 'nextcloud-admin-password (current-params))))) (generate-postgres-password)))
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params))) (postgres-password . ,(or (alist-ref 'postgres-password
(user . ,(alist-ref 'log-viewer-user (current-params))) (alist-ref 'ghost config eq? '()))
(password . ,(alist-ref 'log-viewer-password (current-params))))) (generate-postgres-password)))))
(all-apps . ((smtp-host . ,(alist-ref 'smtp-host (current-params))) (wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params)))))
(smtp-port . ,(alist-ref 'smtp-port (current-params))) (nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params)))
(smtp-auth-user . ,(alist-ref 'smtp-auth-user (current-params))) (admin-user . ,(alist-ref 'nextcloud-admin-user (current-params)))
(smtp-auth-password . ,(alist-ref 'smtp-auth-password (current-params))) (admin-password . ,(alist-ref 'nextcloud-admin-password (current-params)))
(smtp-from . ,(alist-ref 'smtp-from (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)))) (redirect (conc "/config/wizard/machine/" instance-id))))
(get/widgets (get/widgets
@ -815,16 +1028,18 @@ h1, h2, h3, h4, h5, h6 {
(get-digital-ocean-regions (alist-ref 'digitalocean-api-token config))))) (get-digital-ocean-regions (alist-ref 'digitalocean-api-token config)))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2/" instance-id)))))))))) (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" (post "/config/wizard/machine-submit/:id"
(let ((instance-id (alist-ref "id" (current-params) equal?))) (let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction (with-db/transaction
(lambda (db) (lambda (db)
(update-user-service-config (update-user-service-config
db db
(session-user-id) (session-user-id)
instance-id instance-id
`((digitalocean-region . ,(alist-ref 'region (current-params))))))) `((digitalocean-region . ,(alist-ref 'region (current-params)))))))
(redirect (conc "/config/wizard/machine2/" instance-id)))) (redirect (conc "/config/wizard/machine2/" instance-id))))
(get/widgets (get/widgets
("/config/wizard/machine2/:id") ("/config/wizard/machine2/:id")
@ -902,118 +1117,142 @@ h1, h2, h3, h4, h5, h6 {
(VStack (VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch"))))))))) (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! ;; 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 ;; 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" (post "/config/wizard/review-submit/:id"
(let* ((instance-id (alist-ref "id" (current-params) equal?)) (let* ((instance-id (alist-ref "id" (current-params) equal?))
(results (results
(with-db/transaction (with-db/transaction
(lambda (db) (lambda (db)
`((selected-apps . ,(map `((selected-apps . ,(map
car car
(filter cdr (filter cdr
(get-user-selected-apps db (session-user-id) instance-id)))) (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)) (service-config . ,(get-user-service-config db (session-user-id) instance-id))
(terraform-state . ,(get-user-terraform-state 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))) (ssh-pub-key . ,(get-instance-ssh-pub-key db (session-user-id) instance-id))
(app-config (alist-ref 'app-config results)) (restic-password . ,(get-instance-restic-password db (session-user-id) instance-id))))))
(config (alist-ref 'config app-config)) (selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(root-domain (alist-ref 'root-domain app-config)) (app-config (alist-ref 'app-config results))
(service-config (alist-ref 'service-config results)) (config (alist-ref 'config app-config))
(terraform-state (alist-ref 'terraform-state results)) (root-domain (alist-ref 'root-domain app-config))
(dir (deployment-directory (session-user-id)))) (service-config (alist-ref 'service-config results))
(setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state)) (terraform-state (alist-ref 'terraform-state results))
(with-output-to-file (string-append dir "/config/apps.config") (ssh-pub-key (alist-ref 'ssh-pub-key results))
(lambda () (restic-password (alist-ref 'restic-password results))
(map (lambda (e) (dir (deployment-directory (session-user-id))))
(write-config-entry (car e) (cdr e))) (setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
`(("ROOT_DOMAIN" . ,root-domain) (with-output-to-file (string-append dir "/config/apps.config")
("APP_CONFIGS" . ,(string-intersperse (lambda ()
(map (lambda (app) (map (lambda (e)
(conc (if (eq? app 'log-viewer) 'dozzle app) (write-config-entry (car e) (cdr e)))
"," `(("ROOT_DOMAIN" . ,root-domain)
(alist-ref 'subdomain (alist-ref app config)))) ("APP_CONFIGS" . ,(string-intersperse
selected-apps) (map (lambda (app)
" ")) (conc (if (eq? app 'log-viewer) 'dozzle app)
("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config))) ","
("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config))) (alist-ref 'subdomain (alist-ref app config))))
("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config))) selected-apps)
("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config))) " "))
("NEXTCLOUD_POSTGRES_DB" . "nextcloud") ("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
("NEXTCLOUD_POSTGRES_USER" . "nextcloud") ("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config)))
("NEXTCLOUD_POSTGRES_PASSWORD" . "dbpassword") ;; TODO generate ("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
("NEXTCLOUD_REDIS_PASSWORD" . "redispassword") ;; TODO generate ("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
("GHOST_DATABASE_ROOT_PASSWORD" . "reallysecurerootpassword") ;; TODO generate ("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
("GHOST_DATABASE_PASSWORD" . "ghostpassword") ;; TODO generate ("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config))) ("NEXTCLOUD_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nextcloud config)))
("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config))) ("NEXTCLOUD_REDIS_PASSWORD" . ,(alist-ref 'redis-password (alist-ref 'nextcloud config)))
("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config))) ("GHOST_DATABASE_ROOT_PASSWORD" . ,(alist-ref 'postgres-root-password (alist-ref 'ghost config)))
("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config))) ("GHOST_DATABASE_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'ghost config)))
("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config))) ("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config)) ("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config)) ("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config)) ("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
("RESTIC_PASSWORD" . "foodisgood"))))) ;; TODO generate or get from user ("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
(with-output-to-file (string-append dir "/config/production.tfvars") ("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
(lambda () ("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
(map (lambda (e) ("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
(write-config-entry (car e) (cdr e))) ("RESTIC_PASSWORD" . ,restic-password)))))
`(("server_type" . ,(alist-ref 'digitalocean-size service-config)) (with-output-to-file (string-append dir "/config/production.tfvars")
("do_token" . ,(alist-ref 'digitalocean-api-token service-config)) (lambda ()
("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config)) (map (lambda (e)
("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config)) (write-config-entry (car e) (cdr e)))
("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config)) `(("server_type" . ,(alist-ref 'digitalocean-size service-config))
("cluster_name" . "mycluster") ("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
("datacenter" . ,(alist-ref 'digitalocean-region service-config)) ("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
("flatcar_stable_version" . "4459.2.1"))) ("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
(display "ssh_keys=[\"") (display (with-input-from-file (string-append dir "/config/ssh-keys") read-string)) (print "\"]")))) ("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
(let* ((instance-id (alist-ref "id" (current-params) equal?)) ("cluster_name" . "mycluster")
(user-id (session-user-id)) ("datacenter" . ,(alist-ref 'digitalocean-region service-config))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id)))) ("flatcar_stable_version" . "4459.2.1")))
(dir (deployment-directory user-id))) ;; remove the newline that generating the ssh key adds
(thread-start! (display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]"))))
(lambda () (let* ((instance-id (alist-ref "id" (current-params) equal?))
(change-directory dir) (user-id (session-user-id))
(let ((pid (process-run "make apply > make-out"))) (deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
(with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid))) (dir (deployment-directory user-id)))
(change-directory "../") (thread-start!
(let loop () (lambda ()
(thread-sleep! 5) (change-directory dir)
(receive (pid exit-normal status) (process-wait pid #t) (let ((pid (process-run "make apply > make-out 2>&1")))
(if (= pid 0) (with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
(begin (let ((progress (parse-deployment-log (change-directory "../")
(with-input-from-file (let loop ()
(string-append (deployment-directory user-id) "/make-out") (thread-sleep! 5)
read-string)))) (receive (pid exit-normal status) (process-wait pid #t)
(with-db/transaction (if (= pid 0) ;; process is still running
(lambda (db) (begin (let ((progress (parse-deployment-log
(update-deployment-progress db deployment-id progress)))) (with-input-from-file
(loop)) (string-append (deployment-directory user-id) "/make-out")
(let ((progress (parse-deployment-log read-string)))
(with-input-from-file (tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string))
(string-append (deployment-directory user-id) "/make-out") (tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))
read-string)))) (with-db/transaction
(with-db/transaction (lambda (db)
(lambda (db) (update-deployment-progress db deployment-id progress)
(update-deployment-progress db deployment-id progress) (when (file-exists? (string-append dir "/terraform.tfstate"))
;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES (update-user-terraform-state db user-id instance-id
;; like the random digital ocean error saying the IP can't be (if (eof-object? tf-state) "" tf-state)
;; updated because another operation is in progress. (if (eof-object? tf-state-backup) "" tf-state-backup))))))
;; it still registers as "success". (loop))
;; probably need to also write stderr to a file and read/store/parse that? (let ((progress (parse-deployment-log
;; Should we parse make-out for string "Apply complete!" ? (with-input-from-file
(update-deployment-status (string-append (deployment-directory user-id) "/make-out")
db user-id deployment-id read-string)))
(if exit-normal 'complete 'failed) (tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string))
(with-input-from-file (string-append dir "/make-out") read-string)) (tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))
(update-user-terraform-state db user-id instance-id (with-db/transaction
(with-input-from-file (string-append dir "/terraform.tfstate") read-string) (lambda (db)
(with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))))))))))) (update-deployment-progress db deployment-id progress)
(redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?)))) ;; 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 (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?)) (let* ((instance-id (alist-ref "id" (current-params) equal?))
(res (with-db/transaction (res (with-db/transaction
(lambda (db) (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)) (output (with-input-from-file (string-append (deployment-directory (session-user-id)) "/make-out") read-string))
(progress (alist-ref 'progress res)) (progress (alist-ref 'progress res))
(status (alist-ref 'status res))) (status (alist-ref 'status res)))
`(VStack `(App
(h1 (Main-Container
,(case (string->symbol status) (VStack
((queued) "Deployment queued") (h1
((in-progress) "Deployment in progress") ,(case (string->symbol status)
((complete) "Deployment complete!") ((queued) "Deployment queued")
((failed) "Deployment failed"))) ((in-progress) "Deployment in progress")
(ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress))) ((complete) "Deployment complete!")
(li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress))) ((failed) "Deployment failed")))
(li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress))) (ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
(li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress)))) (li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
(pre ,output) (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 (get/widgets
("/dashboard") ("/dashboard")
@ -1046,13 +1294,45 @@ h1, h2, h3, h4, h5, h6 {
(@ (action "/config/wizard/create-instance") (@ (action "/config/wizard/create-instance")
(method POST)) (method POST))
(Button "Setup New Instance")) (Button "Setup New Instance"))
(ul ,@(map (lambda (deployment) (ul ,@(map (lambda (instance)
`(li (a (@ (href ,(conc "/deployments/" (alist-ref 'id deployment)))) (let ((root-domain (alist-ref 'root-domain instance))
,(alist-ref 'root-domain deployment)) (config (alist-ref 'config instance)))
" - ",(alist-ref 'status deployment))) `(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 (with-db/transaction
(lambda (db) (lambda (db)
(get-user-deployments db (session-user-id)))))))))) (get-dashboard db (session-user-id))))))))))
(schematra-install) (schematra-install)

Write Preview
Loading…
Cancel
Save