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

Adding web app.

Browse Source
main
Thomas Hintz 5 days ago
parent 84eee0820c
commit 8595014fde
1 changed files with 755 additions and 0 deletions
Show Stats Download Patch File Download Diff File

755
src/nassella.scm
Unescape Escape View File

@ -0,0 +1,755 @@
(import sxml-transforms (chicken string) (chicken port) html-widgets
(prefix schematra schematra:)
schematra-body-parser
schematra-session
(rename srfi-1 (delete srfi1:delete))
uri-common
http-client
medea
intarweb
(chicken io)
openssl
(chicken pretty-print)
(chicken io)
(chicken process)
(chicken process-context))
(schematra:use-middleware! (body-parser-middleware))
(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)))
(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)
(print "<!DOCTYPE html>")
(SXML->HTML
`(html (head (style ,(apply string-append (cons *global-css-reset* css-list)))
,@sxml-head-out)
,sxml-body-out)))))
(schematra:use-middleware! (session-middleware "your-secret-key-here"))
(define-syntax get
(syntax-rules ()
((_ (path) body ...)
(schematra:get (path)
(with-output-to-string
(lambda ()
(widget-sxml->html
'((meta (@ (name "viewport") (content "width=device-width"))))
(begin
;; TODO remove once sessions are integrated
(session-set! "user-id" "12345")
(session-set! "username" "me")
body ...))))))))
(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)))
(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))))
(define-widget (Form-Nav ((back-to #f) (submit-button "Next")))
`(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"))))))
"Back")
(button (@ (type "submit")
(style ((background ,($ 'color.primary))
(color ,($ 'color.primary.contrast))
(border-radius ,($ 'radius.medium))
(border-color ,($ 'color.primary.shade))
(cursor "pointer"))))
,submit-button)))
(define *data*
'())
(get
("/config/wizard/services")
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/services-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(Field (@ (name "cloudflare-api-token") (label ("API Token")) (value ,(alist-ref 'cloudflare-api-token *data*))))
(Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (value ,(alist-ref 'cloudflare-zone-id *data*))))
(Field (@ (name "cloudflare-account-id") (label ("Account ID")) (value ,(alist-ref 'cloudflare-account-id *data*)))))
(Fieldset
(@ (title "DigitalOcean"))
(Field (@ (name "digitalocean-api-token") (label ("API Token")) (value ,(alist-ref 'digitalocean-api-token *data*)))))
(Fieldset
(@ (title "Backblaze"))
(Field (@ (name "backblaze-application-key") (label ("Application Key")) (value ,(alist-ref 'backblaze-application-key *data*))))
(Field (@ (name "backblaze-key-id") (label ("Key ID")) (value ,(alist-ref 'backblaze-key-id *data*))))
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url *data*)))))
(Form-Nav))))))
(schematra:post ("/config/wizard/services-submit")
(set! *data* (alist-update 'cloudflare-api-token (alist-ref 'cloudflare-api-token (schematra:current-params)) *data*))
(set! *data* (alist-update 'cloudflare-account-id (alist-ref 'cloudflare-account-id (schematra:current-params)) *data*))
(set! *data* (alist-update 'cloudflare-zone-id (alist-ref 'cloudflare-zone-id (schematra:current-params)) *data*))
(set! *data* (alist-update 'digitalocean-api-token (alist-ref 'digitalocean-api-token (schematra:current-params)) *data*))
(set! *data* (alist-update 'backblaze-application-key (alist-ref 'backblaze-application-key (schematra:current-params)) *data*))
(set! *data* (alist-update 'backblaze-key-id (alist-ref 'backblaze-key-id (schematra:current-params)) *data*))
(set! *data* (alist-update 'backblaze-bucket-url (alist-ref 'backblaze-bucket-url (schematra:current-params)) *data*))
(schematra:redirect "/config/wizard/services-success"))
(get
("/config/wizard/services-success")
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/apps"))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(h3 "Connected")
(p "Your Cloudflare account was successfully connected!"))
(Fieldset
(@ (title "DigitalOcean"))
(h3 "Connected")
(p "Your DigitalOcean account was successfully connected!"))
(Fieldset
(@ (title "Backblaze"))
(h3 "Connected")
(p "Your Backblaze account was successfully connected!"))
(Form-Nav (@ (back-to "/config/wizard/services"))))))))
(get
("/config/wizard/apps")
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps-submit") (method POST))
(VStack
(Fieldset
(@ (title "Root Domain"))
(Field (@ (element select) (name "root-domain"))
(option (@ (value (alist-ref 'root-domain *data*))) "nassella.cc")))
(Fieldset
(@ (title "Selected Apps"))
(Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps *data*)))))
(Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'wg-easy (alist-ref 'selected-apps *data*)))))
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
(Form-Nav (@ (back-to "/config/wizard/services-success"))))))))
(schematra:post ("/config/wizard/apps-submit")
(set! *data* (alist-update 'root-domain (alist-ref 'root-domain (schematra:current-params)) *data*))
(set! *data* (alist-update 'selected-apps
`(,@(if (alist-ref 'wg-easy (schematra:current-params)) '(wg-easy) '())
,@(if (alist-ref 'nextcloud (schematra:current-params)) '(nextcloud) '())
log-viewer)
*data*))
(schematra:redirect "/config/wizard/apps2"))
(get
("/config/wizard/apps2")
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps2-submit") (method POST))
(VStack
,@(if (member 'wg-easy (alist-ref 'selected-apps *data*))
`((Fieldset
(@ (title "WG-Easy"))
(Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (value ,(alist-ref 'wg-easy-subdomain *data*))))))
'())
,@(if (member 'nextcloud (alist-ref 'selected-apps *data*))
`((Fieldset
(@ (title "NextCloud"))
(Field (@ (name "nextcloud-subdomain") (label ("Subdomain")) (value ,(alist-ref 'nextcloud-subdomain *data*))))
(Field (@ (name "nextcloud-admin-user") (label ("Admin Username")) (value ,(alist-ref 'nextcloud-admin-user *data*))))
(Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password") (value ,(alist-ref 'nextcloud-admin-password *data*))))))
'())
(Fieldset
(@ (title "Log Viewer"))
(Field (@ (name "log-viewer-subdomain") (label ("Subdomain")) (value ,(alist-ref 'log-viewer-subdomain *data*))))
(Field (@ (name "log-viewer-user") (label ("Username")) (value ,(alist-ref 'log-viewer-user *data*))))
(Field (@ (name "log-viewer-password") (label ("Password")) (type "password") (value ,(alist-ref 'log-viewer-password *data*)))))
(Form-Nav (@ (back-to "/config/wizard/apps"))))))))
(schematra:post ("/config/wizard/apps2-submit")
(set! *data* (alist-update 'nextcloud-admin-user (alist-ref 'nextcloud-admin-user (schematra:current-params)) *data*))
(set! *data* (alist-update 'nextcloud-admin-password (alist-ref 'nextcloud-admin-password (schematra:current-params)) *data*))
(set! *data* (alist-update 'log-viewer-user (alist-ref 'log-viewer-user (schematra:current-params)) *data*))
(set! *data* (alist-update 'log-viewer-password (alist-ref 'log-viewer-password (schematra:current-params)) *data*))
(schematra:redirect "/config/wizard/machine"))
;; 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)))
(define (get-digital-ocean-regions api-token)
(filter
(lambda (r)
(alist-ref 'available r))
(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
(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)))))
(get
("/config/wizard/machine")
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine-submit")
(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 *data*)))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2")))))))))
(schematra:post ("/config/wizard/machine-submit")
(set! *data* (alist-update 'digitalocean-region (alist-ref 'region (schematra:current-params)) *data*))
(schematra:redirect "/config/wizard/machine2"))
(get
("/config/wizard/machine2")
(let* ((region (alist-ref 'digitalocean-region *data*))
(all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token *data*)))
(sizes (filter (lambda (s) (member region (alist-ref 'regions s))) all-sizes)))
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine2-submit")
(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)))
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine"))))))))))
(schematra:post ("/config/wizard/machine2-submit")
(set! *data* (alist-update 'digitalocean-size (alist-ref 'size (schematra:current-params)) *data*))
(schematra:redirect "/config/wizard/review"))
(get
("/config/wizard/review")
`(App
(Configuration-Wizard
(@ (step "Review"))
(h2 "Root Domain")
,(alist-ref 'root-domain *data*)
(h2 "Apps")
(ul ,@(map (lambda (app) `(li ,app " @ "
,(alist-ref (string->symbol (conc (symbol->string app) "-subdomain")) *data*)
"."
,(alist-ref 'root-domain *data*)))
(alist-ref 'selected-apps *data*)))
(h2 "Machine")
(ul (li "Region: " ,(alist-ref 'digitalocean-region *data*))
(li "Size: " ,(alist-ref 'digitalocean-size *data*)))
(form
(@ (action "/config/wizard/review-submit") (method POST))
(VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2")) (submit-button "Launch"))))))))
(define (write-config-entry name key-or-value)
(display name)
(display "=\"")
(display (if (symbol? key-or-value) (alist-ref key-or-value *data*) key-or-value))
(print "\""))
(schematra:post ("/config/wizard/review-submit")
(with-output-to-file "deploy/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 (string->symbol (conc (symbol->string app) "-subdomain")) *data*)))
(alist-ref 'selected-apps *data*))
" "))
("HOST_ADMIN_USER" . log-viewer-user)
("HOST_ADMIN_PASSWORD" . log-viewer-password)
("NEXTCLOUD_ADMIN_USER" . nextcloud-admin-user)
("NEXTCLOUD_ADMIN_PASSWORD" . nextcloud-admin-password)
("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
("NEXTCLOUD_POSTGRES_PASSWORD" . "dbpassword")
("NEXTCLOUD_REDIS_PASSWORD" . "redispassword")
("BACKBLAZE_KEY_ID" . backblaze-key-id)
("BACKBLAZE_APPLICATION_KEY" . backblaze-application-key)
("BACKBLAZE_BUCKET_URL" . backblaze-bucket-url)
("RESTIC_PASSWORD" . "foodisgood")))))
(with-output-to-file "deploy/config/production.tfvars"
(lambda ()
(map (lambda (e)
(write-config-entry (car e) (cdr e)))
`(("server_type" . digitalocean-size)
("do_token" . digitalocean-api-token)
("cloudflare_api_token" . cloudflare-api-token)
("cloudflare_zone_id" . cloudflare-zone-id)
("cloudflare_account_id" . cloudflare-account-id)
("cluster_name" . "mycluster")
("datacenter" . digitalocean-region)
("flatcar_stable_version" . "4230.2.3")))
(display "ssh_keys=[\"") (display (with-input-from-file "deploy/config/ssh-keys" read-string)) (print "\"]")))
(change-directory "deploy")
(session-set! "pid" (process-run "make apply > make-out"))
(change-directory "../")
(schematra:redirect "/config/wizard/success"))
(get
("/config/wizard/success")
(receive (pid exit-normal status) (process-wait (session-get "pid") #t) ;; TODO should not rely on the user refreshing page to process-wait since that could create zombie
`(VStack
(h1
,(if (= pid 0)
"Deployment in progress"
(if exit-normal
"Deployment complete!"
"Deployment failed")))
,@(intersperse
(with-input-from-file "deploy/make-out"
(lambda ()
(letrec ((loop (lambda (out)
(let ((v (read-line)))
(if (eq? v #!eof)
out
(loop (cons v out)))))))
(reverse (loop '())))))
`(br)))))
(schematra:schematra-install)
(schematra:schematra-start)
Write Preview
Loading…
Cancel
Save