Adding web app.
parent
84eee0820c
commit
8595014fde
@ -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)
|
||||||
Loading…
Reference in New Issue