Backblaze, db bugfixes and connection testing.
This commit is contained in:
626
src/nassella.scm
626
src/nassella.scm
@@ -9,9 +9,13 @@
|
||||
(chicken process-context)
|
||||
(chicken irregex)
|
||||
(chicken file)
|
||||
(chicken condition)
|
||||
|
||||
(rename srfi-1 (delete srfi1:delete))
|
||||
srfi-13
|
||||
srfi-18
|
||||
srfi-158
|
||||
srfi-194
|
||||
|
||||
html-widgets
|
||||
sxml-transforms
|
||||
@@ -23,7 +27,8 @@
|
||||
medea
|
||||
intarweb
|
||||
nassella-db
|
||||
sql-null)
|
||||
sql-null
|
||||
openssl)
|
||||
|
||||
(define app (schematra/make-app))
|
||||
|
||||
@@ -295,11 +300,16 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(define-syntax get/widgets
|
||||
(syntax-rules ()
|
||||
((_ (path) body ...)
|
||||
(get/widgets (path '()) body ...))
|
||||
((_ (path headers) body ...)
|
||||
(get path
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(widget-sxml->html
|
||||
'((meta (@ (name "viewport") (content "width=device-width"))))
|
||||
(cons
|
||||
'(meta (@ (name "viewport") (content "width=device-width")))
|
||||
headers)
|
||||
;; `((meta (@ (name "viewport") (content "width=device-width"))))
|
||||
(begin
|
||||
;; TODO remove once sessions are integrated
|
||||
(session-set! "user-id" (test-user-id))
|
||||
@@ -470,16 +480,23 @@ h1, h2, h3, h4, h5, h6 {
|
||||
,(if (equal? type "checkbox") input label)
|
||||
,(if (equal? type "checkbox") label input))))
|
||||
|
||||
(define-widget (Button ((type "submit")) contents)
|
||||
(define-widget (Button ((type "submit") (enabled #t)) contents)
|
||||
`(button (@ (type ,type)
|
||||
(style ((background ,($ 'color.primary))
|
||||
(color ,($ 'color.primary.contrast))
|
||||
,@(if enabled '() '((disabled)))
|
||||
(style ((background ,(if enabled
|
||||
($ 'color.primary)
|
||||
($ 'color.primary.contrast)))
|
||||
(color ,(if enabled
|
||||
($ 'color.primary.contrast)
|
||||
($ 'color.primary)))
|
||||
(border-radius ,($ 'radius.medium))
|
||||
(border-color ,($ 'color.primary.shade))
|
||||
(cursor "pointer"))))
|
||||
,@(if enabled
|
||||
'((cursor "pointer"))
|
||||
'()))))
|
||||
,@contents))
|
||||
|
||||
(define-widget (Form-Nav ((back-to #f) (submit-button "Next")))
|
||||
(define-widget (Form-Nav ((back-to #f) (submit-button "Next") (submit-enabled #t)))
|
||||
`(HStack
|
||||
(@ (style ((justify-content "space-between"))))
|
||||
(a (@ (href ,(or back-to ""))
|
||||
@@ -496,7 +513,7 @@ h1, h2, h3, h4, h5, h6 {
|
||||
'()
|
||||
'((pointer-events "none"))))))
|
||||
"Back")
|
||||
(Button ,submit-button)))
|
||||
(Button (@ (enabled ,submit-enabled)) ,submit-button)))
|
||||
|
||||
;; Parsing JSON arrays as lists instead of vectors
|
||||
(define array-as-list-parser
|
||||
@@ -534,6 +551,78 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(Authorization ,(conc "Bearer " api-token)))))))
|
||||
(with-input-from-request req #f read-json))))))
|
||||
|
||||
(define (get-cloudflare-domains api-token)
|
||||
(map
|
||||
(lambda (x)
|
||||
(alist-ref 'name x))
|
||||
(alist-ref
|
||||
'result
|
||||
(let* ((uri (uri-reference "https://api.cloudflare.com/client/v4/zones"))
|
||||
(req (make-request method: 'GET
|
||||
uri: uri
|
||||
headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw)))))))
|
||||
(with-input-from-request req #f read-json)
|
||||
;; (handle-exceptions exn (get-condition-property exn 'client-error 'body)
|
||||
;; (with-input-from-request req #f read-json))
|
||||
))))
|
||||
|
||||
;; TODO this currently only supports the first page
|
||||
;; Example return json:
|
||||
;; ((result ((id . "aaa") (name . "example.org") (status . "active")
|
||||
;; (paused . #f) (type . "full") (development_mode . 0)
|
||||
;; (name_servers "abby.ns.cloudflare.com" "toby.ns.cloudflare.com")
|
||||
;; (original_name_servers . null) (original_registrar . null) (original_dnshost . null)
|
||||
;; (modified_on . "2025-08-13T17:17:10.664419Z") (created_on . "2025-08-13T17:17:05.956271Z")
|
||||
;; (activated_on . "2025-08-13T17:17:10.476671Z") (vanity_name_servers)
|
||||
;; (vanity_name_servers_ips . null)
|
||||
;; (meta (step . 4) (custom_certificate_quota . 0) (page_rule_quota . 3) (phishing_detected . #f))
|
||||
;; (owner (id . null) (type . "user") (email . null))
|
||||
;; (account (id . "aaa") (name . "XXX's Account"))
|
||||
;; (tenant (id . null) (name . null)) (tenant_unit (id . null))
|
||||
;; (permissions "#dns_records:edit" "#dns_records:read" "#zone:read")
|
||||
;; (plan (id . "0feeeeeeeeeeeeeeeeeeeeeeeeeeeeee") (name . "Free Website") (price . 0)
|
||||
;; (currency . "USD") (frequency . "") (is_subscribed . #f) (can_subscribe . #f)
|
||||
;; (legacy_id . "free") (legacy_discount . #f) (externally_managed . #f))))
|
||||
;; (result_info (page . 1) (per_page . 20) (total_pages . 1) (count . 1) (total_count . 1))
|
||||
;; (success . #t) (errors) (messages))
|
||||
(define (test-cloudflare-connection api-token zone-id account-id)
|
||||
(let* ((uri (uri-reference "https://api.cloudflare.com/client/v4/zones"))
|
||||
(req (make-request method: 'GET
|
||||
uri: uri
|
||||
headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw)))))))
|
||||
(let ((res (handle-exceptions exn (read-json (get-condition-property exn 'client-error 'body))
|
||||
(with-input-from-request req #f read-json))))
|
||||
(if (alist-ref 'success res)
|
||||
(let ((matches
|
||||
(filter (lambda (x) (and (string=? (alist-ref 'id x) zone-id)
|
||||
(string=? (alist-ref 'id (alist-ref 'account x)) account-id)))
|
||||
(alist-ref 'result res))))
|
||||
(if (null? matches)
|
||||
'((success . #f)
|
||||
(errors ((message . "Account ID and/or Zone ID does not match API Token."))))
|
||||
'((success . #t)
|
||||
(result ,matches))))
|
||||
res))))
|
||||
|
||||
(define (test-digitalocean-connection api-token)
|
||||
(let* ((uri (uri-reference "https://api.digitalocean.com/v2/account"))
|
||||
(req (make-request method: 'GET
|
||||
uri: uri
|
||||
headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw)))))))
|
||||
(let ((res (handle-exceptions exn (read-json (get-condition-property exn 'client-error 'body))
|
||||
(with-input-from-request req #f read-json))))
|
||||
(if (alist-ref 'account res)
|
||||
(if (string=? (alist-ref 'status (alist-ref 'account res)) "active")
|
||||
`((success . #t)
|
||||
(result ,res))
|
||||
'((success . #f)
|
||||
(errors ((message . "Token is valid but account status is not 'active'.")))))
|
||||
`((success . #f)
|
||||
(errors ((message . ,(alist-ref 'message res)))))))))
|
||||
|
||||
;; (define (test-backblaze-connection key-id application-key bucket-url)
|
||||
;; )
|
||||
|
||||
(define (deployment-directory user-id)
|
||||
(string-append "deploy-" (number->string user-id)))
|
||||
|
||||
@@ -579,13 +668,84 @@ h1, h2, h3, h4, h5, h6 {
|
||||
((complete) "complete")
|
||||
((failed) "failed")))
|
||||
|
||||
;; (with-db/transaction
|
||||
;; (lambda (db)
|
||||
;; (update-instance-ssh-pub-key db 1 22 "")))
|
||||
|
||||
;; (with-db/transaction
|
||||
;; (lambda (db)
|
||||
;; (get-instance-ssh-pub-key db 1 22)))
|
||||
|
||||
;; Generates an ssh key via ssh-keygen running in docker
|
||||
;; Returns a list with the first element being the private key
|
||||
;; and the second element being the corresponding public key.
|
||||
;; Does not leave a trace of the generated keys on the filesystem.
|
||||
(define (generate-ssh-key user-id)
|
||||
(define (generate-ssh-key_ filepath counter)
|
||||
(if (directory-exists? (conc filepath counter))
|
||||
(generate-ssh-key_ filepath (+ counter 1))
|
||||
(conc filepath counter)))
|
||||
(let ((key-path (generate-ssh-key_ (conc "temp-ssh-keys-" user-id "-") 0)))
|
||||
(create-directory key-path)
|
||||
(receive (in-port out-port pid err-port)
|
||||
;; There are docker images that exist that include ssh-keygen
|
||||
;; but none of them are "official". For something sensitive like
|
||||
;; this it seems much better to only use an official image so there
|
||||
;; is less chance of an image doing something malicious and we don't
|
||||
;; notice when updating the image this command uses.
|
||||
;;
|
||||
;; This command maps a volume to the unique directory we created above
|
||||
;; and uses that to store the generated ssh keys.
|
||||
;; Later on this directory gets deleted after we read the keys into
|
||||
;; strings to return from this function.
|
||||
(process* "docker" `("run" "--rm" "--volume"
|
||||
,(conc (current-directory) "/" key-path ":/opt/keys")
|
||||
"debian:12-slim" "bash" "-c" "apt update
|
||||
apt install -y openssh-client
|
||||
ssh-keygen -t ed25519 -f /opt/keys/key -N \"\"
|
||||
chmod -R 777 /opt/keys"))
|
||||
(let ((thread
|
||||
(thread-start!
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(thread-sleep! 1)
|
||||
;; We do a non-blocking wait here so that we don't
|
||||
;; block the entire web process.
|
||||
(receive (wait-pid exit-normal status) (process-wait pid #t)
|
||||
(if (= wait-pid 0) ;; wait-pid is 0 until the process has finished
|
||||
(loop)
|
||||
(let ((priv-key (with-input-from-file (conc key-path "/key") read-string))
|
||||
(pub-key (with-input-from-file (conc key-path "/key.pub") read-string)))
|
||||
(with-input-from-port in-port read-string) ;; left here for debugging and to clear ports
|
||||
(with-input-from-port err-port read-string) ;; left here for debugging and to clear ports
|
||||
(delete-directory key-path #t)
|
||||
(list priv-key pub-key)))))))))
|
||||
(thread-join! thread)))))
|
||||
|
||||
(define (generate-restic-password)
|
||||
(generator->string (gtake (make-random-char-generator
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
|
||||
30)))
|
||||
|
||||
(define (generate-postgres-password)
|
||||
(generator->string (gtake (make-random-char-generator
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
|
||||
40)))
|
||||
|
||||
(define (generate-redis-password)
|
||||
(generator->string (gtake (make-random-char-generator
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
|
||||
40)))
|
||||
|
||||
(with-schematra-app app
|
||||
(lambda ()
|
||||
|
||||
(post "/config/wizard/create-instance"
|
||||
(let ((instance-id (with-db/transaction
|
||||
(lambda (db)
|
||||
(create-instance db (session-user-id))))))
|
||||
(let* ((ssh-keys (generate-ssh-key (session-user-id)))
|
||||
(instance-id (with-db/transaction
|
||||
(lambda (db)
|
||||
(create-instance db (session-user-id) (first ssh-keys) (second ssh-keys)
|
||||
(generate-restic-password))))))
|
||||
(redirect (conc "/config/wizard/services/" instance-id))))
|
||||
|
||||
;; TODO should all these key related form fields be of type password
|
||||
@@ -638,7 +798,15 @@ h1, h2, h3, h4, h5, h6 {
|
||||
|
||||
(get/widgets
|
||||
("/config/wizard/services-success/:id")
|
||||
(let ((instance-id (alist-ref "id" (current-params) equal?)))
|
||||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||||
(service-config
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(get-user-service-config db (session-user-id) instance-id))))
|
||||
(cloudflare-result (test-cloudflare-connection (alist-ref 'cloudflare-api-token service-config)
|
||||
(alist-ref 'cloudflare-zone-id service-config)
|
||||
(alist-ref 'cloudflare-account-id service-config)))
|
||||
(digitalocean-result (test-digitalocean-connection (alist-ref 'digitalocean-api-token service-config))))
|
||||
`(App
|
||||
(Configuration-Wizard
|
||||
(@ (step "Services"))
|
||||
@@ -647,17 +815,37 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(VStack
|
||||
(Fieldset
|
||||
(@ (title "Cloudflare"))
|
||||
(h3 "Connected")
|
||||
(p "Your Cloudflare account was successfully connected!"))
|
||||
,@(if (alist-ref 'success cloudflare-result)
|
||||
`((h3 "Connected")
|
||||
(p "Your Cloudflare account was successfully connected!"))
|
||||
`((h3 "Connection Failed")
|
||||
(p "Unable to make a connection via Cloudflare API. Message is: \""
|
||||
,(string-intersperse
|
||||
(map (lambda (err)
|
||||
(alist-ref 'message err))
|
||||
(alist-ref 'errors cloudflare-result))
|
||||
"\" & \"")
|
||||
"\""))))
|
||||
(Fieldset
|
||||
(@ (title "DigitalOcean"))
|
||||
(h3 "Connected")
|
||||
(p "Your DigitalOcean account was successfully connected!"))
|
||||
,@(if (alist-ref 'success digitalocean-result)
|
||||
`((h3 "Connected")
|
||||
(p "Your DigitalOcean account was successfully connected!"))
|
||||
`((h3 "Connection Failed")
|
||||
(p "Unable to make a connection via DigitalOcean API. Message is: \""
|
||||
,(string-intersperse
|
||||
(map (lambda (err)
|
||||
(alist-ref 'message err))
|
||||
(alist-ref 'errors digitalocean-result))
|
||||
"\" & \"")
|
||||
"\""))))
|
||||
(Fieldset
|
||||
(@ (title "Backblaze"))
|
||||
(h3 "Connected")
|
||||
(p "Your Backblaze account was successfully connected!"))
|
||||
(Form-Nav (@ (back-to ,(conc "/config/wizard/services/" instance-id))))))))))
|
||||
(Form-Nav (@ (back-to ,(conc "/config/wizard/services/" instance-id))
|
||||
(submit-enabled ,(and (alist-ref 'success cloudflare-result)
|
||||
(alist-ref 'success digitalocean-result)))))))))))
|
||||
|
||||
(get/widgets
|
||||
("/config/wizard/apps/:id")
|
||||
@@ -669,7 +857,8 @@ h1, h2, h3, h4, h5, h6 {
|
||||
car
|
||||
(filter cdr
|
||||
(get-user-selected-apps db (session-user-id) instance-id))))
|
||||
(app-config . ,(get-user-app-config db (session-user-id) instance-id)))))))
|
||||
(app-config . ,(get-user-app-config db (session-user-id) instance-id))
|
||||
(service-config . ,(get-user-service-config db (session-user-id) instance-id)))))))
|
||||
`(App
|
||||
(Configuration-Wizard
|
||||
(@ (step "Apps"))
|
||||
@@ -679,13 +868,24 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(Fieldset
|
||||
(@ (title "Root Domain"))
|
||||
(Field (@ (element select) (name "root-domain"))
|
||||
(option (@ (value ,(or (alist-ref 'root-domain (alist-ref 'app-config results)) "nassella.cc"))) "nassella.cc"))) ;; TODO fetch from cloudflare API?
|
||||
,@(map (lambda (domain)
|
||||
`(option (@ (value ,domain)
|
||||
,@(if (equal? domain
|
||||
(alist-ref 'root-domain (alist-ref 'app-config results)))
|
||||
'(selected)
|
||||
'()))
|
||||
,domain))
|
||||
(get-cloudflare-domains (alist-ref 'cloudflare-api-token
|
||||
(alist-ref 'service-config results))))
|
||||
))
|
||||
(Fieldset
|
||||
(@ (title "Selected Apps"))
|
||||
(Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps results)))))
|
||||
(Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'nextcloud (alist-ref 'selected-apps results)))))
|
||||
(Field (@ (name "ghost") (type "checkbox") (label ("Ghost")) (checked ,(member 'ghost (alist-ref 'selected-apps results)))))
|
||||
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
|
||||
;; TODO add config for when automatic upgrades are scheduled for?
|
||||
;; TODO add config for server timezone?
|
||||
(Form-Nav (@ (back-to ,(conc "/config/wizard/services-success/" instance-id))))))))))
|
||||
|
||||
(post "/config/wizard/apps-submit/:id"
|
||||
@@ -696,9 +896,9 @@ h1, h2, h3, h4, h5, h6 {
|
||||
db
|
||||
(session-user-id)
|
||||
instance-id
|
||||
`((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "0.0") (sql-null)))
|
||||
(nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "0.0") (sql-null)))
|
||||
(ghost . ,(or (and (alist-ref 'ghost (current-params)) "0.0") (sql-null)))))
|
||||
`((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "15.1.0") (sql-null)))
|
||||
(nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "31.0.8") (sql-null)))
|
||||
(ghost . ,(or (and (alist-ref 'ghost (current-params)) "6.10.0") (sql-null)))))
|
||||
(update-root-domain db
|
||||
(session-user-id)
|
||||
instance-id
|
||||
@@ -774,23 +974,36 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(let ((instance-id (alist-ref "id" (current-params) equal?)))
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(update-user-app-config
|
||||
db
|
||||
(session-user-id)
|
||||
instance-id
|
||||
`((ghost . ((subdomain . ,(alist-ref 'ghost-subdomain (current-params)))))
|
||||
(wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params)))))
|
||||
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params)))
|
||||
(admin-user . ,(alist-ref 'nextcloud-admin-user (current-params)))
|
||||
(admin-password . ,(alist-ref 'nextcloud-admin-password (current-params)))))
|
||||
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
|
||||
(user . ,(alist-ref 'log-viewer-user (current-params)))
|
||||
(password . ,(alist-ref 'log-viewer-password (current-params)))))
|
||||
(all-apps . ((smtp-host . ,(alist-ref 'smtp-host (current-params)))
|
||||
(smtp-port . ,(alist-ref 'smtp-port (current-params)))
|
||||
(smtp-auth-user . ,(alist-ref 'smtp-auth-user (current-params)))
|
||||
(smtp-auth-password . ,(alist-ref 'smtp-auth-password (current-params)))
|
||||
(smtp-from . ,(alist-ref 'smtp-from (current-params)))))))))
|
||||
(let ((config (alist-ref 'config (get-user-app-config db (session-user-id) instance-id))))
|
||||
(update-user-app-config
|
||||
db
|
||||
(session-user-id)
|
||||
instance-id
|
||||
`((ghost . ((subdomain . ,(alist-ref 'ghost-subdomain (current-params)))
|
||||
(postgres-root-password . ,(or (alist-ref 'postgres-root-password
|
||||
(alist-ref 'ghost config eq? '()))
|
||||
(generate-postgres-password)))
|
||||
(postgres-password . ,(or (alist-ref 'postgres-password
|
||||
(alist-ref 'ghost config eq? '()))
|
||||
(generate-postgres-password)))))
|
||||
(wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params)))))
|
||||
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params)))
|
||||
(admin-user . ,(alist-ref 'nextcloud-admin-user (current-params)))
|
||||
(admin-password . ,(alist-ref 'nextcloud-admin-password (current-params)))
|
||||
(postgres-password . ,(or (alist-ref 'postgres-password
|
||||
(alist-ref 'nextcloud config eq? '()))
|
||||
(generate-postgres-password)))
|
||||
(redis-password . ,(or (alist-ref 'redis-password
|
||||
(alist-ref 'nextcloud config eq? '()))
|
||||
(generate-redis-password)))))
|
||||
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
|
||||
(user . ,(alist-ref 'log-viewer-user (current-params)))
|
||||
(password . ,(alist-ref 'log-viewer-password (current-params)))))
|
||||
(all-apps . ((smtp-host . ,(alist-ref 'smtp-host (current-params)))
|
||||
(smtp-port . ,(alist-ref 'smtp-port (current-params)))
|
||||
(smtp-auth-user . ,(alist-ref 'smtp-auth-user (current-params)))
|
||||
(smtp-auth-password . ,(alist-ref 'smtp-auth-password (current-params)))
|
||||
(smtp-from . ,(alist-ref 'smtp-from (current-params))))))))))
|
||||
(redirect (conc "/config/wizard/machine/" instance-id))))
|
||||
|
||||
(get/widgets
|
||||
@@ -815,16 +1028,18 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(get-digital-ocean-regions (alist-ref 'digitalocean-api-token config)))))
|
||||
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2/" instance-id))))))))))
|
||||
|
||||
;; TODO if the region is changed, all of the data is DELETED because the
|
||||
;; volume is deleted and re-created
|
||||
(post "/config/wizard/machine-submit/:id"
|
||||
(let ((instance-id (alist-ref "id" (current-params) equal?)))
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(update-user-service-config
|
||||
db
|
||||
(session-user-id)
|
||||
instance-id
|
||||
`((digitalocean-region . ,(alist-ref 'region (current-params)))))))
|
||||
(redirect (conc "/config/wizard/machine2/" instance-id))))
|
||||
(let ((instance-id (alist-ref "id" (current-params) equal?)))
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(update-user-service-config
|
||||
db
|
||||
(session-user-id)
|
||||
instance-id
|
||||
`((digitalocean-region . ,(alist-ref 'region (current-params)))))))
|
||||
(redirect (conc "/config/wizard/machine2/" instance-id))))
|
||||
|
||||
(get/widgets
|
||||
("/config/wizard/machine2/:id")
|
||||
@@ -902,118 +1117,142 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(VStack
|
||||
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch")))))))))
|
||||
|
||||
;; TODO run restic-init if needed (like the first run or if the backblaze
|
||||
;; config changes
|
||||
;; TODO this can only handle a user deploying one instance at a time!
|
||||
;; the folder used should be the user-id PLUS the instance id
|
||||
;; TODO should this perform a backup and then run the systemctl stop app command first?
|
||||
(post "/config/wizard/review-submit/:id"
|
||||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||||
(results
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
`((selected-apps . ,(map
|
||||
car
|
||||
(filter cdr
|
||||
(get-user-selected-apps db (session-user-id) instance-id))))
|
||||
(app-config . ,(get-user-app-config db (session-user-id) instance-id))
|
||||
(service-config . ,(get-user-service-config db (session-user-id) instance-id))
|
||||
(terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))))))
|
||||
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
|
||||
(app-config (alist-ref 'app-config results))
|
||||
(config (alist-ref 'config app-config))
|
||||
(root-domain (alist-ref 'root-domain app-config))
|
||||
(service-config (alist-ref 'service-config results))
|
||||
(terraform-state (alist-ref 'terraform-state results))
|
||||
(dir (deployment-directory (session-user-id))))
|
||||
(setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
|
||||
(with-output-to-file (string-append dir "/config/apps.config")
|
||||
(lambda ()
|
||||
(map (lambda (e)
|
||||
(write-config-entry (car e) (cdr e)))
|
||||
`(("ROOT_DOMAIN" . ,root-domain)
|
||||
("APP_CONFIGS" . ,(string-intersperse
|
||||
(map (lambda (app)
|
||||
(conc (if (eq? app 'log-viewer) 'dozzle app)
|
||||
","
|
||||
(alist-ref 'subdomain (alist-ref app config))))
|
||||
selected-apps)
|
||||
" "))
|
||||
("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
|
||||
("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config)))
|
||||
("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
|
||||
("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
|
||||
("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
|
||||
("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
|
||||
("NEXTCLOUD_POSTGRES_PASSWORD" . "dbpassword") ;; TODO generate
|
||||
("NEXTCLOUD_REDIS_PASSWORD" . "redispassword") ;; TODO generate
|
||||
("GHOST_DATABASE_ROOT_PASSWORD" . "reallysecurerootpassword") ;; TODO generate
|
||||
("GHOST_DATABASE_PASSWORD" . "ghostpassword") ;; TODO generate
|
||||
("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
|
||||
("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
|
||||
("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
|
||||
("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
|
||||
("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
|
||||
("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
|
||||
("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
|
||||
("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
|
||||
("RESTIC_PASSWORD" . "foodisgood"))))) ;; TODO generate or get from user
|
||||
(with-output-to-file (string-append dir "/config/production.tfvars")
|
||||
(lambda ()
|
||||
(map (lambda (e)
|
||||
(write-config-entry (car e) (cdr e)))
|
||||
`(("server_type" . ,(alist-ref 'digitalocean-size service-config))
|
||||
("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
|
||||
("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
|
||||
("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
|
||||
("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
|
||||
("cluster_name" . "mycluster")
|
||||
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
|
||||
("flatcar_stable_version" . "4459.2.1")))
|
||||
(display "ssh_keys=[\"") (display (with-input-from-file (string-append dir "/config/ssh-keys") read-string)) (print "\"]"))))
|
||||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||||
(user-id (session-user-id))
|
||||
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
|
||||
(dir (deployment-directory user-id)))
|
||||
(thread-start!
|
||||
(lambda ()
|
||||
(change-directory dir)
|
||||
(let ((pid (process-run "make apply > make-out")))
|
||||
(with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
|
||||
(change-directory "../")
|
||||
(let loop ()
|
||||
(thread-sleep! 5)
|
||||
(receive (pid exit-normal status) (process-wait pid #t)
|
||||
(if (= pid 0)
|
||||
(begin (let ((progress (parse-deployment-log
|
||||
(with-input-from-file
|
||||
(string-append (deployment-directory user-id) "/make-out")
|
||||
read-string))))
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(update-deployment-progress db deployment-id progress))))
|
||||
(loop))
|
||||
(let ((progress (parse-deployment-log
|
||||
(with-input-from-file
|
||||
(string-append (deployment-directory user-id) "/make-out")
|
||||
read-string))))
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(update-deployment-progress db deployment-id progress)
|
||||
;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES
|
||||
;; like the random digital ocean error saying the IP can't be
|
||||
;; updated because another operation is in progress.
|
||||
;; it still registers as "success".
|
||||
;; probably need to also write stderr to a file and read/store/parse that?
|
||||
;; Should we parse make-out for string "Apply complete!" ?
|
||||
(update-deployment-status
|
||||
db user-id deployment-id
|
||||
(if exit-normal 'complete 'failed)
|
||||
(with-input-from-file (string-append dir "/make-out") read-string))
|
||||
(update-user-terraform-state db user-id instance-id
|
||||
(with-input-from-file (string-append dir "/terraform.tfstate") read-string)
|
||||
(with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string))))))))))))
|
||||
(redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))
|
||||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||||
(results
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
`((selected-apps . ,(map
|
||||
car
|
||||
(filter cdr
|
||||
(get-user-selected-apps db (session-user-id) instance-id))))
|
||||
(app-config . ,(get-user-app-config db (session-user-id) instance-id))
|
||||
(service-config . ,(get-user-service-config db (session-user-id) instance-id))
|
||||
(terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))
|
||||
(ssh-pub-key . ,(get-instance-ssh-pub-key db (session-user-id) instance-id))
|
||||
(restic-password . ,(get-instance-restic-password db (session-user-id) instance-id))))))
|
||||
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
|
||||
(app-config (alist-ref 'app-config results))
|
||||
(config (alist-ref 'config app-config))
|
||||
(root-domain (alist-ref 'root-domain app-config))
|
||||
(service-config (alist-ref 'service-config results))
|
||||
(terraform-state (alist-ref 'terraform-state results))
|
||||
(ssh-pub-key (alist-ref 'ssh-pub-key results))
|
||||
(restic-password (alist-ref 'restic-password results))
|
||||
(dir (deployment-directory (session-user-id))))
|
||||
(setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
|
||||
(with-output-to-file (string-append dir "/config/apps.config")
|
||||
(lambda ()
|
||||
(map (lambda (e)
|
||||
(write-config-entry (car e) (cdr e)))
|
||||
`(("ROOT_DOMAIN" . ,root-domain)
|
||||
("APP_CONFIGS" . ,(string-intersperse
|
||||
(map (lambda (app)
|
||||
(conc (if (eq? app 'log-viewer) 'dozzle app)
|
||||
","
|
||||
(alist-ref 'subdomain (alist-ref app config))))
|
||||
selected-apps)
|
||||
" "))
|
||||
("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
|
||||
("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config)))
|
||||
("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
|
||||
("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
|
||||
("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
|
||||
("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
|
||||
("NEXTCLOUD_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nextcloud config)))
|
||||
("NEXTCLOUD_REDIS_PASSWORD" . ,(alist-ref 'redis-password (alist-ref 'nextcloud config)))
|
||||
("GHOST_DATABASE_ROOT_PASSWORD" . ,(alist-ref 'postgres-root-password (alist-ref 'ghost config)))
|
||||
("GHOST_DATABASE_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'ghost config)))
|
||||
("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
|
||||
("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
|
||||
("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
|
||||
("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
|
||||
("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
|
||||
("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
|
||||
("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
|
||||
("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
|
||||
("RESTIC_PASSWORD" . ,restic-password)))))
|
||||
(with-output-to-file (string-append dir "/config/production.tfvars")
|
||||
(lambda ()
|
||||
(map (lambda (e)
|
||||
(write-config-entry (car e) (cdr e)))
|
||||
`(("server_type" . ,(alist-ref 'digitalocean-size service-config))
|
||||
("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
|
||||
("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
|
||||
("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
|
||||
("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
|
||||
("cluster_name" . "mycluster")
|
||||
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
|
||||
("flatcar_stable_version" . "4459.2.1")))
|
||||
;; remove the newline that generating the ssh key adds
|
||||
(display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]"))))
|
||||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||||
(user-id (session-user-id))
|
||||
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
|
||||
(dir (deployment-directory user-id)))
|
||||
(thread-start!
|
||||
(lambda ()
|
||||
(change-directory dir)
|
||||
(let ((pid (process-run "make apply > make-out 2>&1")))
|
||||
(with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
|
||||
(change-directory "../")
|
||||
(let loop ()
|
||||
(thread-sleep! 5)
|
||||
(receive (pid exit-normal status) (process-wait pid #t)
|
||||
(if (= pid 0) ;; process is still running
|
||||
(begin (let ((progress (parse-deployment-log
|
||||
(with-input-from-file
|
||||
(string-append (deployment-directory user-id) "/make-out")
|
||||
read-string)))
|
||||
(tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string))
|
||||
(tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(update-deployment-progress db deployment-id progress)
|
||||
(when (file-exists? (string-append dir "/terraform.tfstate"))
|
||||
(update-user-terraform-state db user-id instance-id
|
||||
(if (eof-object? tf-state) "" tf-state)
|
||||
(if (eof-object? tf-state-backup) "" tf-state-backup))))))
|
||||
(loop))
|
||||
(let ((progress (parse-deployment-log
|
||||
(with-input-from-file
|
||||
(string-append (deployment-directory user-id) "/make-out")
|
||||
read-string)))
|
||||
(tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string))
|
||||
(tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(update-deployment-progress db deployment-id progress)
|
||||
;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES
|
||||
;; like the random digital ocean error saying the IP can't be
|
||||
;; updated because another operation is in progress.
|
||||
;; it still registers as "success".
|
||||
;; probably need to also write stderr to a file and read/store/parse that?
|
||||
;; Should we parse make-out for string "Apply complete!" ?
|
||||
(update-deployment-status
|
||||
db user-id deployment-id
|
||||
(if exit-normal 'complete 'failed)
|
||||
(with-input-from-file (string-append dir "/make-out") read-string))
|
||||
(update-user-terraform-state db user-id instance-id
|
||||
(if (eof-object? tf-state) "" tf-state)
|
||||
(if (eof-object? tf-state-backup) "" tf-state-backup))))))))))))
|
||||
(redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))
|
||||
|
||||
(get/widgets
|
||||
("/config/wizard/success/:id")
|
||||
("/config/wizard/success/:id"
|
||||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||||
(res (with-db/transaction
|
||||
(lambda (db)
|
||||
`((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))))))
|
||||
(status (string->symbol (alist-ref 'status res))))
|
||||
(if (or (eq? status 'complete) (eq? status 'failed))
|
||||
'()
|
||||
'((meta (@ (http-equiv "refresh") (content "5")))))))
|
||||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||||
(res (with-db/transaction
|
||||
(lambda (db)
|
||||
@@ -1022,19 +1261,28 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(output (with-input-from-file (string-append (deployment-directory (session-user-id)) "/make-out") read-string))
|
||||
(progress (alist-ref 'progress res))
|
||||
(status (alist-ref 'status res)))
|
||||
`(VStack
|
||||
(h1
|
||||
,(case (string->symbol status)
|
||||
((queued) "Deployment queued")
|
||||
((in-progress) "Deployment in progress")
|
||||
((complete) "Deployment complete!")
|
||||
((failed) "Deployment failed")))
|
||||
(ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
|
||||
(li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
|
||||
(li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress)))
|
||||
(li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
|
||||
(pre ,output)
|
||||
)))
|
||||
`(App
|
||||
(Main-Container
|
||||
(VStack
|
||||
(h1
|
||||
,(case (string->symbol status)
|
||||
((queued) "Deployment queued")
|
||||
((in-progress) "Deployment in progress")
|
||||
((complete) "Deployment complete!")
|
||||
((failed) "Deployment failed")))
|
||||
(ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
|
||||
(li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
|
||||
(li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress)))
|
||||
(li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
|
||||
(div
|
||||
(a (@ (href "/dashboard")) "Dashboard")
|
||||
,@(if (or (eq? (string->symbol status) 'complete) (eq? (string->symbol status) 'failed))
|
||||
'()
|
||||
" (deployment will continue in the background if you leave this page)"))
|
||||
(hr)
|
||||
(pre (@ (style ((overflow-x "scroll"))))
|
||||
,output)
|
||||
)))))
|
||||
|
||||
(get/widgets
|
||||
("/dashboard")
|
||||
@@ -1046,13 +1294,45 @@ h1, h2, h3, h4, h5, h6 {
|
||||
(@ (action "/config/wizard/create-instance")
|
||||
(method POST))
|
||||
(Button "Setup New Instance"))
|
||||
(ul ,@(map (lambda (deployment)
|
||||
`(li (a (@ (href ,(conc "/deployments/" (alist-ref 'id deployment))))
|
||||
,(alist-ref 'root-domain deployment))
|
||||
" - ",(alist-ref 'status deployment)))
|
||||
(ul ,@(map (lambda (instance)
|
||||
(let ((root-domain (alist-ref 'root-domain instance))
|
||||
(config (alist-ref 'config instance)))
|
||||
`(li (VStack
|
||||
(h2 ,root-domain)
|
||||
(HStack
|
||||
"status: " ,(if (equal? (alist-ref 'status instance) "complete")
|
||||
"deployed successfully"
|
||||
(alist-ref 'status instance)))
|
||||
(h3 "Apps")
|
||||
(ul ,@(filter
|
||||
identity
|
||||
(map (lambda (app-map)
|
||||
(let ((app (car app-map))
|
||||
(doc-url (cdr app-map)))
|
||||
(if (or (alist-ref app instance)
|
||||
(eq? app 'log-viewer))
|
||||
`((li (a (@ (href ,doc-url)) ,app)
|
||||
" (v" ,(alist-ref app instance eq? "-") ") "
|
||||
(a (@ (href "https://"
|
||||
,(alist-ref 'subdomain (alist-ref app config))
|
||||
"." ,root-domain))
|
||||
,(alist-ref 'subdomain (alist-ref app config))
|
||||
"." ,root-domain)))
|
||||
#f)))
|
||||
'((wg-easy . "https://wg-easy.github.io/wg-easy/Pre-release/")
|
||||
(nextcloud . "https://nextcloud.com/support/")
|
||||
(ghost . "https://nextcloud.com/support/")
|
||||
(log-viewer . "https://nextcloud.com/support/")))))
|
||||
(h3 "Actions")
|
||||
(ul (li (a (@ (href "/config/wizard/services/"
|
||||
,(alist-ref 'instance-id instance)))
|
||||
"Modify Setup"))
|
||||
(li "Upgrade Now (pending automatic upgrades scheduled for: )")
|
||||
(li "Manage Backups")
|
||||
(li "Destroy"))))))
|
||||
(with-db/transaction
|
||||
(lambda (db)
|
||||
(get-user-deployments db (session-user-id))))))))))
|
||||
(get-dashboard db (session-user-id))))))))))
|
||||
|
||||
(schematra-install)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user