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