(load "db.scm") (import (chicken string) (chicken port) (chicken io) (chicken pretty-print) (chicken process) (chicken process-context) (chicken irregex) (chicken file) (rename srfi-1 (delete srfi1:delete)) srfi-18 html-widgets sxml-transforms (prefix schematra schematra:) schematra-body-parser schematra-session uri-common http-client medea intarweb nassella-db sql-null) (schematra:use-middleware! (body-parser-middleware)) (define *global-css-reset* "/* Josh's Custom CSS Reset as released into the PUBLIC DOMAIN https://www.joshwcomeau.com/css/custom-css-reset/ */ *, *::before, *::after { box-sizing: border-box; } * { margin: 0; } @media (prefers-reduced-motion: no-preference) { html { interpolate-size: allow-keywords; } } body { line-height: 1.5; -webkit-font-smoothing: antialiased; } img, picture, video, canvas, svg { display: block; max-width: 100%; } input, button, textarea, select { font: inherit; } p, h1, h2, h3, h4, h5, h6 { overflow-wrap: break-word; } p { text-wrap: pretty; } h1, h2, h3, h4, h5, h6 { text-wrap: balance; }") (define *style-tokens* `((color ((gamma ((950 . "#ffffff") (900 . "#f2f2f2") (850 . "#e4e4e4") (800 . "#d7d7d7") (750 . "#c9c9c9") (700 . "#bcbcbc") (650 . "#aeaeae") (600 . "#a1a1a1") (550 . "#949494") (500 . "#868686") (450 . "#797979") (400 . "#6b6b6b") (350 . "#5e5e5e") (300 . "#515151") (250 . "#434343") (200 . "#363636") (150 . "#282828") (100 . "#1b1b1b") (50 . "#0d0d0d") (0 . "#000000"))) (primary ((default . "#983490") (rgb . (152 52 144)) (contrast . (color contrast dark)) (tint . "#bd7ab4") (shade . "#64275e") (tone . "#92528b") (background . "#dab4d5") (background-contrast . "#2B114B"))) (secondary ((default . "#41be4b") (rgb . (65 190 75)) (contrast . (color contrast light)) (tint . "#8bd587") (shade . "#317b34") (tone . "#61aa60"))) (base ((light . (color gamma 800)) (dark . (color gamma 150)))) (accent ((default . " #44b7c0") (contrast . (color contrast light)) (tint . " #8dcfd5") (shade . " #33767b") (tone . " #63a5aa"))) (util ((info ((default . " #4e87e9") (contrast . (color contrast light)) (tint . " #93adf1") (shade . " #395895") (tone . " #6984c5"))) (safe ((default . " #58df31") (contrast . (color contrast light)) (tint . " #9beb7e") (shade . " #3f8f27") (tone . " #70bf56"))) (warning ((default . " #e6af5c") (contrast . (color contrast light)) (tint . " #f2c992") (shade . " #93713e") (tone . " #c59f6a"))) (alert ((default . " #e7385e") (contrast . (color contrast light)) (tint . " #f78590") (shade . " #952c3f") (tone . " #c95b69"))))) (contrast ((dark . (color gamma 900)) (light . (color gamma 50)))) (text ((strong . (color gamma 50)) (regular . (color gamma 150)) (subtle . (color gamma 250)) (accent . (color primary tone)))))) (font ((size ((xs . "0.694rem") (s . "0.833rem") (n . "1rem") (l . "1.2rem") (xl . "1.44rem") (xxl . "1.728rem"))) (family ((label . "Arial, Sans-Serif") (body . "Georgia, Serif"))))) (icon ((size ((xs . "0.867rem") (s . "1.041rem") (n . "1.25rem") (l . "1.5rem") (xl . "1.8rem") (xxl . "2.16rem"))))) (line-height ((tight . 1.2) (regular . 1.6) (loose . 2.133))) (space ((12 . "0.125rem") (25 . "0.25rem") (50 . "0.5rem") (75 . "0.75rem") (100 . "1rem") (125 . "1.25rem") (150 . "1.5rem") (175 . "1.75rem") (200 . "2rem"))) (gap ((side . (space 50)) (col . (space 50)) (gutter . (space 50)) (associated . (space 25)))) (width ((main ((max . "700px"))))) (radius ((small . "0.25rem") (medium . "0.5rem") (large . "1rem") (round . "50%") (pill . "9999px"))) )) ;; given a path, find it's value in the tree ;; If path has one less element ;; than the depth of the tree for that path it will be ;; assumed that the last level should use an implicit 'default ;; for the path. ;; for example: (style-path-value spec '(color gamma 900)) -> "#f2f2f2" ;; or with default path: (style-path-value spec '(color primary)) -> "#983490" (define (style-path-value tree path) (let ((res (alist-ref (car path) tree))) (if res (cond ((and (null? (cdr path)) (pair? res) (pair? (car res))) (style-path-value (car res) '(default))) ((null? (cdr path)) res) (else (style-path-value (car res) (cdr path)))) '()))) ;; convert the spec tree to a list of tokens and values ;; the path to a node is converted to a single symbol ;; that is joined by a period (.) ;; for example (style-token-tree->list spec '()) -> ;; ((color.gamma.900 "#f2f2f2") ;; (color.gamma.50 "#0d0d0d") ;; (color.primary.default "#983490") ;; (color.primary.rgb (152 52 144)) ;; (color.primary.contrast (color contrast dark)) ;; (color.secondary.default "#41be4b") ;; (color.secondary.rgb (65 190 75)) ;; (color.secondary.contrast (color contrast light)) ;; (font.size.xs "0.694rem") ;; (font.size.s "0.833rem")) (define (style-token-tree->list tree tokens) (apply append (map (lambda (node) ;; we are at the end of the expansion if the cdr of the node is a dotted pair (if (and (pair? node) (pair? (cdr node)) (pair? (cadr node))) (style-token-tree->list (cadr node) (append tokens (list (car node)))) (append ;; we use append so that if there is no default node it returns an empy list and gets "removed" from the return value (list (list (string->symbol (string-intersperse (map ->string (append tokens (list (car node))) ;; combine tokens and node value into final form ) ".")) (cdr node))) (if (eq? (car node) 'default) ;; create an extra entry without "default" on it (list (list (string->symbol (string-intersperse (map ->string tokens) ".")) (cdr node))) (list))))) tree))) ;; recursively lookup a path variable until ;; we find its root value. ;; for example: (resolved-style-path-value spec '(color contrast dark)) -> "#f2f2f2" (define (resolved-style-path-value tree path) (let ((val (style-path-value tree path))) (if (pair? val) ;; result is another path so look it up (resolved-style-path-value tree val) val))) (define (run-style-token-tests) (assert "#f2f2f2" (style-path-value *style-tokens* '(color gamma 900))) (assert "#983490" (style-path-value *style-tokens* '(color primary))) (style-token-tree->list *style-tokens* '()) ;; TODO (assert "#f2f2f2" (resolved-style-path-value *style-tokens* '(color contrast dark)))) ;; convenience function for using a style token. ;; takes as an argument either a dotted token symbol or a path. ;; Returns the fully resolved value ;; ($ 'color.primary.contrast) -> "#f2f2f2" ;; OR ;; ($ '(color primary contrast) -> "#f2f2f2" (define ($ path-or-symbol) (if (symbol? path-or-symbol) (let ((val (car (alist-ref path-or-symbol (style-token-tree->list *style-tokens* '()))))) (if (pair? val) ;; if we got a path back instead of a value (resolved-style-path-value *style-tokens* val) val)) (resolved-style-path-value *style-tokens* path-or-symbol))) (define (widget-sxml->html sxml-head sxml-body) (let ((sxml-head-out (widget->sxml-and-css sxml-head))) (receive (sxml-body-out css-list) (widget->sxml-and-css sxml-body) (print "") (SXML->HTML `(html (head (style ,(apply string-append (cons *global-css-reset* css-list))) ,@sxml-head-out) ,sxml-body-out))))) (schematra:use-middleware! (session-middleware "your-secret-key-here")) (define-syntax get (syntax-rules () ((_ (path) body ...) (schematra:get (path) (with-output-to-string (lambda () (widget-sxml->html '((meta (@ (name "viewport") (content "width=device-width")))) (begin ;; TODO remove once sessions are integrated (session-set! "user-id" 7) (session-set! "username" "me") body ...)))))))) (define-widget (Container ((max-width ($ 'width.main.max)) (style '())) contents) `(div (@ (data-name "Container") (style ((display "flex") (flex-wrap "wrap") (justify-content "center") ,@style))) (div (@ (style ((width "100%") (max-width ,max-width)))) ,@contents))) (define-widget (Decorative-Box ((color ($ 'color.gamma.800))) contents) `(div (@ (data-name "Decorative-Box") (style ((background-color ,color)))) ,@contents)) (define-widget (Box () contents) `(div (@ (data-name "Box")) ,@contents)) (define-widget (Stack ((direction 'vertical) (gap ($ 'gap.gutter)) (style '()) (element 'div)) contents) `(,element (@ (style ((display "flex") (flex-direction ,(if (eq? direction 'vertical) "column" "row")) (gap ,gap) ,@style)) (data-name "Stack")) ,@contents)) (define-widget (HStack ((gap ($ 'gap.col)) (style '())) contents) `(Stack (@ (direction horizontal) (gap ,gap) (style ,style)) ,@contents)) (define-widget (VStack ((gap ($ 'gap.gutter)) (style '()) (element #f)) contents) `(Stack (@ ,@(if element `((element ,element)) '()) (direction vertical) (gap ,gap) (style ,style)) ,@contents)) (define-widget (Step ((current #t) (completed #f) (last #f) (step-number 0)) contents) (let ((container-break 460)) `(div (@ (style ((position "relative") (display "flex") (flex-direction "column") (flex ,(if last "initial" "1 0 0px")))) (data-name "Step")) (div (@ (style ((display "flex") (align-items "center") (gap ,($ 'gap.col))))) (div (@ (style ((background ,(if completed ($ 'color.secondary.shade) (if current ($ 'color.secondary) ($ 'color.base.light)))) (border-color ,($ 'color.base.dark)) (border-width "2px") (border-style "solid") (color ,(if (or current completed) ($ 'color.secondary.contrast) ($ 'color.base.dark))) (border-radius ,($ 'radius.pill)) (width ,($ 'icon.size.xxl)) (height ,($ 'icon.size.xxl)) (display "flex") (justify-content "center") (align-items "center") (flex-shrink "0") ,@(if current `((box-shadow ,(conc "0 0 5px " ($ 'color.base.light)))) '())))) ,(if completed `(svg (@ (style ((fill "none") (stroke "currentColor") (stroke-width "2px") (stroke-linecap "round") (stroke-linejoin "round") (flex-shrink "0") (width ,($ 'icon.size.l)) (height ,($ 'icon.size.l))))) (path (@ (d "M20 6 9 17l-5-5")))) `(div ,step-number))) (div (@ (style ((@container ,(conc "(max-width: " container-break "px)") (display "none"))))) ,@contents) ,@(if (not last) `((div (@ (style (,(if completed `(background ,($ 'color.base.dark)) `(background ,($ 'color.gamma.400))) (flex "1 1 0%") (width "100%") (height "2px") (margin-inline-end "8px")))))) '())) (div (@ (style ((@container ,(conc "(min-width: " container-break "px)") (display "none")) (margin-top ,($ 'gap.gutter))))) ,@contents)))) (define-widget (Steps ((current "") (steps '()))) `(HStack (@ (style ((width "100%") (justify-content "space-between") (align-items "center") (container-type "inline-size"))) (gap "0")) ,@(let ((num-steps (length steps)) (step-index (list-index (lambda (x) (equal? x current)) steps))) (map (lambda (step i) `(Step (@ (last ,(= i (- num-steps 1))) (completed ,(< i step-index)) (current ,(= i step-index)) (step-number ,(+ i 1))) ,step)) steps (list-tabulate num-steps values))))) (define-widget (Body () contents) `(body (@ (data-name "Body") (style ((background ,($ 'color.secondary.tint)) (font-family ,($ 'font.family.label))))) ,@contents)) (define-widget (App () contents) `(Body (Container (@ (style ((margin "0.8rem")))) ,@contents))) (define-widget (Configuration-Wizard ((step "Services")) contents) `(VStack (@ (style ((background ,($ 'color.primary.background)) (color ,($ 'color.primary.background-contrast)) (border-radius ,($ 'radius.large)) (padding ,($ 'gap.gutter))))) (header (Steps (@ (steps ("Services" "Apps" "Machine" "Review")) (current ,step)))) (main (h1 (@ (style ((font-size ,($ 'font.size.xxl))))) ,step) ,@contents))) (define-widget (Fieldset ((title "Title")) contents) `(VStack (@ (element fieldset) (data-name "Fieldset") (style ((background "rgba(0,0,0,0.1)") (border-radius ,($ 'radius.small)) (min-width "0")))) (legend (h2 (@ (style ((font-size ,($ 'font.size.xl)) (font-weight "bold") (font-style "italic")))) ,title)) ,@contents)) (define-widget (Field ((name "") (id #f) (label '()) (element 'input) (type "text") (value #f) (checked #f) (input-style '()) (disabled #f)) contents) (let ((label `(label (@ (for ,(or id name)) (style ((font-weight "bold")))) ,@label)) (input `(,element (@ (type ,type) (name ,name) (id ,(or id name)) ,@(if value `((value ,value)) '()) ,@(if checked `((checked)) '()) ,@(if input-style (list input-style) '()) ,@(if disabled `((disabled)) '())) ,@contents))) `(,(if (equal? type "checkbox") 'HStack 'VStack) (@ (gap ,($ 'gap.associated))) ,(if (equal? type "checkbox") input label) ,(if (equal? type "checkbox") label input)))) (define-widget (Form-Nav ((back-to #f) (submit-button "Next"))) `(HStack (@ (style ((justify-content "space-between")))) (a (@ (href ,(or back-to "")) (style ((background ,(if back-to ($ 'color.primary.tint) ($ 'color.base.light))) (color ,(if back-to ($ 'color.primary.contrast) ($ 'color.contrast.light))) (border-radius ,($ 'radius.medium)) (border-color ,($ 'color.primary.shade)) (border-style "solid") (border-width "2px") (padding ,($ 'space.25)) (text-align "center") (text-decoration "none") ,@(if back-to '() '((pointer-events "none")))))) "Back") (button (@ (type "submit") (style ((background ,($ 'color.primary)) (color ,($ 'color.primary.contrast)) (border-radius ,($ 'radius.medium)) (border-color ,($ 'color.primary.shade)) (cursor "pointer")))) ,submit-button))) (get ("/config/wizard/services") (let ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-get "user-id")))))) `(App (Configuration-Wizard (@ (step "Services")) (form (@ (action "/config/wizard/services-submit") (method POST)) (VStack (Fieldset (@ (title "Cloudflare")) (Field (@ (name "cloudflare-api-token") (label ("API Token")) (value ,(alist-ref 'cloudflare-api-token config)))) (Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (value ,(alist-ref 'cloudflare-zone-id config)))) (Field (@ (name "cloudflare-account-id") (label ("Account ID")) (value ,(alist-ref 'cloudflare-account-id config))))) (Fieldset (@ (title "DigitalOcean")) (Field (@ (name "digitalocean-api-token") (label ("API Token")) (value ,(alist-ref 'digitalocean-api-token config))))) (Fieldset (@ (title "Backblaze")) (Field (@ (name "backblaze-application-key") (label ("Application Key")) (value ,(alist-ref 'backblaze-application-key config)))) (Field (@ (name "backblaze-key-id") (label ("Key ID")) (value ,(alist-ref 'backblaze-key-id config)))) (Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url config))))) (Form-Nav))))))) (schematra:post ("/config/wizard/services-submit") (with-db/transaction (lambda (db) (update-user-service-config db (session-get "user-id") `((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (schematra:current-params))) (cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (schematra:current-params))) (cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (schematra:current-params))) (digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (schematra:current-params))) (backblaze-application-key . ,(alist-ref 'backblaze-application-key (schematra:current-params))) (backblaze-key-id . ,(alist-ref 'backblaze-key-id (schematra:current-params))) (backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (schematra:current-params))))))) (schematra:redirect "/config/wizard/services-success")) (get ("/config/wizard/services-success") `(App (Configuration-Wizard (@ (step "Services")) (form (@ (action "/config/wizard/apps")) (VStack (Fieldset (@ (title "Cloudflare")) (h3 "Connected") (p "Your Cloudflare account was successfully connected!")) (Fieldset (@ (title "DigitalOcean")) (h3 "Connected") (p "Your DigitalOcean account was successfully connected!")) (Fieldset (@ (title "Backblaze")) (h3 "Connected") (p "Your Backblaze account was successfully connected!")) (Form-Nav (@ (back-to "/config/wizard/services")))))))) (get ("/config/wizard/apps") (let ((results (with-db/transaction (lambda (db) `((selected-apps . ,(map car (filter cdr (get-user-selected-apps db (session-get "user-id"))))) (app-config . ,(get-user-app-config db (session-get "user-id")))))))) `(App (Configuration-Wizard (@ (step "Apps")) (form (@ (action "/config/wizard/apps-submit") (method POST)) (VStack (Fieldset (@ (title "Root Domain")) (Field (@ (element select) (name "root-domain")) (option (@ (value ,(alist-ref 'root-domain (alist-ref 'app-config results)))) "nassella.cc"))) ;; TODO fetch from cloudflare API? (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 "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled")))) (Form-Nav (@ (back-to "/config/wizard/services-success"))))))))) (schematra:post ("/config/wizard/apps-submit") (with-db/transaction (lambda (db) (update-user-selected-apps db (session-get "user-id") `((wg-easy . ,(or (and (alist-ref 'wg-easy (schematra:current-params)) "0.0") (sql-null))) (nextcloud . ,(or (and (alist-ref 'nextcloud (schematra:current-params)) "0.0") (sql-null))))) (update-root-domain db (session-get "user-id") (alist-ref 'root-domain (schematra:current-params))))) (schematra:redirect "/config/wizard/apps2")) (get ("/config/wizard/apps2") (let* ((results (with-db/transaction (lambda (db) `((selected-apps . ,(map car (filter cdr (get-user-selected-apps db (session-get "user-id"))))) (app-config . ,(get-user-app-config db (session-get "user-id"))))))) (selected-apps (alist-ref 'selected-apps results)) (app-config (alist-ref 'app-config results))) `(App (Configuration-Wizard (@ (step "Apps")) (form (@ (action "/config/wizard/apps2-submit") (method POST)) (VStack ,@(if (member 'wg-easy selected-apps) `((Fieldset (@ (title "WG-Easy")) (Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'wg-easy app-config eq? '()) eq? "wg-easy")))))) '()) ,@(if (member 'nextcloud selected-apps) `((Fieldset (@ (title "NextCloud")) (Field (@ (name "nextcloud-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'nextcloud app-config eq? '()) eq? "nextcloud")))) (Field (@ (name "nextcloud-admin-user") (label ("Admin Username")) (value ,(alist-ref 'admin-user (alist-ref 'nextcloud app-config eq? '()) eq? "admin")))) (Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password") (value ,(alist-ref 'admin-password (alist-ref 'nextcloud app-config eq? '()) eq? "")))))) '()) (Fieldset (@ (title "Log Viewer")) (Field (@ (name "log-viewer-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'log-viewer app-config eq? '()) eq? "logs")))) (Field (@ (name "log-viewer-user") (label ("Username")) (value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? "")))) (Field (@ (name "log-viewer-password") (label ("Password")) (type "password") (value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? ""))))) (Form-Nav (@ (back-to "/config/wizard/apps"))))))))) (schematra:post ("/config/wizard/apps2-submit") (with-db/transaction (lambda (db) (update-user-app-config db (session-get "user-id") `((wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (schematra:current-params))))) (nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (schematra:current-params))) (admin-user . ,(alist-ref 'nextcloud-admin-user (schematra:current-params))) (admin-password . ,(alist-ref 'nextcloud-admin-password (schematra:current-params))))) (log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (schematra:current-params))) (user . ,(alist-ref 'log-viewer-user (schematra:current-params))) (password . ,(alist-ref 'log-viewer-password (schematra:current-params))))))))) (schematra:redirect "/config/wizard/machine")) ;; Parsing JSON arrays as lists instead of vectors (define array-as-list-parser (cons 'array (lambda (x) x))) (json-parsers (cons array-as-list-parser (json-parsers))) (define (get-digital-ocean-regions api-token) (filter (lambda (r) (alist-ref 'available r)) (alist-ref 'regions (let* ((uri (uri-reference "https://api.digitalocean.com/v2/regions")) (req (make-request method: 'GET uri: uri headers: (headers `((content-type application/json) (Authorization ,(conc "Bearer " api-token))))))) (with-input-from-request req #f read-json))))) (define (get-digital-ocean-sizes api-token) (filter (lambda (r) (alist-ref 'available r)) (alist-ref 'sizes (let* ((uri (uri-reference "https://api.digitalocean.com/v2/sizes?per_page=200")) (req (make-request method: 'GET uri: uri headers: (headers `((content-type application/json) (Authorization ,(conc "Bearer " api-token))))))) (with-input-from-request req #f read-json))))) (get ("/config/wizard/machine") (let ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-get "user-id")))))) `(App (Configuration-Wizard (@ (step "Machine")) (form (@ (action "/config/wizard/machine-submit") (method POST)) (VStack (Fieldset (@ (title "Region")) (Field (@ (element select) (name "region")) (option (@ (value "")) "") ,@(map (lambda (r) `(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r))) (get-digital-ocean-regions (alist-ref 'digitalocean-api-token config))))) (Form-Nav (@ (back-to ,(conc "/config/wizard/apps2")))))))))) (schematra:post ("/config/wizard/machine-submit") (with-db/transaction (lambda (db) (update-user-service-config db (session-get "user-id") `((digitalocean-region . ,(alist-ref 'region (schematra:current-params))))))) (schematra:redirect "/config/wizard/machine2")) (get ("/config/wizard/machine2") (let* ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-get "user-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 "/config/wizard/machine2-submit") (method POST)) (VStack (Fieldset (@ (title "Size")) (Field (@ (element select) (name "size") (input-style ((max-width "100%")))) ,@(map (lambda (s) `(option (@ (value ,(alist-ref 'slug s)) ,@(if (equal? (alist-ref 'slug s) "s-2vcpu-2gb") `((selected "selected")) '())) "$" ,(alist-ref 'price_monthly s) " (CPU: ",(alist-ref 'vcpus s) " Mem: " ,(/ (alist-ref 'memory s) 1024) " Disk: " ,(alist-ref 'disk s) ") " ,(alist-ref 'description s))) sizes))) (Form-Nav (@ (back-to ,(conc "/config/wizard/machine")))))))))) (schematra:post ("/config/wizard/machine2-submit") (with-db/transaction (lambda (db) (update-user-service-config db (session-get "user-id") `((digitalocean-size . ,(alist-ref 'size (schematra:current-params))))))) (schematra:redirect "/config/wizard/review")) (get ("/config/wizard/review") (let* ((results (with-db/transaction (lambda (db) `((selected-apps . ,(map car (filter cdr (get-user-selected-apps db (session-get "user-id"))))) (app-config . ,(get-user-app-config db (session-get "user-id"))) (service-config . ,(get-user-service-config db (session-get "user-id"))))))) (selected-apps (cons 'log-viewer (alist-ref 'selected-apps results))) (app-config (alist-ref 'app-config results)) (config (alist-ref 'config app-config)) (root-domain (alist-ref 'root-domain app-config)) (service-config (alist-ref 'service-config results))) `(App (Configuration-Wizard (@ (step "Review")) (h2 "Root Domain") ,root-domain (h2 "Apps") (ul ,@(map (lambda (app) `(li ,app " @ " ,(alist-ref 'subdomain (alist-ref app config)) "." ,root-domain)) selected-apps)) (h2 "Machine") (ul (li "Region: " ,(alist-ref 'digitalocean-region service-config)) (li "Size: " ,(alist-ref 'digitalocean-size service-config))) (form (@ (action "/config/wizard/review-submit") (method POST)) (VStack (Form-Nav (@ (back-to ,(conc "/config/wizard/machine2")) (submit-button "Launch"))))))))) (define (deployment-directory user-id) (string-append "deploy-" (number->string user-id))) (define (setup-deploy-files dir state state-backup) (when (directory-exists? dir) (delete-directory dir #t)) (create-directory dir) (process-wait (process-run (string-append "tar -xf nassella-latest.tar -C " dir))) (create-directory (string-append dir "/config")) (copy-file "../config/ssh-keys" (string-append dir "/config/ssh-keys")) ;; TODO remove (with-output-to-file (string-append dir "/terraform.tfstate") (lambda () (write-string state))) (with-output-to-file (string-append dir "/terraform.tfstate.backup") (lambda () (write-string state-backup)))) (define (parse-deployment-log log) (define (search complete in-progress) (cond ((irregex-search complete log) 'complete) ((irregex-search in-progress log) 'in-progress) (else 'queued))) `((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start")) (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 "\"")) (schematra:post ("/config/wizard/review-submit") (let* ((results (with-db/transaction (lambda (db) `((selected-apps . ,(map car (filter cdr (get-user-selected-apps db (session-get "user-id"))))) (app-config . ,(get-user-app-config db (session-get "user-id"))) (service-config . ,(get-user-service-config db (session-get "user-id"))) (terraform-state . ,(get-user-terraform-state db (session-get "user-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)) (dir (deployment-directory (session-get "user-id")))) (setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state)) (with-output-to-file (string-append dir "/config/apps.config") (lambda () (map (lambda (e) (write-config-entry (car e) (cdr e))) `(("ROOT_DOMAIN" . ,root-domain) ("APP_CONFIGS" . ,(string-intersperse (map (lambda (app) (conc (if (eq? app 'log-viewer) 'dozzle app) "," (alist-ref 'subdomain (alist-ref app config)))) selected-apps) " ")) ("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config))) ("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config))) ("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config))) ("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config))) ("NEXTCLOUD_POSTGRES_DB" . "nextcloud") ("NEXTCLOUD_POSTGRES_USER" . "nextcloud") ("NEXTCLOUD_POSTGRES_PASSWORD" . "dbpassword") ;; TODO generate ("NEXTCLOUD_REDIS_PASSWORD" . "redispassword") ;; TODO generate ("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" . "foodisgood"))))) ;; TODO generate or get from user (with-output-to-file (string-append dir "/config/production.tfvars") (lambda () (map (lambda (e) (write-config-entry (car e) (cdr e))) `(("server_type" . ,(alist-ref 'digitalocean-size service-config)) ("do_token" . ,(alist-ref 'digitalocean-api-token service-config)) ("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config)) ("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config)) ("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config)) ("cluster_name" . "mycluster") ("datacenter" . ,(alist-ref 'digitalocean-region service-config)) ("flatcar_stable_version" . "4230.2.3"))) (display "ssh_keys=[\"") (display (with-input-from-file (string-append dir "/config/ssh-keys") read-string)) (print "\"]")))) (let* ((user-id (session-get "user-id")) (deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id)))) (dir (deployment-directory user-id))) (thread-start! (lambda () (change-directory dir) (let ((pid (process-run "make apply > make-out"))) (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) (begin (let ((progress (parse-deployment-log (with-input-from-file (string-append (deployment-directory user-id) "/make-out") read-string)))) (with-db/transaction (lambda (db) (update-deployment-progress db deployment-id progress)))) (loop)) (let ((progress (parse-deployment-log (with-input-from-file (string-append (deployment-directory user-id) "/make-out") 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 (with-input-from-file (string-append dir "/terraform.tfstate") read-string) (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))))))))))) (schematra:redirect "/config/wizard/success")) (define (progress-status->text status) (case status ((queued) "queued") ((in-progress) "in progress") ((complete) "complete") ((failed) "failed"))) (get ("/config/wizard/success") (let* ((res (with-db/transaction (lambda (db) `((status . ,(get-most-recent-deployment-status db (session-get "user-id"))) (progress . ,(get-most-recent-deployment-progress db (session-get "user-id"))))))) (output (with-input-from-file (string-append (deployment-directory (session-get "user-id")) "/make-out") read-string)) (progress (alist-ref 'progress res)) (status (alist-ref 'status res))) `(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)))) (pre ,output) ))) (schematra:schematra-install) (schematra:schematra-start)