nassella/app
1
0
Fork 0
Code Issues 15 Pull Requests Packages Projects 1 Releases Wiki Activity
Files
24b9477f24f0f01ed58309ebf00388c4e24d62d3
app/src/nassella.scm

1719 lines
88 KiB
Scheme
Raw Normal View History

Improving docker setup & terraform init.
2026-02-21 08:39:32 -08:00
;; (load "db")
;; (load "mocks")
(include "db")
(include "mocks")
Postgres db integration.
2025-11-10 13:13:59 -08:00
(import (chicken string)
(chicken port)
(chicken io)
(chicken pretty-print)
(chicken process)
(chicken process-context)
Improving deployment process.
2025-11-12 05:42:25 -08:00
(chicken irregex)
Properly manage deploys via unique folders and db.
2025-11-12 07:31:23 -08:00
(chicken file)
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(chicken condition)
Postgres db integration.
2025-11-10 13:13:59 -08:00
(rename srfi-1 (delete srfi1:delete))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
srfi-13
Improving deployment process.
2025-11-12 05:42:25 -08:00
srfi-18
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
srfi-158
srfi-194
Postgres db integration.
2025-11-10 13:13:59 -08:00
html-widgets
sxml-transforms
Adding tests.
2025-11-30 11:36:19 -08:00
schematra
Working dockerfile.
2026-02-20 10:58:57 -08:00
schematra.body-parser
Adding web app.
2025-10-08 05:53:38 -07:00
uri-common
http-client
medea
intarweb
Postgres db integration.
2025-11-10 13:13:59 -08:00
nassella-db
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
sql-null
Working nassella running on nassella!!
2026-02-23 09:09:58 -08:00
openssl
spiffy)
Adding web app.
2025-10-08 05:53:38 -07:00
Adding tests.
2025-11-30 11:36:19 -08:00
(define app (schematra/make-app))
(with-schematra-app app
(lambda ()
(use-middleware! (body-parser-middleware))))
Adding web app.
2025-10-08 05:53:38 -07:00
(define *global-css-reset*
"/*
Josh's Custom CSS Reset as released into the PUBLIC DOMAIN
https://www.joshwcomeau.com/css/custom-css-reset/
*/
*, *::before, *::after {
box-sizing: border-box;
}
* {
margin: 0;
}
@media (prefers-reduced-motion: no-preference) {
html {
interpolate-size: allow-keywords;
}
}
body {
line-height: 1.5;
-webkit-font-smoothing: antialiased;
}
img, picture, video, canvas, svg {
display: block;
max-width: 100%;
}
input, button, textarea, select {
font: inherit;
}
p, h1, h2, h3, h4, h5, h6 {
overflow-wrap: break-word;
}
p {
text-wrap: pretty;
}
h1, h2, h3, h4, h5, h6 {
text-wrap: balance;
}")
(define *style-tokens*
`((color ((gamma ((950 . "#ffffff")
(900 . "#f2f2f2")
(850 . "#e4e4e4")
(800 . "#d7d7d7")
(750 . "#c9c9c9")
(700 . "#bcbcbc")
(650 . "#aeaeae")
(600 . "#a1a1a1")
(550 . "#949494")
(500 . "#868686")
(450 . "#797979")
(400 . "#6b6b6b")
(350 . "#5e5e5e")
(300 . "#515151")
(250 . "#434343")
(200 . "#363636")
(150 . "#282828")
(100 . "#1b1b1b")
(50 . "#0d0d0d")
(0 . "#000000")))
(primary ((default . "#983490")
(rgb . (152 52 144))
(contrast . (color contrast dark))
(tint . "#bd7ab4")
(shade . "#64275e")
(tone . "#92528b")
(background . "#dab4d5")
(background-contrast . "#2B114B")))
(secondary ((default . "#41be4b")
(rgb . (65 190 75))
(contrast . (color contrast light))
(tint . "#8bd587")
(shade . "#317b34")
(tone . "#61aa60")))
(base ((light . (color gamma 800))
(dark . (color gamma 150))))
(accent ((default . " #44b7c0")
(contrast . (color contrast light))
(tint . " #8dcfd5")
(shade . " #33767b")
(tone . " #63a5aa")))
(util ((info ((default . " #4e87e9")
(contrast . (color contrast light))
(tint . " #93adf1")
(shade . " #395895")
(tone . " #6984c5")))
(safe ((default . " #58df31")
(contrast . (color contrast light))
(tint . " #9beb7e")
(shade . " #3f8f27")
(tone . " #70bf56")))
(warning ((default . " #e6af5c")
(contrast . (color contrast light))
(tint . " #f2c992")
(shade . " #93713e")
(tone . " #c59f6a")))
(alert ((default . " #e7385e")
(contrast . (color contrast light))
(tint . " #f78590")
(shade . " #952c3f")
(tone . " #c95b69")))))
(contrast ((dark . (color gamma 900))
(light . (color gamma 50))))
(text ((strong . (color gamma 50))
(regular . (color gamma 150))
(subtle . (color gamma 250))
(accent . (color primary tone))))))
(font ((size ((xs . "0.694rem")
(s . "0.833rem")
(n . "1rem")
(l . "1.2rem")
(xl . "1.44rem")
(xxl . "1.728rem")))
(family ((label . "Arial, Sans-Serif")
(body . "Georgia, Serif")))))
(icon ((size ((xs . "0.867rem")
(s . "1.041rem")
(n . "1.25rem")
(l . "1.5rem")
(xl . "1.8rem")
(xxl . "2.16rem")))))
(line-height ((tight . 1.2)
(regular . 1.6)
(loose . 2.133)))
(space ((12 . "0.125rem")
(25 . "0.25rem")
(50 . "0.5rem")
(75 . "0.75rem")
(100 . "1rem")
(125 . "1.25rem")
(150 . "1.5rem")
(175 . "1.75rem")
(200 . "2rem")))
(gap ((side . (space 50))
(col . (space 50))
(gutter . (space 50))
(associated . (space 25))))
(width ((main ((max . "700px")))))
(radius ((small . "0.25rem")
(medium . "0.5rem")
(large . "1rem")
(round . "50%")
(pill . "9999px")))
))
;; given a path, find it's value in the tree
;; If path has one less element
;; than the depth of the tree for that path it will be
;; assumed that the last level should use an implicit 'default
;; for the path.
;; for example: (style-path-value spec '(color gamma 900)) -> "#f2f2f2"
;; or with default path: (style-path-value spec '(color primary)) -> "#983490"
(define (style-path-value tree path)
(let ((res (alist-ref (car path) tree)))
(if res
(cond ((and (null? (cdr path)) (pair? res) (pair? (car res)))
(style-path-value (car res) '(default)))
((null? (cdr path))
res)
(else
(style-path-value (car res) (cdr path))))
'())))
;; convert the spec tree to a list of tokens and values
;; the path to a node is converted to a single symbol
;; that is joined by a period (.)
;; for example (style-token-tree->list spec '()) ->
;; ((color.gamma.900 "#f2f2f2")
;; (color.gamma.50 "#0d0d0d")
;; (color.primary.default "#983490")
;; (color.primary.rgb (152 52 144))
;; (color.primary.contrast (color contrast dark))
;; (color.secondary.default "#41be4b")
;; (color.secondary.rgb (65 190 75))
;; (color.secondary.contrast (color contrast light))
;; (font.size.xs "0.694rem")
;; (font.size.s "0.833rem"))
(define (style-token-tree->list tree tokens)
(apply append (map (lambda (node)
;; we are at the end of the expansion if the cdr of the node is a dotted pair
(if (and (pair? node) (pair? (cdr node)) (pair? (cadr node)))
(style-token-tree->list (cadr node) (append tokens (list (car node))))
(append ;; we use append so that if there is no default node it returns an empy list and gets "removed" from the return value
(list
(list (string->symbol
(string-intersperse
(map ->string
(append tokens (list (car node))) ;; combine tokens and node value into final form
)
"."))
(cdr node)))
(if (eq? (car node) 'default) ;; create an extra entry without "default" on it
(list (list (string->symbol
(string-intersperse (map ->string tokens) "."))
(cdr node)))
(list)))))
tree)))
;; recursively lookup a path variable until
;; we find its root value.
;; for example: (resolved-style-path-value spec '(color contrast dark)) -> "#f2f2f2"
(define (resolved-style-path-value tree path)
(let ((val (style-path-value tree path)))
(if (pair? val) ;; result is another path so look it up
(resolved-style-path-value tree val)
val)))
(define (run-style-token-tests)
(assert "#f2f2f2" (style-path-value *style-tokens* '(color gamma 900)))
(assert "#983490" (style-path-value *style-tokens* '(color primary)))
(style-token-tree->list *style-tokens* '()) ;; TODO
(assert "#f2f2f2" (resolved-style-path-value *style-tokens* '(color contrast dark))))
;; convenience function for using a style token.
;; takes as an argument either a dotted token symbol or a path.
;; Returns the fully resolved value
;; ($ 'color.primary.contrast) -> "#f2f2f2"
;; OR
;; ($ '(color primary contrast) -> "#f2f2f2"
(define ($ path-or-symbol)
(if (symbol? path-or-symbol)
(let ((val (car (alist-ref path-or-symbol (style-token-tree->list *style-tokens* '())))))
(if (pair? val) ;; if we got a path back instead of a value
(resolved-style-path-value *style-tokens* val)
val))
(resolved-style-path-value *style-tokens* path-or-symbol)))
Adding tests.
2025-11-30 11:36:19 -08:00
(define test-mode (make-parameter #f))
(define last-request-body-sxml (make-parameter '()))
(define last-request-body-widget-sxml (make-parameter '()))
Adding web app.
2025-10-08 05:53:38 -07:00
(define (widget-sxml->html sxml-head sxml-body)
(let ((sxml-head-out (widget->sxml-and-css sxml-head)))
(receive (sxml-body-out css-list)
(widget->sxml-and-css sxml-body)
Adding tests.
2025-11-30 11:36:19 -08:00
(when test-mode
(last-request-body-widget-sxml sxml-body)
(last-request-body-sxml (widget->sxml sxml-body)))
Adding web app.
2025-10-08 05:53:38 -07:00
(print "<!DOCTYPE html>")
(SXML->HTML
`(html (head (style ,(apply string-append (cons *global-css-reset* css-list)))
,@sxml-head-out)
,sxml-body-out)))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(define test-user-id (make-parameter 1))
Removing sessions and only using authelia auth headers
2026-04-16 08:55:31 -07:00
(define (authelia-auth-middleware next)
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(cond-expand
(dev
Removing sessions and only using authelia auth headers
2026-04-16 08:55:31 -07:00
(current-params (append `((user-id . ,(test-user-id)) (username . "me")) (current-params)))
(next))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(else
Removing sessions and only using authelia auth headers
2026-04-16 08:55:31 -07:00
(let* ((request (current-request))
(headers (request-headers request))
(remote-user (header-value 'remote-user headers))
(uri (request-uri request))
(path (uri-path uri)))
(if remote-user
(begin
(current-params (append `((user-id . ,(with-db/transaction
(lambda (db)
(get-user-id-by-username db remote-user))))
(username . ,remote-user))
(current-params)))
(next))
(if (string-prefix-ci? "/unsecured/" path)
(next)
'(unauthorized "no valid auth header")))))))
(with-schematra-app app
(lambda ()
(use-middleware! authelia-auth-middleware)))
(define (session-user-id)
(alist-ref 'user-id (current-params)))
Adding web app.
2025-10-08 05:53:38 -07:00
Adding tests.
2025-11-30 11:36:19 -08:00
(define-syntax get/widgets
Adding web app.
2025-10-08 05:53:38 -07:00
(syntax-rules ()
((_ (path) body ...)
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(get/widgets (path '()) body ...))
((_ (path headers) body ...)
Adding tests.
2025-11-30 11:36:19 -08:00
(get path
(with-output-to-string
(lambda ()
(widget-sxml->html
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(cons
'(meta (@ (name "viewport") (content "width=device-width")))
headers)
;; `((meta (@ (name "viewport") (content "width=device-width"))))
Adding tests.
2025-11-30 11:36:19 -08:00
(begin
body ...))))))))
Adding web app.
2025-10-08 05:53:38 -07:00
(define-widget (Container ((max-width ($ 'width.main.max)) (style '())) contents)
`(div (@ (data-name "Container")
(style ((display "flex")
(flex-wrap "wrap")
(justify-content "center")
,@style)))
(div (@ (style ((width "100%")
(max-width ,max-width))))
,@contents)))
(define-widget (Decorative-Box ((color ($ 'color.gamma.800))) contents)
`(div (@ (data-name "Decorative-Box")
(style ((background-color ,color))))
,@contents))
(define-widget (Box () contents)
`(div (@ (data-name "Box"))
,@contents))
(define-widget (Stack ((direction 'vertical) (gap ($ 'gap.gutter)) (style '()) (element 'div)) contents)
`(,element (@ (style ((display "flex")
(flex-direction ,(if (eq? direction 'vertical) "column" "row"))
(gap ,gap)
,@style))
(data-name "Stack"))
,@contents))
(define-widget (HStack ((gap ($ 'gap.col)) (style '())) contents)
`(Stack (@ (direction horizontal) (gap ,gap) (style ,style))
,@contents))
(define-widget (VStack ((gap ($ 'gap.gutter)) (style '()) (element #f)) contents)
`(Stack (@ ,@(if element `((element ,element)) '()) (direction vertical) (gap ,gap) (style ,style))
,@contents))
(define-widget (Step ((current #t) (completed #f) (last #f) (step-number 0)) contents)
(let ((container-break 460))
`(div (@ (style ((position "relative")
(display "flex")
(flex-direction "column")
(flex ,(if last "initial" "1 0 0px"))))
(data-name "Step"))
(div (@ (style ((display "flex")
(align-items "center")
(gap ,($ 'gap.col)))))
(div (@ (style ((background ,(if completed
($ 'color.secondary.shade)
(if current
($ 'color.secondary)
($ 'color.base.light))))
(border-color ,($ 'color.base.dark))
(border-width "2px")
(border-style "solid")
(color ,(if (or current completed) ($ 'color.secondary.contrast) ($ 'color.base.dark)))
(border-radius ,($ 'radius.pill))
(width ,($ 'icon.size.xxl))
(height ,($ 'icon.size.xxl))
(display "flex")
(justify-content "center")
(align-items "center")
(flex-shrink "0")
,@(if current
`((box-shadow ,(conc "0 0 5px " ($ 'color.base.light))))
'()))))
,(if completed
`(svg (@ (style ((fill "none")
(stroke "currentColor")
(stroke-width "2px")
(stroke-linecap "round")
(stroke-linejoin "round")
(flex-shrink "0")
(width ,($ 'icon.size.l))
(height ,($ 'icon.size.l)))))
(path (@ (d "M20 6 9 17l-5-5"))))
`(div ,step-number)))
(div (@ (style ((@container ,(conc "(max-width: " container-break "px)")
(display "none")))))
,@contents)
,@(if (not last)
`((div (@ (style (,(if completed
`(background ,($ 'color.base.dark))
`(background ,($ 'color.gamma.400)))
(flex "1 1 0%")
(width "100%")
(height "2px")
(margin-inline-end "8px"))))))
'()))
(div (@ (style ((@container ,(conc "(min-width: " container-break "px)")
(display "none"))
(margin-top ,($ 'gap.gutter)))))
,@contents))))
(define-widget (Steps ((current "") (steps '())))
`(HStack
(@ (style ((width "100%")
(justify-content "space-between")
(align-items "center")
(container-type "inline-size")))
(gap "0"))
,@(let ((num-steps (length steps))
(step-index (list-index (lambda (x) (equal? x current)) steps)))
(map
(lambda (step i)
`(Step (@ (last ,(= i (- num-steps 1)))
(completed ,(< i step-index))
(current ,(= i step-index))
(step-number ,(+ i 1)))
,step))
steps (list-tabulate num-steps values)))))
(define-widget (Body () contents)
`(body (@ (data-name "Body") (style ((background ,($ 'color.secondary.tint)) (font-family ,($ 'font.family.label)))))
,@contents))
(define-widget (App () contents)
`(Body (Container (@ (style ((margin "0.8rem")))) ,@contents)))
(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)))))
(header
(Steps (@ (steps ("Services" "Apps" "Machine" "Review")) (current ,step))))
(main
(h1 (@ (style ((font-size ,($ 'font.size.xxl))))) ,step)
,@contents)))
Initial sketch of dashboard.
2025-11-15 12:34:29 -08:00
(define-widget (Main-Container () contents)
`(VStack
(@ (style ((background ,($ 'color.primary.background))
(color ,($ 'color.primary.background-contrast))
(border-radius ,($ 'radius.large))
(padding ,($ 'gap.gutter)))))
;; (header
;; (Steps (@ (steps ("Services" "Apps" "Machine" "Review")) (current ,step))))
,@contents))
Adding web app.
2025-10-08 05:53:38 -07:00
(define-widget (Fieldset ((title "Title")) contents)
`(VStack
(@ (element fieldset)
(data-name "Fieldset")
(style ((background "rgba(0,0,0,0.1)")
(border-radius ,($ 'radius.small))
(min-width "0"))))
(legend
(h2 (@ (style ((font-size ,($ 'font.size.xl)) (font-weight "bold") (font-style "italic"))))
,title))
,@contents))
(define-widget (Field ((name "") (id #f) (label '()) (element 'input) (type "text") (value #f) (checked #f)
(input-style '()) (disabled #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)) '()))
,@contents)))
`(,(if (equal? type "checkbox") 'HStack 'VStack)
(@ (gap ,($ 'gap.associated)))
,(if (equal? type "checkbox") input label)
,(if (equal? type "checkbox") label input))))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(define-widget (Button ((type "submit") (enabled #t)) contents)
Initial sketch of dashboard.
2025-11-15 12:34:29 -08:00
`(button (@ (type ,type)
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
,@(if enabled '() '((disabled)))
(style ((background ,(if enabled
($ 'color.primary)
($ 'color.primary.contrast)))
(color ,(if enabled
($ 'color.primary.contrast)
($ 'color.primary)))
Initial sketch of dashboard.
2025-11-15 12:34:29 -08:00
(border-radius ,($ 'radius.medium))
(border-color ,($ 'color.primary.shade))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
,@(if enabled
'((cursor "pointer"))
'()))))
Initial sketch of dashboard.
2025-11-15 12:34:29 -08:00
,@contents))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(define-widget (Form-Nav ((back-to #f) (submit-button "Next") (submit-enabled #t)))
Adding web app.
2025-10-08 05:53:38 -07:00
`(HStack
(@ (style ((justify-content "space-between"))))
(a (@ (href ,(or back-to ""))
(style ((background ,(if back-to ($ 'color.primary.tint) ($ 'color.base.light)))
(color ,(if back-to ($ 'color.primary.contrast) ($ 'color.contrast.light)))
(border-radius ,($ 'radius.medium))
(border-color ,($ 'color.primary.shade))
(border-style "solid")
(border-width "2px")
(padding ,($ 'space.25))
(text-align "center")
(text-decoration "none")
,@(if back-to
'()
'((pointer-events "none"))))))
Initial sketch of dashboard.
2025-11-15 12:34:29 -08:00
"Back")
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(Button (@ (enabled ,submit-enabled)) ,submit-button)))
Adding web app.
2025-10-08 05:53:38 -07:00
Adding tests.
2025-11-30 11:36:19 -08:00
;; Parsing JSON arrays as lists instead of vectors
(define array-as-list-parser
(cons 'array (lambda (x) x)))
(json-parsers (cons array-as-list-parser (json-parsers)))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
;; TODO change username to to a prod API key that has read access
;; to the checkout session
(define (send-stripe-request #!key (method 'GET) endpoint (body #f) (username ""))
(define api-endpoint "https://api.stripe.com/")
(define api-version "/v1")
(with-input-from-request
(make-request method: method
uri: (uri-reference (string-append api-endpoint api-version endpoint))
headers: (headers `((authorization . (#(basic ((username . ,username) (password . ""))))))))
body
read-json))
(define (stripe-session-email sid)
(alist-ref
'email
(alist-ref
'customer_details
(send-stripe-request endpoint: (string-append "/checkout/sessions/" sid)))))
(define (create-lldap-user username email)
;; query = mutation createUser($user:CreateUserInput!){createUser(user:$user){id email displayName firstName lastName avatar}}
;; variables = {\"user\":{\"id\":\"${id}\",\"email\":\"${email}\",\"displayName\":\"${name}\",\"firstName\":\"${firstName}\",\"lastName\":\"${lastName}\",\"avatar\":\"
;; data="{\"query\":\"${query}\",\"variables\":${variables}"
;; http://localhost:17170/api/graphql
;; -H 'Content-Type: application/json' \
;; -H "Authorization: Bearer $token" \
(let ((api-token
(alist-ref
'token
(with-input-from-request
(make-request method: 'POST
uri: (uri-reference "http://nassella_lldap:17170/auth/simple/login")
headers: (headers `((content-type application/json))))
(lambda ()
(write-json
`((username . "admin") (password . ,(string-trim-right (with-input-from-file "/run/secrets/nassella_lldap_admin_password" read-string)))))) ;; trim to remove newline
read-json))))
(with-input-from-request
(make-request method: 'POST
uri: (uri-reference "http://nassella_lldap:17170/api/graphql")
headers: (headers `((content-type application/json)
(authorization #(,(string-append "Bearer " api-token) raw)))))
(lambda ()
(write-json
`((query . "mutation createUser($user:CreateUserInput!){createUser(user:$user){id email displayName firstName lastName avatar}}")
(variables . ((user . ((id . ,username)
(email . ,email))))))))
read-json)))
Adding tests.
2025-11-30 11:36:19 -08:00
(define (get-digital-ocean-regions api-token)
(filter
(lambda (r)
(alist-ref 'available r))
(if (test-mode)
*digital-ocean-regions-response*
(alist-ref
'regions
(let* ((uri (uri-reference "https://api.digitalocean.com/v2/regions"))
(req (make-request method: 'GET
uri: uri
headers: (headers `((content-type application/json)
(Authorization ,(conc "Bearer " api-token)))))))
(with-input-from-request req #f read-json))))))
(define (get-digital-ocean-sizes api-token)
(filter
(lambda (r)
(alist-ref 'available r))
(alist-ref
'sizes
(if (test-mode)
*digital-ocean-sizes-response*
(let* ((uri (uri-reference "https://api.digitalocean.com/v2/sizes?per_page=200"))
(req (make-request method: 'GET
uri: uri
headers: (headers `((content-type application/json)
(Authorization ,(conc "Bearer " api-token)))))))
(with-input-from-request req #f read-json))))))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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)
;; )
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(define (deployment-directory user-id instance-id)
(string-append "deploy-" (number->string user-id) "-" (->string instance-id)))
Adding tests.
2025-11-30 11:36:19 -08:00
(define (setup-deploy-files dir state state-backup)
(when (directory-exists? dir)
(delete-directory dir #t))
(create-directory dir)
(process-wait (process-run (string-append "tar -xf nassella-latest.tar -C " dir)))
(create-directory (string-append dir "/config"))
(copy-file "../config/ssh-keys" (string-append dir "/config/ssh-keys")) ;; TODO remove
(with-output-to-file (string-append dir "/terraform.tfstate") (lambda () (write-string state)))
(with-output-to-file (string-append dir "/terraform.tfstate.backup") (lambda () (write-string state-backup))))
(define (parse-deployment-log log)
(define (search complete in-progress)
(cond ((irregex-search complete log)
'complete)
((irregex-search in-progress log)
'in-progress)
(else 'queued)))
`((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start"))
Adding ghost and fixing compose .env setup.
2025-12-07 10:38:36 -08:00
;; TODO this didn't seem to work right when upgrading the flatcar image
;; log: [0mdigitalocean_custom_image.flatcar: Creating...
;; digitalocean_custom_image.flatcar: Still creating... [00m10s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m20s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m30s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m40s elapsed]
Adding tests.
2025-11-30 11:36:19 -08:00
(custom-image . ,(search "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Modifying"))
(machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..."))
(machine-destroy . ,(search "droplet.machine: Destruction complete"
'(: "droplet.machine (deposed object " (* alphanum) "): Destroying...")))))
(define (write-config-entry name value)
(display name)
(display "=\"")
(display value)
(print "\""))
(define (progress-status->text status)
(case status
((queued) "queued")
((in-progress) "in progress")
((complete) "complete")
((failed) "failed")))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
;; (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)
Working nassella running on nassella!!
2026-02-23 09:09:58 -08:00
(if exit-normal
(begin
(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
(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)))
(delete-directory key-path #t)
(list priv-key pub-key)))
(error "Generating ssh key docker command had abnormal exit")))))))))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(thread-join! thread)))))
(define (generate-restic-password)
(generator->string (gtake (make-random-char-generator
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
30)))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(define (generate-jwt-secret)
(generator->string (gtake (make-random-char-generator
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
32)))
(define (generate-key-seed)
(generator->string (gtake (make-random-char-generator
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
32)))
(define (generate-authelia-key-seed)
(generator->string (gtake (make-random-char-generator
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
64)))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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)))
Adding tests.
2025-11-30 11:36:19 -08:00
(with-schematra-app app
(lambda ()
Working nassella deployment.
2026-04-08 19:54:32 -07:00
;;; UNSECURED PAGES
(get/widgets
("/unsecured/account/create")
`(App
(form
(@ (action "/unsecured/account/create-submit") (method POST))
(VStack
(Fieldset
(@ (title "Account Details"))
(Field (@ (name "username") (label ("Username"))))
(input (@ (type "hidden") (name "sid") (value ,(alist-ref 'sid (current-params) equal?))))
(Button (@ (type "submit")) "Create Account"))))))
(post "/unsecured/account/create-submit"
(let ((email (stripe-session-email (alist-ref 'sid (current-params))))
(username (alist-ref 'username (current-params))))
(create-lldap-user username email)
(with-db/transaction (lambda (db) (create-user db email username))))
(redirect "/authelia/reset-password"))
;;; REQUIRES AUTHED USER
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(post "/config/wizard/create-instance"
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(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))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
;; TODO should all these key related form fields be of type password
;; so the browser doesn't save them???
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
("/config/wizard/services/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-user-id)
instance-id)))))
Postgres db integration.
2025-11-10 13:13:59 -08:00
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(@ (action ,(conc "/config/wizard/services-submit/" instance-id))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(method POST))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(Field (@ (name "cloudflare-api-token") (label ("API Token")) (value ,(alist-ref 'cloudflare-api-token config))))
(Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (value ,(alist-ref 'cloudflare-zone-id config))))
(Field (@ (name "cloudflare-account-id") (label ("Account ID")) (value ,(alist-ref 'cloudflare-account-id config)))))
(Fieldset
(@ (title "DigitalOcean"))
(Field (@ (name "digitalocean-api-token") (label ("API Token")) (value ,(alist-ref 'digitalocean-api-token config)))))
(Fieldset
(@ (title "Backblaze"))
(Field (@ (name "backblaze-application-key") (label ("Application Key")) (value ,(alist-ref 'backblaze-application-key config))))
(Field (@ (name "backblaze-key-id") (label ("Key ID")) (value ,(alist-ref 'backblaze-key-id config))))
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url config)))))
(Form-Nav)))))))
Adding web app.
2025-10-08 05:53:38 -07:00
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(post "/config/wizard/services-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
`((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (current-params)))
(cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (current-params)))
(cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (current-params)))
(digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (current-params)))
(backblaze-application-key . ,(alist-ref 'backblaze-application-key (current-params)))
(backblaze-key-id . ,(alist-ref 'backblaze-key-id (current-params)))
(backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (current-params)))))))
(redirect (conc "/config/wizard/services-success/" instance-id))))
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
("/config/wizard/services-success/:id")
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action ,(conc "/config/wizard/apps/" instance-id)))
(VStack
(Fieldset
(@ (title "Cloudflare"))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
,@(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))
"\" & \"")
"\""))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(Fieldset
(@ (title "DigitalOcean"))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
,@(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))
"\" & \"")
"\""))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(Fieldset
(@ (title "Backblaze"))
(h3 "Connected")
(p "Your Backblaze account was successfully connected!"))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(Form-Nav (@ (back-to ,(conc "/config/wizard/services/" instance-id))
(submit-enabled ,(and (alist-ref 'success cloudflare-result)
(alist-ref 'success digitalocean-result)))))))))))
Adding web app.
2025-10-08 05:53:38 -07:00
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
("/config/wizard/apps/: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))))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(app-config . ,(get-user-app-config db (session-user-id) instance-id))
(service-config . ,(get-user-service-config db (session-user-id) instance-id)))))))
Postgres db integration.
2025-11-10 13:13:59 -08:00
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(@ (action ,(conc "/config/wizard/apps-submit/" instance-id)) (method POST))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(VStack
(Fieldset
(@ (title "Root Domain"))
(Field (@ (element select) (name "root-domain"))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
,@(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))))
))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(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)))))
Adding ghost and fixing compose .env setup.
2025-12-07 10:38:36 -08:00
(Field (@ (name "ghost") (type "checkbox") (label ("Ghost")) (checked ,(member 'ghost (alist-ref 'selected-apps results)))))
Working nassella running on nassella!!
2026-02-23 09:09:58 -08:00
(Field (@ (name "nassella") (type "checkbox") (label ("Nassella")) (checked ,(member 'nassella (alist-ref 'selected-apps results)))))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
;; TODO add config for when automatic upgrades are scheduled for?
;; TODO add config for server timezone?
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(Form-Nav (@ (back-to ,(conc "/config/wizard/services-success/" instance-id))))))))))
(post "/config/wizard/apps-submit/:id"
(let ((instance-id (alist-ref "id" (current-params) equal?)))
(with-db/transaction
(lambda (db)
(update-user-selected-apps
db
(session-user-id)
instance-id
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
`((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)))
Working nassella running on nassella!!
2026-02-23 09:09:58 -08:00
(ghost . ,(or (and (alist-ref 'ghost (current-params)) "6.10.0") (sql-null)))
(nassella . ,(or (and (alist-ref 'nassella (current-params)) "b0.0.1") (sql-null)))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(update-root-domain db
(session-user-id)
instance-id
(alist-ref 'root-domain (current-params)))))
(redirect (conc "/config/wizard/apps2/" instance-id))))
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
("/config/wizard/apps2/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(results
Postgres db integration.
2025-11-10 13:13:59 -08:00
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(get-user-selected-apps db (session-user-id) instance-id))))
(app-config . ,(get-user-app-config db (session-user-id) instance-id))))))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(selected-apps (alist-ref 'selected-apps results))
Adding tests.
2025-11-30 11:36:19 -08:00
(app-config (alist-ref 'config (alist-ref 'app-config results))))
Postgres db integration.
2025-11-10 13:13:59 -08:00
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(@ (action ,(conc "/config/wizard/apps2-submit/" instance-id)) (method POST))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(VStack
Adding ghost and fixing compose .env setup.
2025-12-07 10:38:36 -08:00
,@(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"))))))
'())
Postgres db integration.
2025-11-10 13:13:59 -08:00
,@(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"))))))
'())
,@(if (member 'nextcloud selected-apps)
`((Fieldset
(@ (title "NextCloud"))
(Field (@ (name "nextcloud-subdomain") (label ("Subdomain"))
(value ,(alist-ref 'subdomain (alist-ref 'nextcloud app-config eq? '()) eq? "nextcloud"))))
(Field (@ (name "nextcloud-admin-user") (label ("Admin Username"))
(value ,(alist-ref 'admin-user (alist-ref 'nextcloud app-config eq? '()) eq? "admin"))))
(Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password")
(value ,(alist-ref 'admin-password (alist-ref 'nextcloud app-config eq? '()) eq? ""))))))
'())
Working nassella running on nassella!!
2026-02-23 09:09:58 -08:00
,@(if (member 'nassella selected-apps)
`((Fieldset
(@ (title "Nassella"))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(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"))
(value ,(alist-ref 'lldap-subdomain (alist-ref 'nassella app-config eq? '()) eq? "lldap"))))
(Field (@ (name "nassella-lldap-admin-password") (label ("Admin Password")) (type "password")
(value ,(alist-ref 'lldap-admin-password (alist-ref 'nassella app-config eq? '()) eq? ""))))))
Working nassella running on nassella!!
2026-02-23 09:09:58 -08:00
'())
Postgres db integration.
2025-11-10 13:13:59 -08:00
(Fieldset
(@ (title "Log Viewer"))
(Field (@ (name "log-viewer-subdomain") (label ("Subdomain"))
(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? "")))))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
,@(if (or (member 'nextcloud selected-apps) (member 'ghost selected-apps) (member 'nassella selected-apps))
Properly gather, save, and generate Ghost config.
2025-12-08 11:32:30 -08:00
`((Fieldset
(@ (title "All Apps - Email - SMTP"))
(Field (@ (name "smtp-host") (label ("Host"))
(value ,(alist-ref 'smtp-host (alist-ref 'all-apps app-config eq? '()) eq? ""))))
(Field (@ (name "smtp-port") (label ("Port"))
(value ,(alist-ref 'smtp-port (alist-ref 'all-apps app-config eq? '()) eq? ""))))
(Field (@ (name "smtp-auth-user") (label ("Auth User"))
(value ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps app-config eq? '()) eq? ""))))
(Field (@ (name "smtp-auth-password") (label ("Auth Password")) (type "password")
(value ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps app-config eq? '()) eq? ""))))
(Field (@ (name "smtp-from") (label ("From"))
(value ,(alist-ref 'smtp-from (alist-ref 'all-apps app-config eq? '()) eq? "My Name <no-reply@example.org>"))))))
'())
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(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)
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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)))))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(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)))
(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)))))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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))))))))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(redirect (conc "/config/wizard/machine/" instance-id))))
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
("/config/wizard/machine/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-user-id) instance-id)))))
Postgres db integration.
2025-11-10 13:13:59 -08:00
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(@ (action ,(conc "/config/wizard/machine-submit/" instance-id))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(method POST))
(VStack
(Fieldset
(@ (title "Region"))
(Field (@ (element select) (name "region"))
(option (@ (value "")) "")
,@(map (lambda (r)
`(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r)))
(get-digital-ocean-regions (alist-ref 'digitalocean-api-token config)))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2/" instance-id))))))))))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
;; TODO if the region is changed, all of the data is DELETED because the
;; volume is deleted and re-created
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(post "/config/wizard/machine-submit/:id"
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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))))
Adding web app.
2025-10-08 05:53:38 -07:00
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
("/config/wizard/machine2/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(config (with-db/transaction
Postgres db integration.
2025-11-10 13:13:59 -08:00
(lambda (db)
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(get-user-service-config db (session-user-id) instance-id))))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(region (alist-ref 'digitalocean-region config))
(all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token config)))
Adding web app.
2025-10-08 05:53:38 -07:00
(sizes (filter (lambda (s) (member region (alist-ref 'regions s))) all-sizes)))
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(@ (action ,(conc "/config/wizard/machine2-submit/" instance-id))
Adding web app.
2025-10-08 05:53:38 -07:00
(method POST))
(VStack
(Fieldset
(@ (title "Size"))
(Field (@ (element select) (name "size") (input-style ((max-width "100%"))))
,@(map (lambda (s) `(option (@ (value ,(alist-ref 'slug s))
,@(if (equal? (alist-ref 'slug s) "s-2vcpu-2gb") `((selected "selected")) '()))
"$" ,(alist-ref 'price_monthly s)
" (CPU: ",(alist-ref 'vcpus s)
" Mem: " ,(/ (alist-ref 'memory s) 1024)
" Disk: " ,(alist-ref 'disk s)
") " ,(alist-ref 'description s)))
sizes)))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine/" instance-id))))))))))
(post "/config/wizard/machine2-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-size . ,(alist-ref 'size (current-params)))))))
(redirect (conc "/config/wizard/review/" instance-id))))
Adding web app.
2025-10-08 05:53:38 -07:00
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
("/config/wizard/review/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(results
Postgres db integration.
2025-11-10 13:13:59 -08:00
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(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))))))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(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)))
`(App
(Configuration-Wizard
(@ (step "Review"))
(h2 "Root Domain")
,root-domain
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(h2 "Apps") ;; TODO if an app that was previously selected is now unselected we need to somehow delete its data
;; so that if the user then re-deploys the app later we don't have key conflicts
Postgres db integration.
2025-11-10 13:13:59 -08:00
(ul ,@(map (lambda (app) `(li ,app " @ "
,(alist-ref 'subdomain (alist-ref app config))
"."
,root-domain))
selected-apps))
(h2 "Machine")
(ul (li "Region: " ,(alist-ref 'digitalocean-region service-config))
(li "Size: " ,(alist-ref 'digitalocean-size service-config)))
(form
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(@ (action ,(conc "/config/wizard/review-submit/" instance-id)) (method POST))
Postgres db integration.
2025-11-10 13:13:59 -08:00
(VStack
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch")))))))))
Adding web app.
2025-10-08 05:53:38 -07:00
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
;; TODO run restic-init if needed (like the first run or if the backblaze
;; config changes
;; TODO should this perform a backup and then run the systemctl stop app command first?
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(post "/config/wizard/review-submit/:id"
Don't allow deploying an app that is being deployed.
2026-04-20 15:44:39 -07:00
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(status (string->symbol
(with-db/transaction
(lambda (db)
(get-most-recent-deployment-status db (session-user-id) instance-id))))))
(when (not (or (eq? status 'queued) (eq? status 'in-progress)))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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))
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(dir (deployment-directory (session-user-id) instance-id)))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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)))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config)))
("NASSELLA_POSTGRES_DB" . "nassella")
("NASSELLA_POSTGRES_USER" . "nassella")
("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config)))
("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia")
("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia")
("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config)))
("NASSELLA_LLDAP_POSTGRES_DB" . "lldap")
("NASSELLA_LLDAP_POSTGRES_USER" . "lldap")
("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config)))
("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config)))
("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config)))
("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config)))
("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config)))
("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella config)))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
("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))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
("cluster_name" . "nassella")
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
Working nassella running on nassella!!
2026-02-23 09:09:58 -08:00
;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
Working nassella deployment.
2026-04-08 19:54:32 -07:00
("flatcar_stable_version" . "4459.2.4")))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
;; 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))))
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(dir (deployment-directory user-id instance-id)))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(string-append (deployment-directory user-id instance-id) "/make-out")
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
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
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(string-append (deployment-directory user-id instance-id) "/make-out")
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
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)
Don't allow deploying an app that is being deployed.
2026-04-20 15:44:39 -07:00
(if (eof-object? tf-state-backup) "" tf-state-backup))))))))))))))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))
Adding web app.
2025-10-08 05:53:38 -07:00
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
("/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")))))))
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(res (with-db/transaction
Improving deployment progress status handling.
2025-11-12 13:22:25 -08:00
(lambda (db)
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
`((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))
(progress . ,(get-most-recent-deployment-progress db (session-user-id) instance-id))))))
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(output (with-input-from-file (string-append (deployment-directory (session-user-id) instance-id) "/make-out") read-string))
Improving deployment progress status handling.
2025-11-12 13:22:25 -08:00
(progress (alist-ref 'progress res))
(status (alist-ref 'status res)))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
`(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)
)))))
Adding web app.
2025-10-08 05:53:38 -07:00
Adding tests.
2025-11-30 11:36:19 -08:00
(get/widgets
Initial sketch of dashboard.
2025-11-15 12:34:29 -08:00
("/dashboard")
`(App
(Main-Container
(main
Refactor to support multiple instances.
2025-11-30 20:13:51 -08:00
(h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Instances")
(form
(@ (action "/config/wizard/create-instance")
(method POST))
(Button "Setup New Instance"))
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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/")
Working nassella running on nassella!!
2026-02-23 09:09:58 -08:00
(nassella . "https://nextcloud.com/support/")
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(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")
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
(li (a (@ (href "/destroy/" ,(alist-ref 'instance-id instance)))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
"Destroy - deletes data and configuration (confirmation required)"))
(li (a (@ (href "/reset/" ,(alist-ref 'instance-id instance)))
"Reset - deletes data (confirmation required)")))))))
Initial sketch of dashboard.
2025-11-15 12:34:29 -08:00
(with-db/transaction
(lambda (db)
Backblaze, db bugfixes and connection testing.
2026-01-18 07:50:31 -08:00
(get-dashboard db (session-user-id))))))))))
Adding tests.
2025-11-30 11:36:19 -08:00
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
(get/widgets
("/destroy/:id")
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(root-domain
(with-db/transaction
(lambda (db)
(alist-ref 'root-domain (get-user-app-config db (session-user-id) instance-id))))))
`(App
(h2 "Destroy Instance")
,root-domain
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(h2 "This action is NOT reversible. All data will be lost!")
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
(form
(@ (action ,(conc "/destroy-submit/" instance-id)) (method POST))
(VStack
(Fieldset
(@ (title "Type the domain name of the instance to confirm."))
(Field (@ (name "instance-domain") (label ("Domain")) (value ""))))
(Form-Nav (@ (back-to "/dashboard") (submit-button "Destroy"))))))))
;; TODO This is mostly a copy of the deployment POST action
(post "/destroy-submit/:id"
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-user-id) instance-id))))
(app-config . ,(get-user-app-config db (session-user-id) instance-id))
(service-config . ,(get-user-service-config db (session-user-id) instance-id))
(terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))
(ssh-pub-key . ,(get-instance-ssh-pub-key db (session-user-id) instance-id))
(restic-password . ,(get-instance-restic-password db (session-user-id) instance-id))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config))
(root-domain (alist-ref 'root-domain app-config))
(service-config (alist-ref 'service-config results))
(terraform-state (alist-ref 'terraform-state results))
(ssh-pub-key (alist-ref 'ssh-pub-key results))
(restic-password (alist-ref 'restic-password results))
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(dir (deployment-directory (session-user-id) instance-id)))
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
(if (not (string=? (alist-ref 'instance-domain (current-params)) root-domain))
(redirect (conc "/destroy/" instance-id))
(begin
(setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
(with-output-to-file (string-append dir "/config/apps.config")
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(lambda ()
(map (lambda (e)
(write-config-entry (car e) (cdr e)))
`(("ROOT_DOMAIN" . ,root-domain)
("APP_CONFIGS" . ,(string-intersperse
(map (lambda (app)
(conc (if (eq? app 'log-viewer) 'dozzle app)
","
(alist-ref 'subdomain (alist-ref app config))))
selected-apps)
" "))
("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config)))
("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
("NEXTCLOUD_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nextcloud config)))
("NEXTCLOUD_REDIS_PASSWORD" . ,(alist-ref 'redis-password (alist-ref 'nextcloud config)))
("GHOST_DATABASE_ROOT_PASSWORD" . ,(alist-ref 'postgres-root-password (alist-ref 'ghost config)))
("GHOST_DATABASE_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'ghost config)))
("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config)))
("NASSELLA_POSTGRES_DB" . "nassella")
("NASSELLA_POSTGRES_USER" . "nassella")
("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config)))
("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia")
("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia")
("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config)))
("NASSELLA_LLDAP_POSTGRES_DB" . "lldap")
("NASSELLA_LLDAP_POSTGRES_USER" . "lldap")
("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config)))
("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config)))
("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config)))
("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config)))
("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config)))
("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella config)))
("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
("RESTIC_PASSWORD" . ,restic-password)))))
(with-output-to-file (string-append dir "/config/production.tfvars")
(lambda ()
(map (lambda (e)
(write-config-entry (car e) (cdr e)))
`(("server_type" . ,(alist-ref 'digitalocean-size service-config))
("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
("cluster_name" . "nassella")
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
("flatcar_stable_version" . "4459.2.4")))
;; remove the newline that generating the ssh key adds
(display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]")))
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
;; TODO need a new table to track destroying?
;; as this is creating a new "deployment"
;; to attach state to
(let* ((instance-id (alist-ref "id" (current-params) equal?))
(user-id (session-user-id))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(dir (deployment-directory user-id instance-id)))
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
(thread-start!
(lambda ()
(change-directory dir)
(let ((pid (process-run "make destroy > make-out 2>&1")))
(with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
(change-directory "../")
(let loop ()
(thread-sleep! 5)
(receive (pid exit-normal status) (process-wait pid #t)
(if (= pid 0) ;; process is still running
(begin (let ((progress (parse-deployment-log
(with-input-from-file
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(string-append (deployment-directory user-id instance-id) "/make-out")
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
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
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(string-append (deployment-directory user-id instance-id) "/make-out")
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
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)
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(if (eof-object? tf-state-backup) "" tf-state-backup))
(when exit-normal
(destroy-instance db instance-id))))))))))))
wip instance "destroy" action
2026-02-09 08:30:39 -08:00
(redirect (conc "/destroy-success/" (alist-ref "id" (current-params) equal?)))))))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(get/widgets
("/destroy-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 (or (and (alist-ref 'status res) (string->symbol (alist-ref 'status res))) 'destroyed)))
(if (or (eq? status 'complete) (eq? status 'failed) (eq? status 'destroyed))
'()
'((meta (@ (http-equiv "refresh") (content "5")))))))
(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))
(progress . ,(get-most-recent-deployment-progress db (session-user-id) instance-id))))))
Allowing multiple instances to deploy at the same time.
2026-04-20 15:13:00 -07:00
(output (with-input-from-file (string-append (deployment-directory (session-user-id) instance-id) "/make-out") read-string))
Working nassella deployment.
2026-04-08 19:54:32 -07:00
(progress (alist-ref 'progress res))
(status (alist-ref 'status res)))
`(App
(Main-Container
(VStack
(h1
,(case (string->symbol status)
((queued) "Destroy queued")
((in-progress) "Destroy in progress")
((destroyed) "Destroy complete!")
((failed) "Destroy failed")))
,@(if (eq? status 'destroyed)
'((a (@ (href "/dashboard")) "Dashboard"))
`((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)))
)))))
Adding tests.
2025-11-30 11:36:19 -08:00
(schematra-install)
Initial sketch of dashboard.
2025-11-15 12:34:29 -08:00
Adding tests.
2025-11-30 11:36:19 -08:00
))
Reference in New Issue Copy Permalink