1954 lines
104 KiB
Scheme
1954 lines
104 KiB
Scheme
;; (load "src/db.scm")
|
||
;; (load "src/mocks.scm")
|
||
(include "db")
|
||
(include "mocks")
|
||
|
||
(import (chicken string)
|
||
(chicken port)
|
||
(chicken io)
|
||
(chicken pretty-print)
|
||
(chicken process)
|
||
(chicken process-context)
|
||
(chicken irregex)
|
||
(chicken file)
|
||
(chicken condition)
|
||
(chicken sort)
|
||
|
||
(rename srfi-1 (delete srfi1:delete))
|
||
srfi-13
|
||
srfi-18
|
||
srfi-19
|
||
srfi-158
|
||
srfi-194
|
||
|
||
html-widgets
|
||
sxml-transforms
|
||
schematra
|
||
schematra.body-parser
|
||
uri-common
|
||
http-client
|
||
medea
|
||
intarweb
|
||
nassella-db
|
||
sql-null
|
||
openssl
|
||
spiffy
|
||
hmac
|
||
sha256-primitive
|
||
string-hexadecimal)
|
||
|
||
(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)))))
|
||
|
||
(define test-user-id (make-parameter 1))
|
||
|
||
(define (authelia-auth-middleware next)
|
||
(cond-expand
|
||
(dev
|
||
(current-params (append `((user-id . ,(test-user-id)) (username . "me")) (current-params)))
|
||
(next))
|
||
(else
|
||
(let* ((request (current-request))
|
||
(headers (request-headers request))
|
||
(remote-user (header-value 'remote-user headers))
|
||
(uri (request-uri request))
|
||
(path (uri-path uri)))
|
||
(if remote-user
|
||
(begin
|
||
(current-params (append `((user-id . ,(with-db/transaction
|
||
(lambda (db)
|
||
(get-user-id-by-username db remote-user))))
|
||
(username . ,remote-user))
|
||
(current-params)))
|
||
(next))
|
||
(if (and (cdr path) (cadr path) (string=? "unsecured" (cadr path)))
|
||
(next)
|
||
(begin (log-to (debug-log) "no valid auth header | ~S | ~A" path headers)
|
||
'(unauthorized "no valid auth header"))))))))
|
||
|
||
(with-schematra-app app
|
||
(lambda ()
|
||
(use-middleware! authelia-auth-middleware)))
|
||
|
||
(define (session-user-id)
|
||
(alist-ref 'user-id (current-params)))
|
||
|
||
(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
|
||
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)))
|
||
|
||
;; TODO change username to to a prod API key that has read access
|
||
;; to the checkout session
|
||
(define (send-stripe-request #!key (method 'GET) endpoint (body #f) (username ""))
|
||
(define api-endpoint "https://api.stripe.com/")
|
||
(define api-version "/v1")
|
||
|
||
(with-input-from-request
|
||
(make-request method: method
|
||
uri: (uri-reference (string-append api-endpoint api-version endpoint))
|
||
headers: (headers `((authorization . (#(basic ((username . ,username) (password . ""))))))))
|
||
body
|
||
read-json))
|
||
|
||
(define (stripe-session-email sid)
|
||
(alist-ref
|
||
'email
|
||
(alist-ref
|
||
'customer_details
|
||
(send-stripe-request endpoint: (string-append "/checkout/sessions/" sid)
|
||
username: (string-trim-right (with-input-from-file "/run/secrets/nassella_stripe_api_key" read-string))))))
|
||
|
||
|
||
(define (create-lldap-user username email)
|
||
;; query = mutation createUser($user:CreateUserInput!){createUser(user:$user){id email displayName firstName lastName avatar}}
|
||
;; variables = {\"user\":{\"id\":\"${id}\",\"email\":\"${email}\",\"displayName\":\"${name}\",\"firstName\":\"${firstName}\",\"lastName\":\"${lastName}\",\"avatar\":\"
|
||
;; data="{\"query\":\"${query}\",\"variables\":${variables}"
|
||
;; http://localhost:17170/api/graphql
|
||
;; -H 'Content-Type: application/json' \
|
||
;; -H "Authorization: Bearer $token" \
|
||
(let ((api-token
|
||
(alist-ref
|
||
'token
|
||
(with-input-from-request
|
||
(make-request method: 'POST
|
||
uri: (uri-reference "http://nassella_lldap:17170/auth/simple/login")
|
||
headers: (headers `((content-type application/json))))
|
||
(lambda ()
|
||
(write-json
|
||
`((username . "admin") (password . ,(string-trim-right (with-input-from-file "/run/secrets/nassella_lldap_admin_password" read-string)))))) ;; trim to remove newline
|
||
read-json))))
|
||
(with-input-from-request
|
||
(make-request method: 'POST
|
||
uri: (uri-reference "http://nassella_lldap:17170/api/graphql")
|
||
headers: (headers `((content-type application/json)
|
||
(authorization #(,(string-append "Bearer " api-token) raw)))))
|
||
(lambda ()
|
||
(write-json
|
||
`((query . "mutation createUser($user:CreateUserInput!){createUser(user:$user){id email displayName firstName lastName avatar}}")
|
||
(variables . ((user . ((id . ,username)
|
||
(email . ,email))))))))
|
||
read-json)))
|
||
|
||
(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 instance-id)
|
||
(string-append "deploy-" (number->string user-id) "-" (->string instance-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"))
|
||
(cond-expand
|
||
(dev
|
||
;; in dev copy personal ssh key
|
||
(copy-file "../config/ssh-keys" (string-append dir "/config/ssh-keys")))
|
||
(else '()))
|
||
(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.
|
||
(cond-expand
|
||
(dev
|
||
(create-directory key-path)
|
||
(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")))
|
||
(else
|
||
(process* "ssh-keygen" `("-t" "ed25519" "-f" ,(conc (current-directory) "/" key-path "/key") "-N" "\"\""))))
|
||
(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)
|
||
(if exit-normal
|
||
(begin
|
||
(with-input-from-port in-port read-string) ;; left here for debugging and to clear ports
|
||
(with-input-from-port err-port read-string)
|
||
;; left here for debugging and to clear ports
|
||
(let ((priv-key (with-input-from-file (conc key-path "/key") read-string))
|
||
(pub-key (with-input-from-file (conc key-path "/key.pub") read-string)))
|
||
(delete-directory key-path #t)
|
||
(list priv-key pub-key)))
|
||
(begin (log-to (debug-log) "generate-ssh-key: docker command error")
|
||
(error "Generating ssh key docker command had abnormal exit"))))))))))
|
||
(thread-join! thread)))))
|
||
|
||
(define (generate-restic-password)
|
||
(generator->string (gtake (make-random-char-generator
|
||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
|
||
30)))
|
||
|
||
(define (generate-jwt-secret)
|
||
(generator->string (gtake (make-random-char-generator
|
||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
|
||
32)))
|
||
|
||
(define (generate-key-seed)
|
||
(generator->string (gtake (make-random-char-generator
|
||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
|
||
32)))
|
||
|
||
(define (generate-authelia-key-seed)
|
||
(generator->string (gtake (make-random-char-generator
|
||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
|
||
64)))
|
||
|
||
(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)))
|
||
|
||
;; example return value
|
||
;; (((time . "2026-04-22T22:24:41.701047574Z") (tree . "42c8556ee6ff87eb2b69a7bc23350026182bc015d7f32ec646d9540f43461754") (paths "/nassella") (hostname . "f042d0fae493") (username . "root") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-22T22:24:41.701047574Z") (backup_end . "2026-04-22T22:24:51.006181344Z") (files_new . 4069) (files_changed . 0) (files_unmodified . 0) (dirs_new . 108) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 1346) (tree_blobs . 67) (data_added . 69399644) (data_added_packed . 11545191) (total_files_processed . 4069) (total_bytes_processed . 146529878)) (id . "77e70711caca6774dabc255dd63dfcaa788c1bd2c1536fda133442e2b5164473") (short_id . "77e70711")) ((time . "2026-04-23T10:00:05.876773568Z") (tree . "5a1650880a1e688576f941b37892617fcb43022b103a7394d994833b6b05ae75") (paths "/nassella") (hostname . "c4e48b3a29e9") (username . "root") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-23T10:00:05.876773568Z") (backup_end . "2026-04-23T10:00:15.208834993Z") (files_new . 4069) (files_changed . 0) (files_unmodified . 0) (dirs_new . 108) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 21) (tree_blobs . 46) (data_added . 2903468) (data_added_packed . 470424) (total_files_processed . 4069) (total_bytes_processed . 146503956)) (id . "312e57caf39295ef7be69569631232f2b1b445322636091d63c2082b48b09079") (short_id . "312e57ca")) ((time . "2026-04-24T01:41:40.890895516Z") (tree . "4367a5665a1c6ebb9ea5ddbe40485d58485d3610a7a07a9e22ee0bfea0f044cc") (paths "/nassella") (hostname . "7d01b0ae1b2e") (username . "root") (tags "daily_automatic") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-24T01:41:40.890895516Z") (backup_end . "2026-04-24T01:41:46.743356138Z") (files_new . 4074) (files_changed . 0) (files_unmodified . 0) (dirs_new . 111) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 29) (tree_blobs . 51) (data_added . 3009785) (data_added_packed . 481008) (total_files_processed . 4074) (total_bytes_processed . 146593600)) (id . "5e7c5f51c46aee69b85e30fade3d6a3b83d07bbe6fa112c75b759966d8848376") (short_id . "5e7c5f51")) ((time . "2026-04-24T10:00:00.956302962Z") (tree . "6edaa49535f5ed860f19c8790d6e4db23b8f79c1b8eb40ac59e73ff524522305") (paths "/nassella") (hostname . "11d8deac4263") (username . "root") (tags "daily_automatic") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-24T10:00:00.956302962Z") (backup_end . "2026-04-24T10:00:07.649733529Z") (files_new . 4074) (files_changed . 0) (files_unmodified . 0) (dirs_new . 112) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 22) (tree_blobs . 68) (data_added . 4097676) (data_added_packed . 601696) (total_files_processed . 4074) (total_bytes_processed . 146594976)) (id . "50f613854ed4d521b596af4435ba4e3f17587124d0a0de248b19f6052117a689") (short_id . "50f61385")) ((time . "2026-04-25T10:00:01.061830384Z") (tree . "ac797c256a6ee09f51ed504c4234e1ced6cef8e1845c67424618658ea6d55abe") (paths "/nassella") (hostname . "f03ffbd8dfe9") (username . "root") (tags "daily_automatic") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-25T10:00:01.061830384Z") (backup_end . "2026-04-25T10:00:07.594710184Z") (files_new . 4074) (files_changed . 0) (files_unmodified . 0) (dirs_new . 112) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 21) (tree_blobs . 49) (data_added . 2899995) (data_added_packed . 474478) (total_files_processed . 4074) (total_bytes_processed . 146594977)) (id . "7cb5b3badbcebf8222efe863d61371d8d5017f9df8eeecef42a05125fa33555f") (short_id . "7cb5b3ba")) ((time . "2026-04-26T10:00:01.071960675Z") (tree . "63f60b2b42909fe374a4db97c6dae53b382e69480f17ca1e6b26f218d859d328") (paths "/nassella") (hostname . "6a7def9f0992") (username . "root") (tags "daily_automatic") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-26T10:00:01.071960675Z") (backup_end . "2026-04-26T10:00:07.762125559Z") (files_new . 4074) (files_changed . 0) (files_unmodified . 0) (dirs_new . 112) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 22) (tree_blobs . 49) (data_added . 2900108) (data_added_packed . 474994) (total_files_processed . 4074) (total_bytes_processed . 146594979)) (id . "f6436aee79cfc8b70d49e81479a46ddce0614e81804607fc1f35a15079e7fe82") (short_id . "f6436aee")))
|
||
|
||
(define (restic-snapshots user-id instance-id)
|
||
(let* ((password-path (conc "restic-password-" user-id "-" instance-id))
|
||
(res
|
||
(with-db/transaction
|
||
(lambda (db)
|
||
`((restic-password . ,(get-instance-restic-password db user-id instance-id))
|
||
(service-config . ,(get-user-service-config db user-id instance-id))))))
|
||
(restic-password (alist-ref 'restic-password res))
|
||
(service-config (alist-ref 'service-config res)))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(with-output-to-file password-path (lambda () (display restic-password))))
|
||
(lambda ()
|
||
(receive (in-port out-port pid err-port)
|
||
(cond-expand
|
||
(dev
|
||
(process* "docker" `("run" "--rm" "--volume"
|
||
,(conc (current-directory) "/" password-path ":/restic-password")
|
||
"-e" ,(conc "AWS_ACCESS_KEY_ID="
|
||
(alist-ref 'backblaze-key-id service-config))
|
||
"-e" ,(conc "AWS_SECRET_ACCESS_KEY="
|
||
(alist-ref 'backblaze-application-key service-config))
|
||
"-i" "restic/restic:0.18.0" "snapshots"
|
||
"--repo" ,(conc "s3:" (alist-ref 'backblaze-bucket-url service-config))
|
||
"--password-file" "/restic-password"
|
||
"--json")))
|
||
(else
|
||
(process* "restic"
|
||
`("snapshots"
|
||
"--repo" ,(conc "s3:" (alist-ref 'backblaze-bucket-url service-config))
|
||
"--password-file" password-path
|
||
"--json")
|
||
`(("AWS_ACCESS_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
|
||
("AWS_SECRET_ACCESS_KEY" . ,(alist-ref 'backblaze-application-key service-config))))))
|
||
(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)
|
||
(if exit-normal
|
||
(let ((res (with-input-from-port in-port read-json)))
|
||
;; left here for debugging and to clear ports
|
||
(with-input-from-port err-port read-string)
|
||
res)
|
||
(begin (log-to (debug-log) "restic-snapshots: docker command error")
|
||
(error "restic-snapshots docker command had abnormal exit"))))))))))
|
||
(thread-join! thread))))
|
||
(lambda ()
|
||
(delete-file password-path)))))
|
||
|
||
;; TODO is this actually needed?
|
||
(single-headers (cons 'X-Nassella-Signature (single-headers)))
|
||
(header-parsers (cons `(X-Nassella-Signature . ,(single identity)) (header-parsers)))
|
||
|
||
(define (send-instance-control-command domain subdomain command secret-key data)
|
||
(let ((json (json->string data)))
|
||
(with-input-from-request
|
||
(make-request method: 'POST
|
||
uri: (uri-reference (conc "https://" subdomain "." domain "/hooks/" command))
|
||
headers: (headers `((content-type application/json)
|
||
(X-Nassella-Signature
|
||
#(,(string->hex ((hmac secret-key (sha256-primitive)) json))
|
||
())))))
|
||
(lambda ()
|
||
(write-json data))
|
||
read-json)))
|
||
|
||
(with-schematra-app app
|
||
(lambda ()
|
||
|
||
;;; UNSECURED PAGES
|
||
(get/widgets
|
||
("/unsecured/account/create")
|
||
`(App
|
||
(form
|
||
(@ (action "/unsecured/account/create-submit") (method POST))
|
||
(VStack
|
||
(Fieldset
|
||
(@ (title "Account Details"))
|
||
(Field (@ (name "username") (label ("Username"))))
|
||
(input (@ (type "hidden") (name "sid") (value ,(alist-ref 'sid (current-params) equal?))))
|
||
(Button (@ (type "submit")) "Create Account"))))))
|
||
|
||
(post "/unsecured/account/create-submit"
|
||
(let ((email (stripe-session-email (alist-ref 'sid (current-params))))
|
||
(username (alist-ref 'username (current-params))))
|
||
(create-lldap-user username email)
|
||
(with-db/transaction (lambda (db) (create-user db email username))))
|
||
(redirect "/authelia/reset-password"))
|
||
|
||
;;; REQUIRES AUTHED USER
|
||
(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")) (type "password")
|
||
(value ,(alist-ref 'cloudflare-api-token config))))
|
||
(Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (type "password")
|
||
(value ,(alist-ref 'cloudflare-zone-id config))))
|
||
(Field (@ (name "cloudflare-account-id") (label ("Account ID")) (type "password")
|
||
(value ,(alist-ref 'cloudflare-account-id config)))))
|
||
(Fieldset
|
||
(@ (title "DigitalOcean"))
|
||
(Field (@ (name "digitalocean-api-token") (label ("API Token")) (type "password")
|
||
(value ,(alist-ref 'digitalocean-api-token config)))))
|
||
(Fieldset
|
||
(@ (title "Backblaze"))
|
||
(Field (@ (name "backblaze-application-key") (label ("Application Key"))
|
||
(type "password")
|
||
(value ,(alist-ref 'backblaze-application-key config))))
|
||
(Field (@ (name "backblaze-key-id") (label ("Key ID")) (type "password")
|
||
(value ,(alist-ref 'backblaze-key-id config))))
|
||
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (type "password")
|
||
(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)))))
|
||
,@(cond-expand
|
||
(dev
|
||
`((Field (@ (name "nassella") (type "checkbox") (label ("Nassella")) (checked ,(member 'nassella (alist-ref 'selected-apps results)))))))
|
||
(else
|
||
'()))
|
||
(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)))
|
||
(nassella . ,(or (and (alist-ref 'nassella (current-params)) "b0.0.1") (sql-null)))
|
||
(instance-control . "b0.0.1")))
|
||
(update-root-domain db
|
||
(session-user-id)
|
||
instance-id
|
||
(alist-ref 'root-domain (current-params)))))
|
||
(redirect (conc "/config/wizard/apps2/" instance-id))))
|
||
|
||
(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? ""))))))
|
||
'())
|
||
,@(if (member 'nassella selected-apps)
|
||
`((Fieldset
|
||
(@ (title "Nassella"))
|
||
(Field (@ (name "nassella-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'nassella app-config eq? '()) eq? "app"))))
|
||
(Field (@ (name "nassella-lldap-subdomain") (label ("LLDAP Subdomain"))
|
||
(value ,(alist-ref 'lldap-subdomain (alist-ref 'nassella app-config eq? '()) eq? "lldap"))))
|
||
(Field (@ (name "nassella-lldap-admin-password") (label ("Admin Password")) (type "password")
|
||
(value ,(alist-ref 'lldap-admin-password (alist-ref 'nassella app-config eq? '()) eq? ""))))
|
||
(Field (@ (name "nassella-stripe-api-key") (label ("Stripe API Key")) (type "password")
|
||
(value ,(alist-ref 'stripe-api-key (alist-ref 'nassella 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) (member 'nassella 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)))))
|
||
(nassella . ((subdomain . ,(alist-ref 'nassella-subdomain (current-params)))
|
||
(postgres-password . ,(or (alist-ref 'postgres-password
|
||
(alist-ref 'nassella config eq? '()))
|
||
(generate-postgres-password)))
|
||
(authelia-postgres-password . ,(or (alist-ref 'authelia-postgres-password
|
||
(alist-ref 'nassella config eq? '()))
|
||
(generate-postgres-password)))
|
||
(lldap-postgres-password . ,(or (alist-ref 'lldap-postgres-password
|
||
(alist-ref 'nassella config eq? '()))
|
||
(generate-postgres-password)))
|
||
(lldap-jwt-secret . ,(or (alist-ref 'lldap-jwt-secret
|
||
(alist-ref 'nassella config eq? '()))
|
||
(generate-jwt-secret)))
|
||
(lldap-key-seed . ,(or (alist-ref 'lldap-key-seed
|
||
(alist-ref 'nassella config eq? '()))
|
||
(generate-key-seed)))
|
||
(lldap-subdomain . ,(alist-ref 'nassella-lldap-subdomain (current-params)))
|
||
(lldap-admin-password . ,(alist-ref 'nassella-lldap-admin-password (current-params)))
|
||
(stripe-api-key . ,(alist-ref 'nassella-stripe-api-key (current-params)))
|
||
(authelia-jwt-secret . ,(or (alist-ref 'authelia-jwt-secret
|
||
(alist-ref 'nassella config eq? '()))
|
||
(generate-jwt-secret)))
|
||
(authelia-key-seed . ,(or (alist-ref 'authelia-key-seed
|
||
(alist-ref 'nassella config eq? '()))
|
||
(generate-authelia-key-seed)))))
|
||
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
|
||
(user . ,(alist-ref 'log-viewer-user (current-params)))
|
||
(password . ,(alist-ref 'log-viewer-password (current-params)))))
|
||
(all-apps . ((smtp-host . ,(alist-ref 'smtp-host (current-params)))
|
||
(smtp-port . ,(alist-ref 'smtp-port (current-params)))
|
||
(smtp-auth-user . ,(alist-ref 'smtp-auth-user (current-params)))
|
||
(smtp-auth-password . ,(alist-ref 'smtp-auth-password (current-params)))
|
||
(smtp-from . ,(alist-ref 'smtp-from (current-params)))))
|
||
(instance-control . ((subdomain . "nassella-instance-control")
|
||
(webhooks-secret . ,(or (alist-ref 'webhooks-secret
|
||
(alist-ref 'instance-control config eq? '()))
|
||
(generate-jwt-secret))))))))))
|
||
(redirect (conc "/config/wizard/machine/" instance-id))))
|
||
|
||
(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") ;; TODO if an app that was previously selected is now unselected we need to somehow delete its data
|
||
;; so that if the user then re-deploys the app later we don't have key conflicts
|
||
(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 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?))
|
||
(status (string->symbol
|
||
(->string
|
||
(with-db/transaction
|
||
(lambda (db)
|
||
(get-most-recent-deployment-status db (session-user-id) instance-id)))))))
|
||
(when (not (or (eq? status 'queued) (eq? status 'in-progress)))
|
||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||
(restic-snapshot-id (alist-ref 'restic-snapshot-id (current-params)))
|
||
(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) instance-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)))
|
||
("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config)))
|
||
("NASSELLA_POSTGRES_DB" . "nassella")
|
||
("NASSELLA_POSTGRES_USER" . "nassella")
|
||
("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config)))
|
||
("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia")
|
||
("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia")
|
||
("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config)))
|
||
("NASSELLA_LLDAP_POSTGRES_DB" . "lldap")
|
||
("NASSELLA_LLDAP_POSTGRES_USER" . "lldap")
|
||
("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config)))
|
||
("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config)))
|
||
("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config)))
|
||
("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config)))
|
||
("NASSELLA_STRIPE_API_KEY" . ,(alist-ref 'stripe-api-key (alist-ref 'nassella config)))
|
||
("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config)))
|
||
("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella config)))
|
||
("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
|
||
("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
|
||
("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
|
||
("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
|
||
("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
|
||
("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
|
||
("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
|
||
("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
|
||
("RESTIC_PASSWORD" . ,restic-password)
|
||
("INSTANCE_CONTROL_WEBHOOKS_SECRET" . ,(alist-ref 'webhooks-secret (alist-ref 'instance-control config)))
|
||
,@(if (and restic-snapshot-id (not (string=? restic-snapshot-id ""))) `(("RESTIC_SNAPSHOT_ID" . ,restic-snapshot-id)) '())))))
|
||
(with-output-to-file (string-append dir "/config/production.tfvars")
|
||
(lambda ()
|
||
(map (lambda (e)
|
||
(write-config-entry (car e) (cdr e)))
|
||
`(("server_type" . ,(alist-ref 'digitalocean-size service-config))
|
||
("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
|
||
("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
|
||
("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
|
||
("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
|
||
("cluster_name" . "nassella")
|
||
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
|
||
;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
|
||
("flatcar_stable_version" . "4593.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 instance-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 instance-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 instance-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) instance-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)))
|
||
;; TODO update links
|
||
'((wg-easy . "https://wg-easy.github.io/wg-easy/Pre-release/")
|
||
(nextcloud . "https://nextcloud.com/support/")
|
||
(ghost . "https://nextcloud.com/support/")
|
||
(nassella . "https://nextcloud.com/support/")
|
||
(log-viewer . "https://nextcloud.com/support/")
|
||
;; (instance-control . "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 (a (@ (href "/backups/" ,(alist-ref 'instance-id instance)))
|
||
"Manage Backups"))
|
||
(li (a (@ (href "/destroy/" ,(alist-ref 'instance-id instance)))
|
||
"Destroy - deletes data and configuration (confirmation required)"))
|
||
(li (a (@ (href "/reset/" ,(alist-ref 'instance-id instance)))
|
||
"Reset - deletes data (confirmation required)")))))))
|
||
(with-db/transaction
|
||
(lambda (db)
|
||
(get-dashboard db (session-user-id))))))))))
|
||
|
||
(get/widgets
|
||
("/destroy/:id")
|
||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||
(root-domain
|
||
(with-db/transaction
|
||
(lambda (db)
|
||
(alist-ref 'root-domain (get-user-app-config db (session-user-id) instance-id))))))
|
||
`(App
|
||
(h2 "Destroy Instance")
|
||
,root-domain
|
||
(h2 "This action is NOT reversible. All data will be lost!")
|
||
(form
|
||
(@ (action ,(conc "/destroy-submit/" instance-id)) (method POST))
|
||
(VStack
|
||
(Fieldset
|
||
(@ (title "Type the domain name of the instance to confirm."))
|
||
(Field (@ (name "instance-domain") (label ("Domain")) (value ""))))
|
||
(Form-Nav (@ (back-to "/dashboard") (submit-button "Destroy"))))))))
|
||
|
||
;; TODO This is mostly a copy of the deployment POST action
|
||
(post "/destroy-submit/:id"
|
||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||
(results
|
||
(with-db/transaction
|
||
(lambda (db)
|
||
`((selected-apps . ,(map
|
||
car
|
||
(filter cdr
|
||
(get-user-selected-apps db (session-user-id) instance-id))))
|
||
(app-config . ,(get-user-app-config db (session-user-id) instance-id))
|
||
(service-config . ,(get-user-service-config db (session-user-id) instance-id))
|
||
(terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))
|
||
(ssh-pub-key . ,(get-instance-ssh-pub-key db (session-user-id) instance-id))
|
||
(restic-password . ,(get-instance-restic-password db (session-user-id) instance-id))))))
|
||
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
|
||
(app-config (alist-ref 'app-config results))
|
||
(config (alist-ref 'config app-config))
|
||
(root-domain (alist-ref 'root-domain app-config))
|
||
(service-config (alist-ref 'service-config results))
|
||
(terraform-state (alist-ref 'terraform-state results))
|
||
(ssh-pub-key (alist-ref 'ssh-pub-key results))
|
||
(restic-password (alist-ref 'restic-password results))
|
||
(dir (deployment-directory (session-user-id) instance-id)))
|
||
(if (not (string=? (alist-ref 'instance-domain (current-params)) root-domain))
|
||
(redirect (conc "/destroy/" instance-id))
|
||
(begin
|
||
(setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
|
||
(with-output-to-file (string-append dir "/config/apps.config")
|
||
(lambda ()
|
||
(map (lambda (e)
|
||
(write-config-entry (car e) (cdr e)))
|
||
`(("ROOT_DOMAIN" . ,root-domain)
|
||
("APP_CONFIGS" . ,(string-intersperse
|
||
(map (lambda (app)
|
||
(conc (if (eq? app 'log-viewer) 'dozzle app)
|
||
","
|
||
(alist-ref 'subdomain (alist-ref app config))))
|
||
selected-apps)
|
||
" "))
|
||
("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
|
||
("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config)))
|
||
("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
|
||
("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
|
||
("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
|
||
("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
|
||
("NEXTCLOUD_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nextcloud config)))
|
||
("NEXTCLOUD_REDIS_PASSWORD" . ,(alist-ref 'redis-password (alist-ref 'nextcloud config)))
|
||
("GHOST_DATABASE_ROOT_PASSWORD" . ,(alist-ref 'postgres-root-password (alist-ref 'ghost config)))
|
||
("GHOST_DATABASE_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'ghost config)))
|
||
("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config)))
|
||
("NASSELLA_POSTGRES_DB" . "nassella")
|
||
("NASSELLA_POSTGRES_USER" . "nassella")
|
||
("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config)))
|
||
("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia")
|
||
("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia")
|
||
("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config)))
|
||
("NASSELLA_LLDAP_POSTGRES_DB" . "lldap")
|
||
("NASSELLA_LLDAP_POSTGRES_USER" . "lldap")
|
||
("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config)))
|
||
("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config)))
|
||
("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config)))
|
||
("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config)))
|
||
("NASSELLA_STRIPE_API_KEY" . ,(alist-ref 'stripe-api-key (alist-ref 'nassella config)))
|
||
("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config)))
|
||
("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella config)))
|
||
("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
|
||
("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
|
||
("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
|
||
("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
|
||
("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
|
||
("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
|
||
("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
|
||
("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
|
||
("RESTIC_PASSWORD" . ,restic-password)
|
||
("INSTANCE_CONTROL_WEBHOOKS_SECRET" . ,(alist-ref 'webhooks-secret (alist-ref 'instance-control config)))))))
|
||
(with-output-to-file (string-append dir "/config/production.tfvars")
|
||
(lambda ()
|
||
(map (lambda (e)
|
||
(write-config-entry (car e) (cdr e)))
|
||
`(("server_type" . ,(alist-ref 'digitalocean-size service-config))
|
||
("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
|
||
("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
|
||
("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
|
||
("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
|
||
("cluster_name" . "nassella")
|
||
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
|
||
;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
|
||
("flatcar_stable_version" . "4593.2.1")))
|
||
;; remove the newline that generating the ssh key adds
|
||
(display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]")))
|
||
;; TODO need a new table to track destroying?
|
||
;; as this is creating a new "deployment"
|
||
;; to attach state to
|
||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||
(user-id (session-user-id))
|
||
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
|
||
(dir (deployment-directory user-id instance-id)))
|
||
(thread-start!
|
||
(lambda ()
|
||
(change-directory dir)
|
||
(let ((pid (process-run "make destroy > make-out 2>&1")))
|
||
(with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
|
||
(change-directory "../")
|
||
(let loop ()
|
||
(thread-sleep! 5)
|
||
(receive (pid exit-normal status) (process-wait pid #t)
|
||
(if (= pid 0) ;; process is still running
|
||
(begin (let ((progress (parse-deployment-log
|
||
(with-input-from-file
|
||
(string-append (deployment-directory user-id instance-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 instance-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))
|
||
(when exit-normal
|
||
(destroy-instance db instance-id))))))))))))
|
||
(redirect (conc "/destroy-success/" (alist-ref "id" (current-params) equal?)))))))
|
||
|
||
(get/widgets
|
||
("/destroy-success/:id"
|
||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||
(res (with-db/transaction
|
||
(lambda (db)
|
||
`((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))))))
|
||
(status (or (and (alist-ref 'status res) (string->symbol (alist-ref 'status res))) 'destroyed)))
|
||
(if (or (eq? status 'complete) (eq? status 'failed) (eq? status 'destroyed))
|
||
'()
|
||
'((meta (@ (http-equiv "refresh") (content "5")))))))
|
||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||
(res (with-db/transaction
|
||
(lambda (db)
|
||
`((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))
|
||
(progress . ,(get-most-recent-deployment-progress db (session-user-id) instance-id))))))
|
||
(output (with-input-from-file (string-append (deployment-directory (session-user-id) instance-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) "Destroy queued")
|
||
((in-progress) "Destroy in progress")
|
||
((destroyed) "Destroy complete!")
|
||
((failed) "Destroy failed")))
|
||
,@(if (eq? status 'destroyed)
|
||
'((a (@ (href "/dashboard")) "Dashboard"))
|
||
`((ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
|
||
(li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
|
||
(li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress)))
|
||
(li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
|
||
(div
|
||
(a (@ (href "/dashboard")) "Dashboard")
|
||
,@(if (or (eq? (string->symbol status) 'complete) (eq? (string->symbol status) 'failed))
|
||
'()
|
||
" (deployment will continue in the background if you leave this page)"))
|
||
(hr)
|
||
(pre (@ (style ((overflow-x "scroll"))))
|
||
,output)))
|
||
)))))
|
||
|
||
(define (roundx n)
|
||
(/ (round (* 10 n)) 10.0))
|
||
|
||
;; The restic date doesn't parse well all the time with srfi-19
|
||
;; so we remove the nanoseconds and set it to UTC (which it is)
|
||
(define (normalize-restic-date s) (string-append (string-take s (string-index s #\.)) "Z+00:00"))
|
||
(define (restic-date-string->date s) (string->date (normalize-restic-date s) "~Y-~m-~dT~H:~M:~S~z"))
|
||
|
||
(get/widgets
|
||
("/backups/:id")
|
||
(let* ((instance-id (alist-ref "id" (current-params) equal?))
|
||
(bytes-in-mib 1048576.0))
|
||
`(App
|
||
(Main-Container
|
||
(VStack
|
||
(h1 "Backups")
|
||
(a (@ (href ,(conc "/backups/" instance-id "/create"))) "Create Snapshot")
|
||
(table
|
||
(thead
|
||
(tr (th "Time") (th "Total Size (MiB)") (th "Tag") (th "*")))
|
||
(tbody
|
||
,@(map (lambda (snapshot)
|
||
`(tr
|
||
(td ,(alist-ref 'time snapshot))
|
||
(td ,(roundx
|
||
(/ (or (alist-ref 'total_bytes_processed (alist-ref 'summary snapshot)) 0) bytes-in-mib)))
|
||
(td ,(or (alist-ref 'tags snapshot) ""))
|
||
(td (a (@ (href ,(conc "/backups/" instance-id "/restore/"
|
||
(alist-ref 'short_id snapshot))))
|
||
"Restore"))))
|
||
(sort
|
||
(restic-snapshots (session-user-id) instance-id)
|
||
(lambda (a b) (date>? (restic-date-string->date (alist-ref 'time a))
|
||
(restic-date-string->date (alist-ref 'time b)))))))))))))
|
||
|
||
(get/widgets
|
||
("/backups/:instance_id/restore/:restic_id")
|
||
(let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
|
||
(restic-id (alist-ref "restic_id" (current-params) equal?))
|
||
(snapshot-info (find (lambda (snapshot)
|
||
(string=? (alist-ref 'short_id snapshot) restic-id))
|
||
(restic-snapshots (session-user-id) instance-id)))
|
||
(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
|
||
(Main-Container
|
||
(VStack
|
||
(h1 "Instance Snapshot Restore")
|
||
(ul (li "Snapshot date: " ,(alist-ref 'time snapshot-info))
|
||
(li "Snapshot tags: " ,(alist-ref 'tags snapshot-info)))
|
||
(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))
|
||
(Field (@ (name "restic-snapshot-id") (type "hidden") (value ,restic-id)))
|
||
(VStack
|
||
(Form-Nav (@ (back-to ,(conc "/backups/" instance-id)) (submit-button "Restore"))))))))))
|
||
|
||
(get/widgets
|
||
("/backups/:instance_id/create")
|
||
(let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
|
||
(root-domain (alist-ref 'root-domain
|
||
(with-db/transaction
|
||
(lambda (db)
|
||
(get-user-app-config db (session-user-id) instance-id))))))
|
||
`(App
|
||
(Main-Container
|
||
(VStack
|
||
(h1 "Create Snapshot")
|
||
(h2 "Root Domain")
|
||
,root-domain
|
||
(form
|
||
(@ (action ,(conc "/backups/" instance-id "/create-submit")) (method POST))
|
||
(Fieldset (@ (title "Snapshot Properties"))
|
||
(Field (@ (name "tag") (label ("Tag")))))
|
||
(VStack
|
||
(Form-Nav (@ (back-to ,(conc "/backups/" instance-id)) (submit-button "Create"))))))))))
|
||
|
||
(post "/backups/:instance_id/create-submit"
|
||
(let ((instance-id (alist-ref "instance_id" (current-params) equal?))
|
||
(app-config (with-db/transaction
|
||
(lambda (db)
|
||
(get-user-app-config db (session-user-id) instance-id)))))
|
||
;; TODO make requests to instance control
|
||
;; get the root domain and subdomain for instance control
|
||
;; then call subdomain.rootdomain/hooks/queue-restic-snapshot
|
||
;; content-type application/json
|
||
;; data: 'path "/" 'tag tag 'request_id (generate-one?) 'version 0
|
||
;; then run through hmac ((hmac "instance-control-secret-key" sha256-primitive) data)
|
||
;; then make a new page to redirect the user to that polls for status page using the request id
|
||
(redirect (conc "/config/wizard/review/" instance-id))))
|
||
|
||
(schematra-install)
|
||
|
||
))
|