nassella/app
1
0
Fork 0
Code Issues 33 Pull Requests Packages Projects 1 Releases Wiki Activity
Files
1ff8b5348ded314b815c155958626b6374eb4e77
app/src/nassella.scm

2208 lines
120 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;; Copyright 2025-2026 Thomas Hintz
;; This file is part of Nassella.
;; Nassella is free software: you can redistribute it and/or modify it under the
;; terms of the GNU Affero General Public License as published by the Free
;; Software Foundation, either version 3 of the License, or (at your option) any
;; later version.
;; Nassella is distributed in the hope that it will be useful, but WITHOUT ANY
;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with Nassella. If not, see <https://www.gnu.org/licenses/>.
;; (import (chicken platform))
;; (register-feature! 'dev)
;; (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)
(chicken random)
(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)))
(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 user-id instance-id key-id application-key bucket-url)
(let* ((password-path (conc "restic-password-" user-id "-" instance-id))
(restic-password
(with-db/transaction
(lambda (db)
(get-instance-restic-password db user-id instance-id)))))
(dynamic-wind
(lambda ()
(with-output-to-file password-path (lambda () (display restic-password))))
(lambda ()
;; restic retries (indefinitely?) if the connection can't be made so
;; we pass it through timeout to ensure it does not hang
(receive (in-port out-port pid err-port)
(cond-expand
(dev
(process* "timeout" `("--preserve-status" "8s" "docker" "run" "--rm" "--volume"
,(conc (current-directory) "/" password-path ":/restic-password")
"-e" ,(conc "AWS_ACCESS_KEY_ID=" key-id)
"-e" ,(conc "AWS_SECRET_ACCESS_KEY=" application-key)
"-i" "restic/restic:0.18.0" "cat" "config"
"--repo" ,(conc "s3:" bucket-url)
"--password-file" "/restic-password"
"--json")))
(else
(process* "timeout"
`("--preserve-status" "8s" "restic" "cat" "config"
"--repo" ,(conc "s3:" bucket-url)
"--password-file" password-path
"--json")
`(("AWS_ACCESS_KEY_ID" . ,key-id)
("AWS_SECRET_ACCESS_KEY" . ,application-key)))))
(let ((thread
(thread-start!
(lambda ()
(let loop ((i 0))
(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
(if (< i 12) ;; 12s timeout
(loop (+ i 1))
(error "timeout trying to connect to to backblaze"))
(if exit-normal
(let ((res (with-input-from-port in-port read-json))
(err (with-input-from-port err-port read-json)))
(if res
`((success . #t)
(result . ,res))
`((success . #f)
(errors ((message . "abnormal exit - check Key ID, Application ID, and Bucket URL"))))))
`((success . #f)
(errors ((message . "abnormal exit - check Key ID, Application ID, and Bucket URL"))))
))))))))
(thread-join! thread))))
(lambda ()
(delete-file password-path)))))
(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 failed)
(cond ((irregex-search failed log)
'failed)
((irregex-search complete log)
'complete)
((irregex-search in-progress log)
'in-progress)
(else 'queued)))
`((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start" "Failed to install provider"))
;; TODO this didn't seem to work right when upgrading the flatcar image
;; log: [0mdigitalocean_custom_image.flatcar: Creating...
;; digitalocean_custom_image.flatcar: Still creating... [00m10s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m20s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m30s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m40s elapsed]
(custom-image . ,(search '(or "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Creation complete")
'(or "custom_image.flatcar: Modifying" "custom_image.flatcar: Creating")
"XXX - nothing"))
(machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..." "XXX - nothing"))
(machine-destroy . ,(search "droplet.machine: Destruction complete"
'(: "droplet.machine (deposed object " (* alphanum) "): Destroying...") "XXX - nothing"))
(ip-destroy . ,(search "reserved_ip_assignment.machine: Destruction complete" "reserved_ip_assignment.machine: Destroying..." "XXX - nothing"))
(ip-create . ,(search "reserved_ip_assignment.machine: Creation complete" "reserved_ip_assignment.machine: Creating..." "Error Assigning reserved IP"))
(volume-create . ,(search "volume_attachment.machine: Creation complete" "volume_attachment.machine: Creating..." "XXX - nothing"))
(volume-destroy . ,(search "volume_attachment.machine: Destruction complete" "volume_attachment.machine: Destroying..." "XXX - nothing"))))
(define (write-config-entry name value)
(display name)
(display "='")
(display (if value
(string-translate* (->string value) '(("'" . "\\'"))) ;; escape any single quotes
""))+
(print "'"))
(define (write-terraform-config-entry name value)
(display name)
(display "=\"")
(display (if value
(string-translate* (->string value) '(("\"" . "\\\""))) ;; escape any double quotes
""))+
(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"))))))
;; https://app.nassella.org/unsecured/account/create?sid={CHECKOUT_SESSION_ID}
(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))))
(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)))
(backblaze-result (test-backblaze-connection (session-user-id) instance-id
(alist-ref 'backblaze-key-id service-config)
(alist-ref 'backblaze-application-key service-config)
(alist-ref 'backblaze-bucket-url 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"))
,@(if (alist-ref 'success backblaze-result)
`((h3 "Connected")
(p "Your Backblaze account was successfully connected!"))
`((h3 "Connection Failed")
(p "Unable to make a connection via Backblaze S3 API. Message is: \""
,(string-intersperse
(map (lambda (err)
(alist-ref 'message err))
(alist-ref 'errors backblaze-result))
"\" & \"")
"\""))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/services/" instance-id))
(submit-enabled ,(and (alist-ref 'success cloudflare-result)
(alist-ref 'success digitalocean-result)
(alist-ref 'success backblaze-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 "wordpress") (type "checkbox") (label ("wordpress")) (checked ,(member 'wordpress (alist-ref 'selected-apps results)))))
(Field (@ (name "lldap") (type "checkbox") (label ("lldap")) (checked ,(member 'lldap (alist-ref 'selected-apps results)))))
(Field (@ (name "authelia") (type "checkbox") (label ("authelia")) (checked ,(member 'authelia (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
(filter (lambda (app/version) (cdr app/version)) ;; filter out unused apps
`((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "15") #f))
(nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "34") #f))
(ghost . ,(or (and (alist-ref 'ghost (current-params)) "6") #f))
(nassella . ,(or (and (alist-ref 'nassella (current-params)) "b0.0.1") #f))
(wordpress . ,(or (and (alist-ref 'wordpress (current-params)) "8.4") #f))
(lldap . ,(or (and (alist-ref 'lldap (current-params)) "0.6.3") #f))
(authelia . ,(or (and (alist-ref 'authelia (current-params)) "4") #f))
(instance-control . "b0.0.1")
(log-viewer . "20"))))
(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? ""))))))
'())
,@(if (member 'wordpress selected-apps)
`((Fieldset
(@ (title "Wordpress"))
(Field (@ (name "wordpress-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'wordpress app-config eq? '()) eq? "wordpress"))))))
'())
,@(if (member 'lldap selected-apps)
`((Fieldset
(@ (title "LLDAP"))
(Field (@ (name "lldap-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'lldap app-config eq? '()) eq? "lldap"))))
(Field (@ (name "lldap-user-email") (label ("Admin Email Address")) (type "email")
(value ,(alist-ref 'user-email (alist-ref 'lldap app-config eq? '()) eq? ""))))
(Field (@ (name "lldap-admin-password") (label ("Admin Password")) (type "password")
(value ,(alist-ref 'admin-password (alist-ref 'lldap app-config eq? '()) eq? ""))))))
'())
,@(if (member 'authelia selected-apps)
`((Fieldset
(@ (title "Authelia"))
(Field (@ (name "authelia-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'authelia app-config eq? '()) eq? "authelia"))))))
'())
(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) (member 'authelia 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)))))
(wordpress . ((subdomain . ,(alist-ref 'wordpress-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'wordpress config eq? '()))
(generate-postgres-password)))
(db-root-password . ,(or (alist-ref 'db-root-password
(alist-ref 'wordpress config eq? '()))
(generate-postgres-password)))))
(lldap . ((subdomain . ,(alist-ref 'lldap-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'lldap config eq? '()))
(generate-postgres-password)))
(jwt-secret . ,(or (alist-ref 'jwt-secret
(alist-ref 'lldap config eq? '()))
(generate-jwt-secret)))
(key-seed . ,(or (alist-ref 'key-seed
(alist-ref 'lldap config eq? '()))
(generate-key-seed)))
(admin-password . ,(alist-ref 'lldap-admin-password (current-params)))
(user-email . ,(alist-ref 'lldap-user-email (current-params)))))
(authelia . ((subdomain . ,(alist-ref 'authelia-subdomain (current-params)))
(db-password . ,(or (alist-ref 'db-password
(alist-ref 'authelia config eq? '()))
(generate-postgres-password)))
(jwt-secret . ,(or (alist-ref 'jwt-secret
(alist-ref 'authelia config eq? '()))
(generate-jwt-secret)))
(session-secret . ,(or (alist-ref 'session-secret
(alist-ref 'authelia config eq? '()))
(generate-authelia-key-seed)))
(encryption-key . ,(or (alist-ref 'encryption-key
(alist-ref 'authelia 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 "Instance Properties"))
(Field (@ (name "volume-size") (label ("Volume Size in GB (For persistent application storage)"))
(value ,(alist-ref 'digitalocean-volume-size config eq? "60"))))
(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)))
(digitalocean-volume-size . ,(alist-ref 'volume-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 (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))
(input (@ (type "hidden") (value ,(alist-ref 'force (current-params))) (name "force")))
(VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch")))))))))
(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 (or (not (or (eq? status 'queued) (eq? status 'in-progress)))
(equal? (alist-ref 'force (current-params)) "true"))
(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 . ,(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 (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-version)
(conc (if (eq? (car app-version) 'log-viewer) 'dozzle (car app-version))
","
(alist-ref 'subdomain (alist-ref (car app-version) config))
","
(cdr app-version)))
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)))
("WORDPRESS_DB_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'wordpress config)))
("WORDPRESS_DB_ROOT_PASSWORD" . ,(alist-ref 'db-root-password (alist-ref 'wordpress config)))
("LLDAP_POSTGRES_DB" . "lldap")
("LLDAP_POSTGRES_USER" . "lldap")
("LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'lldap config)))
("LLDAP_JWT_SECRET" . ,(alist-ref 'jwt-secret (alist-ref 'lldap config)))
("LLDAP_KEY_SEED" . ,(alist-ref 'key-seed (alist-ref 'lldap config)))
("LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'lldap config)))
("LLDAP_USER_EMAIL" . ,(alist-ref 'user-email (alist-ref 'lldap config)))
("AUTHELIA_POSTGRES_DB" . "authelia")
("AUTHELIA_POSTGRES_USER" . "authelia")
("AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'authelia config)))
("AUTHELIA_JWT_SECRET" . ,(alist-ref 'jwt-secret (alist-ref 'authelia config)))
("AUTHELIA_SESSION_SECRET" . ,(alist-ref 'session-secret (alist-ref 'authelia config)))
("AUTHELIA_ENCRYPTION_KEY" . ,(alist-ref 'encryption-key (alist-ref 'authelia 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-terraform-config-entry (car e) (cdr e)))
`(("server_type" . ,(alist-ref 'digitalocean-size service-config))
("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
("digitalocean_volume_size" . ,(alist-ref 'digitalocean-volume-size 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.4")))
;; 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))
(app-config
(with-db/transaction
(lambda (db)
(get-user-app-config db (session-user-id) instance-id))))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
(dir (deployment-directory user-id instance-id))
(backup-request-id (conc (truncate (time->seconds (current-time))) "-" (pseudo-random-integer 10000))))
(with-db/transaction
(lambda (db)
(update-deployment-progress db deployment-id '((instance-backup . in-progress)))))
;; ;; TODO does this handle new deployments? We should not do a back up if this is new!
(handle-exceptions
exn
(with-db/transaction
(lambda (db)
(update-deployment-progress db deployment-id '((instance-backup . failed)))))
(send-instance-control-command
(alist-ref 'root-domain app-config)
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
"queue-restic-snapshot-no-restart"
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
`((path . "/")
(tag . "automated_pre_instance_update")
;; effectively a guid, we just want something unique
(request_id . ,backup-request-id)
(version . 0))))
(thread-start!
(lambda ()
(let ((start-time (time->seconds (current-time))))
(let loop ()
(thread-sleep! 1)
(let* ((status-result
(handle-exceptions
exn
'((status . "error"))
(send-instance-control-command
(alist-ref 'root-domain app-config)
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
"restic-snapshot-status"
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
`((request_id . ,backup-request-id)
(version . 0)))))
(complete (string=? (alist-ref 'status status-result) "complete")))
(if (or complete (> (- (time->seconds (current-time)) start-time) 120))
(with-db/transaction
(lambda (db)
(update-deployment-progress db deployment-id `((instance-backup . ,(or (and complete 'complete) 'failed))))))
(loop)))))
(change-directory dir)
(let ((pid (process-run "make preapply && 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)
(update-deployment-status
db user-id deployment-id
(if (= status 0) '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 (handle-exceptions exn "" (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 "perform backup: " ,(progress-status->text (alist-ref 'instance-backup progress)))
(li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
(li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
(li "application volume disconnect: " ,(progress-status->text (alist-ref 'volume-destroy progress)))
(li "instance create: " ,(progress-status->text (alist-ref 'machine-create progress)))
(li "instance mapped ip disconnect: " ,(progress-status->text (alist-ref 'ip-destroy progress)))
(li "instance mapped ip connect: " ,(progress-status->text (alist-ref 'ip-create progress)))
(li "application volume connect: " ,(progress-status->text (alist-ref 'volume-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 ,@(map (lambda (app-info)
(let ((app (alist-ref 'app-name app-info)))
`((li (a (@ (href "#")) ,app) ;; TODO documentation URL
" (v" ,(alist-ref 'installed-version app-info) ") "
(a (@ (href "https://"
,(alist-ref 'subdomain (alist-ref app config))
"." ,root-domain))
,(alist-ref 'subdomain (alist-ref app config))
"." ,root-domain)))))
(or (alist-ref 'apps instance) ;; TODO this really should not happen maybe?
'())))
(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.4")))
;; 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)
(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 "attaching : " ,(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))))
(request-id (conc (truncate (time->seconds (current-time))) "-" (pseudo-random-integer 10000))))
(send-instance-control-command
(alist-ref 'root-domain app-config)
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
"queue-restic-snapshot"
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
`((path . "/") ;; unused for now but we do want root until we support backing up individual apps
(tag . ,(alist-ref 'tag (current-params)))
;; effectively a guid, we just want something unique
(request_id . ,request-id)
(version . 0)))
(redirect (conc "/backups/" instance-id "/create-success/" request-id))))
(get/widgets
("/backups/:instance_id/create-success/:request_id"
(let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
(request-id (alist-ref "request_id" (current-params) equal?))
(app-config (with-db/transaction
(lambda (db)
(get-user-app-config db (session-user-id) instance-id))))
(status-result
(send-instance-control-command
(alist-ref 'root-domain app-config)
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
"restic-snapshot-status"
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
`((request_id . ,request-id)
(version . 0))))
(complete (string=? (alist-ref 'status status-result) "complete")))
(if complete
'()
'((meta (@ (http-equiv "refresh") (content "5")))))))
(let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
(request-id (alist-ref "request_id" (current-params) equal?))
(app-config (with-db/transaction
(lambda (db)
(get-user-app-config db (session-user-id) instance-id))))
(status-result
(send-instance-control-command
(alist-ref 'root-domain app-config)
(alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
"restic-snapshot-status"
(alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
`((request_id . ,request-id)
(version . 0))))
(complete (string=? (alist-ref 'status status-result) "complete")))
`(App
(Main-Container
(VStack
(h1 ,(if complete "Snapshot Complete" "Snapshot In Progress..."))
(div
(a (@ (href "/dashboard")) "Dashboard")
,@(if complete
'()
" (snapshot will continue in the background if you leave this page)")))))))
(schematra-install)
))
Reference in New Issue View Git Blame Copy Permalink