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

Improving theme, cleaning UI, adding validations.

Browse Source
This commit is contained in:
Thomas Hintz
2026-07-20 21:41:47 -07:00
parent 8173b798a8
commit 1a60f94b13
1 changed files with 355 additions and 203 deletions
Download Patch File Download Diff File Expand all files Collapse all files

558
src/nassella.scm
View File

@@ -132,12 +132,12 @@ h1, h2, h3, h4, h5, h6 {
(0 . "#000000")))
(primary ((default . "#983490")
(rgb . (152 52 144))
(contrast . (color contrast dark))
(contrast . (color base))
(tint . "#bd7ab4")
(shade . "#64275e")
(tone . "#92528b")
(background . "#dab4d5")
(background-contrast . "#2B114B")))
(background . "#EBF6D3")
(background-contrast . "#983490")))
(secondary ((default . "#41be4b")
(rgb . (65 190 75))
(contrast . (color contrast light))
@@ -145,7 +145,8 @@ h1, h2, h3, h4, h5, h6 {
(shade . "#317b34")
(tone . "#61aa60")))
(base ((light . (color gamma 800))
(dark . (color gamma 150))))
(dark . (color gamma 150))
(default . "#DAE7BD")))
(accent ((default . " #44b7c0")
(contrast . (color contrast light))
(tint . " #8dcfd5")
@@ -475,7 +476,9 @@ h1, h2, h3, h4, h5, h6 {
steps (list-tabulate num-steps values)))))
(define-widget (Body () contents)
`(body (@ (data-name "Body") (style ((background ,($ 'color.secondary.tint)) (font-family ,($ 'font.family.label)))))
`(body (@ (data-name "Body") (style ((background ,($ 'color.base))
(font-family ,($ 'font.family.label))
(color ,($ 'color.primary.background-contrast)))))
,@contents))
(define-widget (App () contents)
@@ -483,10 +486,15 @@ h1, h2, h3, h4, h5, h6 {
(define-widget (Configuration-Wizard ((step "Services")) contents)
`(VStack
(@ (style ((background ,($ 'color.primary.background))
(color ,($ 'color.primary.background-contrast))
(border-radius ,($ 'radius.large))
(padding ,($ 'gap.gutter)))))
(@ (style ((border-top-width ,($ 'space.12))
(border-top-color ,($ 'color.primary.background-contrast))
(border-top-style "solid")
(padding-top ,($ 'space.50))
(border-bottom-width ,($ 'space.12))
(border-bottom-color ,($ 'color.primary.background-contrast))
(border-bottom-style "solid")
(padding-bottom ,($ 'space.50)))))
(h2 "Nassella - Instance Setup Wizard")
(header
(Steps (@ (steps ("Services" "Apps" "Machine" "Review")) (current ,step))))
(main
@@ -495,9 +503,7 @@ h1, h2, h3, h4, h5, h6 {
(define-widget (Main-Container () contents)
`(VStack
(@ (style ((background ,($ 'color.primary.background))
(color ,($ 'color.primary.background-contrast))
(border-radius ,($ 'radius.large))
(@ (style ((color ,($ 'color.primary.background-contrast))
(padding ,($ 'gap.gutter)))))
;; (header
;; (Steps (@ (steps ("Services" "Apps" "Machine" "Review")) (current ,step))))
@@ -516,12 +522,13 @@ h1, h2, h3, h4, h5, h6 {
,@contents))
(define-widget (Field ((name "") (id #f) (label '()) (element 'input) (type "text") (value #f) (checked #f)
(input-style '()) (disabled #f))
(input-style '()) (disabled #f) (required #f))
contents)
(let ((label `(label (@ (for ,(or id name)) (style ((font-weight "bold")))) ,@label))
(input `(,element (@ (type ,type) (name ,name) (id ,(or id name)) ,@(if value `((value ,value)) '())
,@(if checked `((checked)) '()) ,@(if input-style (list input-style) '())
,@(if disabled `((disabled)) '()))
,@(if disabled `((disabled)) '())
,@(if required `((required)) '()))
,@contents)))
`(,(if (equal? type "checkbox") 'HStack 'VStack)
(@ (gap ,($ 'gap.associated)))
@@ -563,6 +570,36 @@ h1, h2, h3, h4, h5, h6 {
"Back")
(Button (@ (enabled ,submit-enabled)) ,submit-button)))
(define (status-pill-type->color type)
(case type
((info) ($ 'color.util.info))
((safe) ($ 'color.util.safe))
((warning) ($ 'color.util.warning))
((alert) ($ 'color.util.alert))
(else (error (conc "unknown pill type: " type)))))
(define-widget (Status-Pill ((type 'unknown) (style '())) contents) ;; type can be info, safe, warning, alert
`(div (@ (style ((border-radius ,($ 'radius.pill))
(background ,(status-pill-type->color type))
(padding ,($ 'space.25) ,($ 'space.100))
(width "fit-content")
,@style)))
,@contents))
(define-widget (Deployment-Status-Pill ((status 'unknown)))
`(Status-Pill
(@ (type ,(case status
((queued) 'info)
((in-progress) 'warning)
((complete) 'safe)
((failed) 'alert)))
(style ((font-size ,($ 'font.size.s)))))
,(case status
((queued) "Queued")
((in-progress) "In Progress")
((complete) "Complete")
((failed) "Failed"))))
;; Parsing JSON arrays as lists instead of vectors
(define array-as-list-parser
(cons 'array (lambda (x) x)))
@@ -842,13 +879,6 @@ h1, h2, h3, h4, h5, h6 {
""))+
(print "\""))
(define (progress-status->text status)
(case status
((queued) "queued")
((in-progress) "in progress")
((complete) "complete")
((failed) "failed")))
;; (with-db/transaction
;; (lambda (db)
;; (update-instance-ssh-pub-key db 1 22 "")))
@@ -1001,6 +1031,32 @@ chmod -R 777 /opt/keys")))
(lambda ()
(delete-file password-path)))))
;; verify subdomains. Not the full check because excludes root domain
;; but should help the user in all but extreme cases
;; based on: https://stackoverflow.com/questions/7930751/regexp-for-subdomain
;; We don't expect the user to include the final "dot" so we add it just
;; to validate the subdomain
(define (valid-subdomain? str)
(if (string? str)
(irregex-match? (irregex "(?:[a-z0-9](?:[a-z0-9-]{0,61}[a-z0-9])?\\.)+") (string-append str "."))
#f))
;; based on the docs here https://docs.nextcloud.com/server/stable/admin_manual/configuration_user/user_configuration.html
;; guessed at the length
(define (valid-nextcloud-user? v)
(if (string? v)
(irregex-match? (irregex "[a-zA-Z0-9-_\\. @]{1,64}") v)
#f))
;; Seems to be few restrictions other than a default that it should
;; be at least 10 chars.
;; TODO does our config file have limitations though?
(define (valid-nextcloud-password? v)
(if (string? v)
(> (string-length v) 9)
#f))
;; TODO is this actually needed?
(single-headers (cons 'X-Nassella-Signature (single-headers)))
(header-parsers (cons `(X-Nassella-Signature . ,(single identity)) (header-parsers)))
@@ -1211,10 +1267,10 @@ chmod -R 777 /opt/keys")))
`((Field (@ (name "nassella") (type "checkbox") (label ("Nassella")) (checked ,(member 'nassella (alist-ref 'selected-apps results)))))))
(else
'()))
(Field (@ (name "wordpress") (type "checkbox") (label ("wordpress")) (checked ,(member 'wordpress (alist-ref 'selected-apps results)))))
(Field (@ (name "lldap") (type "checkbox") (label ("lldap")) (checked ,(member 'lldap (alist-ref 'selected-apps results)))))
(Field (@ (name "authelia") (type "checkbox") (label ("authelia")) (checked ,(member 'authelia (alist-ref 'selected-apps results)))))
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
(Field (@ (name "wordpress") (type "checkbox") (label ("Wordpress")) (checked ,(member 'wordpress (alist-ref 'selected-apps results)))))
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled")))
(Field (@ (name "lldap") (type "checkbox") (label ("Admin LLDAP")) (checked #t) (disabled "disabled")))
(Field (@ (name "authelia") (type "checkbox") (label ("Admin Authelia")) (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))))))))))
@@ -1233,8 +1289,8 @@ chmod -R 777 /opt/keys")))
(ghost . ,(or (and (alist-ref 'ghost (current-params)) "6") #f))
(nassella . ,(or (and (alist-ref 'nassella (current-params)) "b0.0.1") #f))
(wordpress . ,(or (and (alist-ref 'wordpress (current-params)) "8.4") #f))
(lldap . ,(or (and (alist-ref 'lldap (current-params)) "0.6.3") #f))
(authelia . ,(or (and (alist-ref 'authelia (current-params)) "4") #f))
(lldap . "0.6.3")
(authelia . "4")
(instance-control . "b0.0.1")
(log-viewer . "20"))))
(update-root-domain db
@@ -1265,173 +1321,219 @@ chmod -R 777 /opt/keys")))
,@(if (member 'ghost selected-apps)
`((Fieldset
(@ (title "Ghost"))
(Field (@ (name "ghost-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'ghost app-config eq? '()) eq? "ghost"))))))
(Field (@ (name "ghost-subdomain") (label ("Subdomain")) (required #t)
(value ,(alist-ref 'subdomain (alist-ref 'ghost app-config eq? '()) eq? "ghost"))))))
'())
,@(if (member 'wg-easy selected-apps)
`((Fieldset
(@ (title "WG-Easy"))
(Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'wg-easy app-config eq? '()) eq? "wg-easy"))))))
(Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (required #t)
(value ,(alist-ref 'subdomain (alist-ref 'wg-easy app-config eq? '()) eq? "wg-easy"))))))
'())
,@(if (member 'nextcloud selected-apps)
`((Fieldset
(@ (title "NextCloud"))
(Field (@ (name "nextcloud-subdomain") (label ("Subdomain"))
(Field (@ (name "nextcloud-subdomain") (label ("Subdomain")) (required #t)
(value ,(alist-ref 'subdomain (alist-ref 'nextcloud app-config eq? '()) eq? "nextcloud"))))
(Field (@ (name "nextcloud-admin-user") (label ("Admin Username"))
(Field (@ (name "nextcloud-admin-user") (label ("Admin Username")) (required #t)
(value ,(alist-ref 'admin-user (alist-ref 'nextcloud app-config eq? '()) eq? "admin"))))
(Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password")
(Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password") (required #t)
(value ,(alist-ref 'admin-password (alist-ref 'nextcloud app-config eq? '()) eq? ""))))))
'())
,@(if (member 'nassella selected-apps)
`((Fieldset
(@ (title "Nassella"))
(Field (@ (name "nassella-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'nassella app-config eq? '()) eq? "app"))))
(Field (@ (name "nassella-lldap-subdomain") (label ("LLDAP Subdomain"))
(Field (@ (name "nassella-subdomain") (label ("Subdomain")) (required #t)
(value ,(alist-ref 'subdomain (alist-ref 'nassella app-config eq? '()) eq? "app"))))
(Field (@ (name "nassella-lldap-subdomain") (label ("LLDAP Subdomain")) (required #t)
(value ,(alist-ref 'lldap-subdomain (alist-ref 'nassella app-config eq? '()) eq? "lldap"))))
(Field (@ (name "nassella-lldap-admin-password") (label ("Admin Password")) (type "password")
(Field (@ (name "nassella-lldap-admin-password") (label ("Admin Password")) (type "password") (required #t)
(value ,(alist-ref 'lldap-admin-password (alist-ref 'nassella app-config eq? '()) eq? ""))))
(Field (@ (name "nassella-stripe-api-key") (label ("Stripe API Key")) (type "password")
(Field (@ (name "nassella-stripe-api-key") (label ("Stripe API Key")) (type "password") (required #t)
(value ,(alist-ref 'stripe-api-key (alist-ref 'nassella app-config eq? '()) eq? ""))))))
'())
,@(if (member 'wordpress selected-apps)
`((Fieldset
(@ (title "Wordpress"))
(Field (@ (name "wordpress-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'wordpress app-config eq? '()) eq? "wordpress"))))))
(Field (@ (name "wordpress-subdomain") (label ("Subdomain")) (required #t)
(value ,(alist-ref 'subdomain (alist-ref 'wordpress app-config eq? '()) eq? "wordpress"))))))
'())
,@(if (member 'lldap selected-apps)
`((Fieldset
(@ (title "LLDAP"))
(Field (@ (name "lldap-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'lldap app-config eq? '()) eq? "lldap"))))
(Field (@ (name "lldap-user-email") (label ("Admin Email Address")) (type "email")
(@ (title "Admin LLDAP"))
(Field (@ (name "lldap-subdomain") (label ("Subdomain")) (required #t)
(value ,(alist-ref 'subdomain (alist-ref 'lldap app-config eq? '()) eq? "lldap"))))
(Field (@ (name "lldap-user-email") (label ("Admin Email Address")) (type "email") (required #t)
(value ,(alist-ref 'user-email (alist-ref 'lldap app-config eq? '()) eq? ""))))
(Field (@ (name "lldap-admin-password") (label ("Admin Password")) (type "password")
(Field (@ (name "lldap-admin-password") (label ("Admin Password")) (type "password") (required #t)
(value ,(alist-ref 'admin-password (alist-ref 'lldap app-config eq? '()) eq? ""))))))
'())
,@(if (member 'authelia selected-apps)
`((Fieldset
(@ (title "Authelia"))
(Field (@ (name "authelia-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'authelia app-config eq? '()) eq? "authelia"))))))
(@ (title "Admin Authelia"))
(Field (@ (name "authelia-subdomain") (label ("Subdomain")) (required #t)
(value ,(alist-ref 'subdomain (alist-ref 'authelia app-config eq? '()) eq? "authelia"))))))
'())
(Fieldset
(@ (title "Log Viewer"))
(Field (@ (name "log-viewer-subdomain") (label ("Subdomain"))
(Field (@ (name "log-viewer-subdomain") (label ("Subdomain")) (required #t)
(value ,(alist-ref 'subdomain (alist-ref 'log-viewer app-config eq? '()) eq? "logs"))))
(Field (@ (name "log-viewer-user") (label ("Username"))
(value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
(Field (@ (name "log-viewer-password") (label ("Password")) (type "password")
(value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? "")))))
;; (Field (@ (name "log-viewer-user") (label ("Username")) (required #t)
;; (value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
;; (Field (@ (name "log-viewer-password") (label ("Password")) (type "password") (required #t)
;; (value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
)
,@(if (or (member 'nextcloud selected-apps) (member 'ghost selected-apps) (member 'nassella selected-apps) (member 'authelia selected-apps))
`((Fieldset
(@ (title "All Apps - Email - SMTP"))
(Field (@ (name "smtp-host") (label ("Host"))
(Field (@ (name "smtp-host") (label ("Host")) (required #t)
(value ,(alist-ref 'smtp-host (alist-ref 'all-apps app-config eq? '()) eq? ""))))
(Field (@ (name "smtp-port") (label ("Port"))
(Field (@ (name "smtp-port") (label ("Port")) (required #t)
(value ,(alist-ref 'smtp-port (alist-ref 'all-apps app-config eq? '()) eq? ""))))
(Field (@ (name "smtp-auth-user") (label ("Auth User"))
(Field (@ (name "smtp-auth-user") (label ("Auth User")) (required #t)
(value ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps app-config eq? '()) eq? ""))))
(Field (@ (name "smtp-auth-password") (label ("Auth Password")) (type "password")
(Field (@ (name "smtp-auth-password") (label ("Auth Password")) (type "password") (required #t)
(value ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps app-config eq? '()) eq? ""))))
(Field (@ (name "smtp-from") (label ("From"))
(Field (@ (name "smtp-from") (label ("From")) (required #t)
(value ,(alist-ref 'smtp-from (alist-ref 'all-apps app-config eq? '()) eq? "My Name <no-reply@example.org>"))))))
'())
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps/" instance-id))))))))))
(post "/config/wizard/apps2-submit/:id"
(let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction
(lambda (db)
(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)))))
(nassella . ((subdomain . ,(alist-ref 'nassella-subdomain (current-params)))
(postgres-password . ,(or (alist-ref 'postgres-password
(alist-ref 'nassella config eq? '()))
(generate-postgres-password)))
(authelia-postgres-password . ,(or (alist-ref 'authelia-postgres-password
(alist-ref 'nassella config eq? '()))
(generate-postgres-password)))
(lldap-postgres-password . ,(or (alist-ref 'lldap-postgres-password
(alist-ref 'nassella config eq? '()))
(generate-postgres-password)))
(lldap-jwt-secret . ,(or (alist-ref 'lldap-jwt-secret
(alist-ref 'nassella config eq? '()))
(generate-jwt-secret)))
(lldap-key-seed . ,(or (alist-ref 'lldap-key-seed
(alist-ref 'nassella config eq? '()))
(generate-key-seed)))
(lldap-subdomain . ,(alist-ref 'nassella-lldap-subdomain (current-params)))
(lldap-admin-password . ,(alist-ref 'nassella-lldap-admin-password (current-params)))
(stripe-api-key . ,(alist-ref 'nassella-stripe-api-key (current-params)))
(authelia-jwt-secret . ,(or (alist-ref 'authelia-jwt-secret
(alist-ref 'nassella config eq? '()))
(generate-jwt-secret)))
(authelia-key-seed . ,(or (alist-ref 'authelia-key-seed
(alist-ref 'nassella config eq? '()))
(generate-authelia-key-seed)))))
(wordpress . ((subdomain . ,(alist-ref 'wordpress-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'wordpress config eq? '()))
(generate-postgres-password)))
(db-root-password . ,(or (alist-ref 'db-root-password
(alist-ref 'wordpress config eq? '()))
(generate-postgres-password)))))
(lldap . ((subdomain . ,(alist-ref 'lldap-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'lldap config eq? '()))
(generate-postgres-password)))
(jwt-secret . ,(or (alist-ref 'jwt-secret
(alist-ref 'lldap config eq? '()))
(generate-jwt-secret)))
(key-seed . ,(or (alist-ref 'key-seed
(alist-ref 'lldap config eq? '()))
(generate-key-seed)))
(admin-password . ,(alist-ref 'lldap-admin-password (current-params)))
(user-email . ,(alist-ref 'lldap-user-email (current-params)))))
(authelia . ((subdomain . ,(alist-ref 'authelia-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'authelia config eq? '()))
(generate-postgres-password)))
(jwt-secret . ,(or (alist-ref 'jwt-secret
(alist-ref 'authelia config eq? '()))
(generate-jwt-secret)))
(session-secret . ,(or (alist-ref 'session-secret
(alist-ref 'authelia config eq? '()))
(generate-authelia-key-seed)))
(encryption-key . ,(or (alist-ref 'encryption-key
(alist-ref 'authelia config eq? '()))
(generate-authelia-key-seed)))))
(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)))))
(instance-control . ((subdomain . "nassella-instance-control")
(webhooks-secret . ,(or (alist-ref 'webhooks-secret
(alist-ref 'instance-control config eq? '()))
(generate-jwt-secret))))))))))
(redirect (conc "/config/wizard/machine/" instance-id))))
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(redirect-to
(with-db/transaction
(lambda (db)
(let* ((config (alist-ref 'config (get-user-app-config db (session-user-id) instance-id)))
(selected-apps (map
car
(filter cdr
(get-user-selected-apps db (session-user-id) instance-id))))
(rules
`((nextcloud-subdomain . (nextcloud required ,valid-subdomain? "nextcloud-invalid-subdomain"))
(nextcloud-admin-user . (nextcloud required ,valid-nextcloud-user? "nextcloud-admin-user"))
(nextcloud-admin-password . (nextcloud required ,valid-nextcloud-password? "nextcloud-admin-password"))
(ghost-subdomain . (ghost required ,valid-subdomain? "ghost-invalid-subdomain"))
(wg-easy-subdomain . (wg-easy required ,valid-subdomain? "wg-easy-invalid-subdomain"))
(nassella-subdomain . (nassella required ,valid-subdomain? "nassella-invalid-subdomain"))
(nassella-lldap-subdomain . (nassella required ,valid-subdomain? "nassella-lldap-invalid-subdomain"))
;; lldap does not have restrictions so just use the same as nextcloud for now
(nassella-lldap-admin-password . (nassella required ,valid-nextcloud-password? "nassella-lldap-admin-password"))
(wordpress-subdomain . (wordpress required ,valid-subdomain? "wordpress-invalid-subdomain"))))
(errs (filter
identity
(map (lambda (rule)
(let* ((param (car rule))
(ruleset (cdr rule))
(app (first ruleset))
(required (eq? (second ruleset) 'required))
(proc (third ruleset))
(error-key (fourth ruleset))
(value (alist-ref param (current-params))))
(if (and (member app selected-apps) (not (proc value))) ;; if user selected app and we fail validation proc
(if required
error-key
(if (or (equal? value #f) (and (string? value) (string=? value ""))) ;; if optional and empty
#f
error-key))
#f)))
rules))))
(if (> (length errs) 0)
(string-append "/config/wizard/apps2/" instance-id "?" (string-join errs "&"))
(begin
(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)))))
(nassella . ((subdomain . ,(alist-ref 'nassella-subdomain (current-params)))
(postgres-password . ,(or (alist-ref 'postgres-password
(alist-ref 'nassella config eq? '()))
(generate-postgres-password)))
(authelia-postgres-password . ,(or (alist-ref 'authelia-postgres-password
(alist-ref 'nassella config eq? '()))
(generate-postgres-password)))
(lldap-postgres-password . ,(or (alist-ref 'lldap-postgres-password
(alist-ref 'nassella config eq? '()))
(generate-postgres-password)))
(lldap-jwt-secret . ,(or (alist-ref 'lldap-jwt-secret
(alist-ref 'nassella config eq? '()))
(generate-jwt-secret)))
(lldap-key-seed . ,(or (alist-ref 'lldap-key-seed
(alist-ref 'nassella config eq? '()))
(generate-key-seed)))
(lldap-subdomain . ,(alist-ref 'nassella-lldap-subdomain (current-params)))
(lldap-admin-password . ,(alist-ref 'nassella-lldap-admin-password (current-params)))
(stripe-api-key . ,(alist-ref 'nassella-stripe-api-key (current-params)))
(authelia-jwt-secret . ,(or (alist-ref 'authelia-jwt-secret
(alist-ref 'nassella config eq? '()))
(generate-jwt-secret)))
(authelia-key-seed . ,(or (alist-ref 'authelia-key-seed
(alist-ref 'nassella config eq? '()))
(generate-authelia-key-seed)))))
(wordpress . ((subdomain . ,(alist-ref 'wordpress-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'wordpress config eq? '()))
(generate-postgres-password)))
(db-root-password . ,(or (alist-ref 'db-root-password
(alist-ref 'wordpress config eq? '()))
(generate-postgres-password)))))
(lldap . ((subdomain . ,(alist-ref 'lldap-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'lldap config eq? '()))
(generate-postgres-password)))
(jwt-secret . ,(or (alist-ref 'jwt-secret
(alist-ref 'lldap config eq? '()))
(generate-jwt-secret)))
(key-seed . ,(or (alist-ref 'key-seed
(alist-ref 'lldap config eq? '()))
(generate-key-seed)))
(admin-password . ,(alist-ref 'lldap-admin-password (current-params)))
(user-email . ,(alist-ref 'lldap-user-email (current-params)))))
(authelia . ((subdomain . ,(alist-ref 'authelia-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'authelia config eq? '()))
(generate-postgres-password)))
(jwt-secret . ,(or (alist-ref 'jwt-secret
(alist-ref 'authelia config eq? '()))
(generate-jwt-secret)))
(session-secret . ,(or (alist-ref 'session-secret
(alist-ref 'authelia config eq? '()))
(generate-authelia-key-seed)))
(encryption-key . ,(or (alist-ref 'encryption-key
(alist-ref 'authelia config eq? '()))
(generate-authelia-key-seed)))))
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
(user . "unused") ;; TODO can we remove?
(password . "unused"))) ;; TODO can we remove?
(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)))))
(instance-control . ((subdomain . "nassella-instance-control")
(webhooks-secret . ,(or (alist-ref 'webhooks-secret
(alist-ref 'instance-control config eq? '()))
(generate-jwt-secret)))))))
(conc "/config/wizard/machine/" instance-id) ;; redirect-to
)))))))
(redirect redirect-to)))
(get/widgets
("/config/wizard/machine/:id")
@@ -1539,7 +1641,11 @@ chmod -R 777 /opt/keys")))
,(alist-ref 'subdomain (alist-ref app config))
"."
,root-domain))
selected-apps))
(filter (lambda (app)
(case app
((instance-control) #f)
(else #t)))
selected-apps)))
(h2 "Machine")
(ul (li "Region: " ,(alist-ref 'digitalocean-region service-config))
(li "Size: " ,(alist-ref 'digitalocean-size service-config)))
@@ -1773,73 +1879,119 @@ chmod -R 777 /opt/keys")))
`(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 "perform backup: " ,(progress-status->text (alist-ref 'instance-backup progress)))
(li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
(li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
(li "application volume disconnect: " ,(progress-status->text (alist-ref 'volume-destroy progress)))
(li "instance create: " ,(progress-status->text (alist-ref 'machine-create progress)))
(li "instance mapped ip disconnect: " ,(progress-status->text (alist-ref 'ip-destroy progress)))
(li "instance mapped ip connect: " ,(progress-status->text (alist-ref 'ip-create progress)))
(li "application volume connect: " ,(progress-status->text (alist-ref 'volume-create progress)))
(li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
(div
(a (@ (href "/dashboard")) "Dashboard")
(h1 "Nassella - Deployment Process")
(HStack (@ (style ((align-items "center"))))
"Overall: " (Status-Pill
(@ (type ,(case (string->symbol status)
((queued) 'info)
((in-progress) 'warning)
((complete) 'safe)
((failed) 'alert))))
,(case (string->symbol status)
((queued) "Queued")
((in-progress) "In Progress")
((complete) "Complete!")
((failed) "Failed"))))
(ul ,@(map (lambda (x)
`(li (HStack (@ (style ((align-items "center")
(margin-bottom ,($ 'gap.gutter)))))
(Deployment-Status-Pill (@ (status ,(alist-ref (car x) progress))))
,(cdr x))))
'((instance-backup . "Backup Instance")
(generate-configs . "Generate Custom Image")
(custom-image . "Upload Flatcar Image")
(volume-destroy . "App Volume Disconnect")
(machine-create . "Create Instance")
(ip-destroy . "Instance Mapped IP Disconnect")
(ip-create . "Instance Mapped IP Connect")
(volume-create . "App Volume Connect")
(machine-destroy . "Cleanup Previous Instance"))))
(form
(@ (action "/dashboard") (method GET))
,@(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)
)))))
'(" (deployment will continue in the background if you leave this page)"))
(Form-Nav (@ (back-to ,(conc "/config/wizard/review/" instance-id)) (submit-button "Finish"))))
,@(if (alist-ref 'log (current-params))
`((hr)
(pre (@ (style ((overflow-x "scroll"))))
,output))
'()))))))
(define (instance-status->display status)
(case (string->symbol status)
((queued) "Queued")
((in-progress) "Deploying...")
((complete) "Deployed")
((failed) "Failed")
(else "Unknown")))
(define (instance-status->pill-type status)
(case (string->symbol status)
((queued) 'info)
((in-progress 'warning))
((complete) 'safe)
((failed) 'alert)
(else 'alert)))
(get/widgets
("/dashboard")
`(App
(Main-Container
(main
(h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Instances")
(VStack
(@ (element main))
(h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Nassella - Instances")
(form
(@ (action "/config/wizard/create-instance")
(method POST))
(Button "Setup New Instance"))
(ul ,@(map (lambda (instance)
(ul (@ (style ((list-style "none")
(padding-left "0"))))
,@(map (lambda (instance)
(let ((root-domain (alist-ref 'root-domain instance))
(config (alist-ref 'config instance)))
`(li (VStack
(h2 ,root-domain)
(HStack
"status: " ,(if (equal? (alist-ref 'status instance) "complete")
"deployed successfully"
(alist-ref 'status instance)))
(h3 "Apps")
(ul ,@(map (lambda (app-info)
(let ((app (alist-ref 'app-name app-info)))
`((li (a (@ (href "#")) ,app) ;; TODO documentation URL
" (v" ,(alist-ref 'installed-version app-info) ") "
(a (@ (href "https://"
,(alist-ref 'subdomain (alist-ref app config))
"." ,root-domain))
,(alist-ref 'subdomain (alist-ref app config))
"." ,root-domain)))))
(or (alist-ref 'apps instance) ;; TODO this really should not happen maybe?
'())))
(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 (a (@ (href "/backups/" ,(alist-ref 'instance-id instance)))
"Manage Backups"))
(li (a (@ (href "/destroy/" ,(alist-ref 'instance-id instance)))
"Destroy - deletes data and configuration (confirmation required)"))
(li (a (@ (href "/reset/" ,(alist-ref 'instance-id instance)))
"Reset - deletes data (confirmation required)")))))))
`(li
(VStack
(@ (style ((background "rgba(0,0,0,0.1)")
(border-radius ,($ 'radius.medium))
(padding ,($ 'space.75))
(margin-bottom ,($ 'space.100)))))
(VStack
(h2 ,root-domain)
(Status-Pill (@ (type ,(instance-status->pill-type (alist-ref 'status instance))))
,(instance-status->display (alist-ref 'status instance))))
(h3 "Apps")
(ul ,@(map (lambda (app-info)
(let ((app (alist-ref 'app-name app-info)))
`((li (a (@ (href "#") (style ((color ,($ 'color.primary.background-contrast))))) ,app) ;; TODO documentation URL
" (v" ,(alist-ref 'installed-version app-info) ") "
(a (@ (href "https://"
,(alist-ref 'subdomain (alist-ref app config))
"." ,root-domain)
(style ((color ,($ 'color.primary.background-contrast)))))
,(alist-ref 'subdomain (alist-ref app config))
"." ,root-domain)))))
(or (filter (lambda (app-info)
(case (alist-ref 'app-name app-info)
((instance-control lldap authelia) #f)
(else #t)))
(alist-ref 'apps instance))
'())))
(h3 "Actions")
(ul (li (a (@ (href "/config/wizard/services/"
,(alist-ref 'instance-id instance))
(style ((color ,($ 'color.primary.background-contrast)))))
"Modify Setup"))
;; (li "Upgrade Now (pending automatic upgrades scheduled for: )")
(li (a (@ (href "/backups/" ,(alist-ref 'instance-id instance))
(style ((color ,($ 'color.primary.background-contrast)))))
"Manage Backups"))
(li (a (@ (href "/destroy/" ,(alist-ref 'instance-id instance))
(style ((color ,($ 'color.primary.background-contrast)))))
"Destroy - deletes data and configuration (confirmation required)"))
(li (a (@ (href "/reset/" ,(alist-ref 'instance-id instance))
(style ((color ,($ 'color.primary.background-contrast)))))
"Reset - deletes data (confirmation required)")))))))
(with-db/transaction
(lambda (db)
(get-dashboard db (session-user-id))))))))))