app/src/nassella.scm

;; (load "db")
;; (load "mocks")
(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)

        (rename srfi-1 (delete srfi1:delete))
        srfi-13
        srfi-18
        srfi-158
        srfi-194

        html-widgets
        sxml-transforms
        schematra
        schematra.body-parser
        uri-common
        http-client
        medea
        intarweb
        nassella-db
        sql-null
        openssl
        spiffy)

(define app (schematra/make-app))

(with-schematra-app app
  (lambda ()
    (use-middleware! (body-parser-middleware))))

(define *global-css-reset*
  "/*
  Josh's Custom CSS Reset as released into the PUBLIC DOMAIN
  https://www.joshwcomeau.com/css/custom-css-reset/
*/

*, *::before, *::after {
  box-sizing: border-box;
}

* {
  margin: 0;
}

@media (prefers-reduced-motion: no-preference) {
  html {
    interpolate-size: allow-keywords;
  }
}

body {
  line-height: 1.5;
  -webkit-font-smoothing: antialiased;
}

img, picture, video, canvas, svg {
  display: block;
  max-width: 100%;
}

input, button, textarea, select {
  font: inherit;
}

p, h1, h2, h3, h4, h5, h6 {
  overflow-wrap: break-word;
}

p {
  text-wrap: pretty;
}
h1, h2, h3, h4, h5, h6 {
  text-wrap: balance;
}")



(define *style-tokens*
  `((color ((gamma ((950 . "#ffffff")
                    (900 . "#f2f2f2")
                    (850 . "#e4e4e4")
                    (800 . "#d7d7d7")
                    (750 . "#c9c9c9")
                    (700 . "#bcbcbc")
                    (650 . "#aeaeae")
                    (600 . "#a1a1a1")
                    (550 . "#949494")
                    (500 . "#868686")
                    (450 . "#797979")
                    (400 . "#6b6b6b")
                    (350 . "#5e5e5e")
                    (300 . "#515151")
                    (250 . "#434343")
                    (200 . "#363636")
                    (150 . "#282828")
                    (100 . "#1b1b1b")
                    (50 . "#0d0d0d")
                    (0 . "#000000")))
            (primary ((default . "#983490")
                      (rgb . (152 52 144))
                      (contrast . (color contrast dark))
                      (tint . "#bd7ab4")
                      (shade . "#64275e")
                      (tone . "#92528b")
                      (background . "#dab4d5")
                      (background-contrast . "#2B114B")))
            (secondary ((default . "#41be4b")
                        (rgb . (65 190 75))
                        (contrast . (color contrast light))
                        (tint . "#8bd587")
                        (shade . "#317b34")
                        (tone . "#61aa60")))
            (base ((light . (color gamma 800))
                   (dark . (color gamma 150))))
            (accent ((default . " #44b7c0")
                     (contrast . (color contrast light))
                     (tint . " #8dcfd5")
                     (shade . " #33767b")
                     (tone . " #63a5aa")))
            (util ((info ((default . " #4e87e9")
                          (contrast . (color contrast light))
                          (tint . " #93adf1")
                          (shade . " #395895")
                          (tone . " #6984c5")))
                   (safe ((default . " #58df31")
                          (contrast . (color contrast light))
                          (tint . " #9beb7e")
                          (shade . " #3f8f27")
                          (tone . " #70bf56")))
                   (warning ((default . " #e6af5c")
                             (contrast . (color contrast light))
                             (tint . " #f2c992")
                             (shade . " #93713e")
                             (tone . " #c59f6a")))
                   (alert ((default . " #e7385e")
                           (contrast . (color contrast light))
                           (tint . " #f78590")
                           (shade . " #952c3f")
                           (tone . " #c95b69")))))
            (contrast ((dark . (color gamma 900))
                       (light . (color gamma 50))))
            (text ((strong . (color gamma 50))
                   (regular . (color gamma 150))
                   (subtle . (color gamma 250))
                   (accent . (color primary tone))))))
    (font ((size ((xs . "0.694rem")
                  (s . "0.833rem")
                  (n . "1rem")
                  (l . "1.2rem")
                  (xl . "1.44rem")
                  (xxl . "1.728rem")))
           (family ((label . "Arial, Sans-Serif")
                    (body . "Georgia, Serif")))))
    (icon ((size ((xs . "0.867rem")
                  (s . "1.041rem")
                  (n . "1.25rem")
                  (l . "1.5rem")
                  (xl . "1.8rem")
                  (xxl . "2.16rem")))))
    (line-height ((tight . 1.2)
                  (regular . 1.6)
                  (loose . 2.133)))
    (space ((12 . "0.125rem")
            (25 . "0.25rem")
            (50 . "0.5rem")
            (75 . "0.75rem")
            (100 . "1rem")
            (125 . "1.25rem")
            (150 . "1.5rem")
            (175 . "1.75rem")
            (200 . "2rem")))
    (gap ((side . (space 50))
          (col . (space 50))
          (gutter . (space 50))
          (associated . (space 25))))
    (width ((main ((max . "700px")))))
    (radius ((small . "0.25rem")
             (medium . "0.5rem")
             (large . "1rem")
             (round . "50%")
             (pill . "9999px")))
    ))

;; given a path, find it's value in the tree
;; If path has one less element
;; than the depth of the tree for that path it will be
;; assumed that the last level should use an implicit 'default
;; for the path.
;; for example: (style-path-value spec '(color gamma 900)) -> "#f2f2f2"
;; or with default path: (style-path-value spec '(color primary)) -> "#983490"
(define (style-path-value tree path)
  (let ((res (alist-ref (car path) tree)))
    (if res
        (cond ((and (null? (cdr path)) (pair? res) (pair? (car res)))
               (style-path-value (car res) '(default)))
              ((null? (cdr path))
               res)
              (else
               (style-path-value (car res) (cdr path))))
        '())))

;; convert the spec tree to a list of tokens and values
;; the path to a node is converted to a single symbol
;; that is joined by a period (.)
;; for example (style-token-tree->list spec '()) ->
;; ((color.gamma.900 "#f2f2f2")
;;  (color.gamma.50 "#0d0d0d")
;;  (color.primary.default "#983490")
;;  (color.primary.rgb (152 52 144))
;;  (color.primary.contrast (color contrast dark))
;;  (color.secondary.default "#41be4b")
;;  (color.secondary.rgb (65 190 75))
;;  (color.secondary.contrast (color contrast light))
;;  (font.size.xs "0.694rem")
;;  (font.size.s "0.833rem"))
(define (style-token-tree->list tree tokens)
  (apply append (map (lambda (node)
                       ;; we are at the end of the expansion if the cdr of the node is a dotted pair
                       (if (and (pair? node) (pair? (cdr node)) (pair? (cadr node)))
                           (style-token-tree->list (cadr node) (append tokens (list (car node))))
                           (append ;; we use append so that if there is no default node it returns an empy list and gets "removed" from the return value
                            (list
                             (list (string->symbol
                                    (string-intersperse
                                     (map ->string
                                          (append tokens (list (car node))) ;; combine tokens and node value into final form
                                          )
                                     "."))
                                   (cdr node)))
                            (if (eq? (car node) 'default) ;; create an extra entry without "default" on it
                                (list (list (string->symbol
                                             (string-intersperse (map ->string tokens) "."))
                                            (cdr node)))
                                (list)))))
                     tree)))

;; recursively lookup a path variable until
;; we find its root value.
;; for example: (resolved-style-path-value spec '(color contrast dark)) -> "#f2f2f2"
(define (resolved-style-path-value tree path)
  (let ((val (style-path-value tree path)))
    (if (pair? val) ;; result is another path so look it up
        (resolved-style-path-value tree val)
        val)))

(define (run-style-token-tests)
  (assert "#f2f2f2" (style-path-value *style-tokens* '(color gamma 900)))
  (assert "#983490" (style-path-value *style-tokens* '(color primary)))
  (style-token-tree->list *style-tokens* '()) ;; TODO
  (assert "#f2f2f2" (resolved-style-path-value *style-tokens* '(color contrast dark))))

;; convenience function for using a style token.
;; takes as an argument either a dotted token symbol or a path.
;; Returns the fully resolved value
;; ($ 'color.primary.contrast) -> "#f2f2f2"
;; OR
;; ($ '(color primary contrast) -> "#f2f2f2"
(define ($ path-or-symbol)
  (if (symbol? path-or-symbol)
      (let ((val (car (alist-ref path-or-symbol (style-token-tree->list *style-tokens* '())))))
        (if (pair? val) ;; if we got a path back instead of a value
            (resolved-style-path-value *style-tokens* val)
            val))
      (resolved-style-path-value *style-tokens* path-or-symbol)))


(define test-mode (make-parameter #f))
(define last-request-body-sxml (make-parameter '()))
(define last-request-body-widget-sxml (make-parameter '()))

(define (widget-sxml->html sxml-head sxml-body)
  (let ((sxml-head-out (widget->sxml-and-css sxml-head)))
    (receive (sxml-body-out css-list)
        (widget->sxml-and-css sxml-body)
      (when test-mode
        (last-request-body-widget-sxml sxml-body)
        (last-request-body-sxml (widget->sxml sxml-body)))
      (print "<!DOCTYPE html>")
      (SXML->HTML
       `(html (head (style ,(apply string-append (cons *global-css-reset* css-list)))
                    ,@sxml-head-out)
              ,sxml-body-out)))))

(define test-user-id (make-parameter 1))

(define (authelia-auth-middleware next)
  (cond-expand
    (dev
     (current-params (append `((user-id . ,(test-user-id)) (username . "me")) (current-params)))
     (next))
    (else
     (let* ((request (current-request))
            (headers (request-headers request))
            (remote-user (header-value 'remote-user headers))
            (uri (request-uri request))
            (path (uri-path uri)))
       (if remote-user
           (begin
             (current-params (append `((user-id . ,(with-db/transaction
                                                    (lambda (db)
                                                      (get-user-id-by-username db remote-user))))
                                       (username . ,remote-user))
                                     (current-params)))
             (next))
           (if (and (cdr path) (cadr path) (string=? "unsecured" (cadr path)))
               (next)
               (begin (log-to (debug-log) "no valid auth header | ~S | ~A" path headers)
                      '(unauthorized "no valid auth header"))))))))

(with-schematra-app app
                    (lambda ()
                      (use-middleware! authelia-auth-middleware)))

(define (session-user-id)
  (alist-ref 'user-id (current-params)))

(define-syntax get/widgets
  (syntax-rules ()
    ((_ (path) body ...)
     (get/widgets (path '()) body ...))
    ((_ (path headers) body ...)
     (get path
          (with-output-to-string
            (lambda ()
              (widget-sxml->html
               (cons
                '(meta (@ (name "viewport") (content "width=device-width")))
                headers)
               ;; `((meta (@ (name "viewport") (content "width=device-width"))))
               (begin
                 body ...))))))))

(define-widget (Container ((max-width ($ 'width.main.max)) (style '())) contents)
  `(div (@ (data-name "Container")
           (style ((display "flex")
                   (flex-wrap "wrap")
                   (justify-content "center")
                   ,@style)))
        (div (@ (style ((width "100%")
                        (max-width ,max-width))))
             ,@contents)))

(define-widget (Decorative-Box ((color ($ 'color.gamma.800))) contents)
  `(div (@ (data-name "Decorative-Box")
           (style ((background-color ,color))))
        ,@contents))

(define-widget (Box () contents)
  `(div (@ (data-name "Box"))
        ,@contents))

(define-widget (Stack ((direction 'vertical) (gap ($ 'gap.gutter)) (style '()) (element 'div)) contents)
  `(,element (@ (style ((display "flex")
                        (flex-direction ,(if (eq? direction 'vertical) "column" "row"))
                        (gap ,gap)
                        ,@style))
                (data-name "Stack"))
     ,@contents))

(define-widget (HStack ((gap ($ 'gap.col)) (style '())) contents)
  `(Stack (@ (direction horizontal) (gap ,gap) (style ,style))
          ,@contents))

(define-widget (VStack ((gap ($ 'gap.gutter)) (style '()) (element #f)) contents)
  `(Stack (@ ,@(if element `((element ,element)) '()) (direction vertical) (gap ,gap) (style ,style))
     ,@contents))

(define-widget (Step ((current #t) (completed #f) (last #f) (step-number 0)) contents)
  (let ((container-break 460))
    `(div (@ (style ((position "relative")
                     (display "flex")
                     (flex-direction "column")
                     (flex ,(if last "initial" "1 0 0px"))))
             (data-name "Step"))
          (div (@ (style ((display "flex")
                          (align-items "center")
                          (gap ,($ 'gap.col)))))
               (div (@ (style ((background ,(if completed
                                                ($ 'color.secondary.shade)
                                                (if current
                                                    ($ 'color.secondary)
                                                    ($ 'color.base.light))))
                               (border-color ,($ 'color.base.dark))
                               (border-width "2px")
                               (border-style "solid")
                               (color ,(if (or current completed) ($ 'color.secondary.contrast) ($ 'color.base.dark)))
                               (border-radius ,($ 'radius.pill))
                               (width ,($ 'icon.size.xxl))
                               (height ,($ 'icon.size.xxl))
                               (display "flex")
                               (justify-content "center")
                               (align-items "center")
                               (flex-shrink "0")
                               ,@(if current
                                     `((box-shadow ,(conc "0 0 5px " ($ 'color.base.light))))
                                     '()))))
                    ,(if completed
                         `(svg (@ (style ((fill "none")
                                          (stroke "currentColor")
                                          (stroke-width "2px")
                                          (stroke-linecap "round")
                                          (stroke-linejoin "round")
                                          (flex-shrink "0")
                                          (width ,($ 'icon.size.l))
                                          (height ,($ 'icon.size.l)))))
                               (path (@ (d "M20 6 9 17l-5-5"))))
                         `(div ,step-number)))
               (div (@ (style ((@container ,(conc "(max-width: " container-break "px)")
                                           (display "none")))))
                    ,@contents)
               ,@(if (not last)
                     `((div (@ (style (,(if completed
                                            `(background ,($ 'color.base.dark))
                                            `(background ,($ 'color.gamma.400)))
                                       (flex "1 1 0%")
                                       (width "100%")
                                       (height "2px")
                                       (margin-inline-end "8px"))))))
                     '()))
          (div (@ (style ((@container ,(conc "(min-width: " container-break "px)")
                                      (display "none"))
                          (margin-top ,($ 'gap.gutter)))))
               ,@contents))))

(define-widget (Steps ((current "") (steps '())))
  `(HStack
    (@ (style ((width "100%")
               (justify-content "space-between")
               (align-items "center")
               (container-type "inline-size")))
       (gap "0"))
    ,@(let ((num-steps (length steps))
            (step-index (list-index (lambda (x) (equal? x current)) steps)))
        (map
         (lambda (step i)
           `(Step (@ (last ,(= i (- num-steps 1)))
                     (completed ,(< i step-index))
                     (current ,(= i step-index))
                     (step-number ,(+ i 1)))
                  ,step))
         steps (list-tabulate num-steps values)))))

(define-widget (Body () contents)
  `(body (@ (data-name "Body") (style ((background ,($ 'color.secondary.tint)) (font-family ,($ 'font.family.label)))))
         ,@contents))

(define-widget (App () contents)
  `(Body (Container (@ (style ((margin "0.8rem")))) ,@contents)))

(define-widget (Configuration-Wizard ((step "Services")) contents)
  `(VStack
    (@ (style ((background ,($ 'color.primary.background))
               (color ,($ 'color.primary.background-contrast))
               (border-radius ,($ 'radius.large))
               (padding ,($ 'gap.gutter)))))
    (header
     (Steps (@ (steps ("Services" "Apps" "Machine" "Review")) (current ,step))))
    (main
     (h1 (@ (style ((font-size ,($ 'font.size.xxl))))) ,step)
     ,@contents)))

(define-widget (Main-Container () contents)
  `(VStack
    (@ (style ((background ,($ 'color.primary.background))
               (color ,($ 'color.primary.background-contrast))
               (border-radius ,($ 'radius.large))
               (padding ,($ 'gap.gutter)))))
    ;; (header
    ;;  (Steps (@ (steps ("Services" "Apps" "Machine" "Review")) (current ,step))))
    ,@contents))

(define-widget (Fieldset ((title "Title")) contents)
  `(VStack
    (@ (element fieldset)
       (data-name "Fieldset")
       (style ((background "rgba(0,0,0,0.1)")
               (border-radius ,($ 'radius.small))
               (min-width "0"))))
    (legend
     (h2 (@ (style ((font-size ,($ 'font.size.xl)) (font-weight "bold") (font-style "italic"))))
         ,title))
    ,@contents))

(define-widget (Field ((name "") (id #f) (label '()) (element 'input) (type "text") (value #f) (checked #f)
                       (input-style '()) (disabled #f))
                      contents)
  (let ((label `(label (@ (for ,(or id name)) (style ((font-weight "bold")))) ,@label))
        (input `(,element (@ (type ,type) (name ,name) (id ,(or id name)) ,@(if value `((value ,value)) '())
                             ,@(if checked `((checked)) '()) ,@(if input-style (list input-style) '())
                             ,@(if disabled `((disabled)) '()))
                  ,@contents)))
    `(,(if (equal? type "checkbox") 'HStack 'VStack)
      (@ (gap ,($ 'gap.associated)))
      ,(if (equal? type "checkbox") input label)
      ,(if (equal? type "checkbox") label input))))

(define-widget (Button ((type "submit") (enabled #t)) contents)
  `(button (@ (type ,type)
              ,@(if enabled '() '((disabled)))
              (style ((background ,(if enabled
                                       ($ 'color.primary)
                                       ($ 'color.primary.contrast)))
                      (color ,(if enabled
                                  ($ 'color.primary.contrast)
                                  ($ 'color.primary)))
                      (border-radius ,($ 'radius.medium))
                      (border-color ,($ 'color.primary.shade))
                      ,@(if enabled
                            '((cursor "pointer"))
                            '()))))
           ,@contents))

(define-widget (Form-Nav ((back-to #f) (submit-button "Next") (submit-enabled #t)))
  `(HStack
    (@ (style ((justify-content "space-between"))))
    (a (@ (href ,(or back-to ""))
          (style ((background ,(if back-to ($ 'color.primary.tint) ($ 'color.base.light)))
                  (color ,(if back-to ($ 'color.primary.contrast) ($ 'color.contrast.light)))
                  (border-radius ,($ 'radius.medium))
                  (border-color ,($ 'color.primary.shade))
                  (border-style "solid")
                  (border-width "2px")
                  (padding ,($ 'space.25))
                  (text-align "center")
                  (text-decoration "none")
                  ,@(if back-to
                        '()
                        '((pointer-events "none"))))))
       "Back")
    (Button (@ (enabled ,submit-enabled)) ,submit-button)))

;; Parsing JSON arrays as lists instead of vectors
(define array-as-list-parser
  (cons 'array (lambda (x) x)))

(json-parsers (cons array-as-list-parser (json-parsers)))

;; TODO change username to to a prod API key that has read access
;; to the checkout session
(define (send-stripe-request #!key (method 'GET) endpoint (body #f) (username ""))
  (define api-endpoint "https://api.stripe.com/")
  (define api-version "/v1")

  (with-input-from-request
      (make-request method: method
    	            uri: (uri-reference (string-append api-endpoint api-version endpoint))
    	            headers: (headers `((authorization . (#(basic ((username . ,username) (password . ""))))))))
    body
    read-json))

(define (stripe-session-email sid)
  (alist-ref
   'email
   (alist-ref
    'customer_details
    (send-stripe-request endpoint: (string-append "/checkout/sessions/" sid)
                         username: (string-trim-right (with-input-from-file "/run/secrets/nassella_stripe_api_key" read-string))))))


(define (create-lldap-user username email)
  ;; query = mutation createUser($user:CreateUserInput!){createUser(user:$user){id email displayName firstName lastName avatar}}
  ;; variables = {\"user\":{\"id\":\"${id}\",\"email\":\"${email}\",\"displayName\":\"${name}\",\"firstName\":\"${firstName}\",\"lastName\":\"${lastName}\",\"avatar\":\"
  ;; data="{\"query\":\"${query}\",\"variables\":${variables}"
  ;; http://localhost:17170/api/graphql
  ;;   -H 'Content-Type: application/json' \
  ;; -H "Authorization: Bearer $token" \
  (let ((api-token
         (alist-ref
          'token
          (with-input-from-request
              (make-request method: 'POST
    	                    uri: (uri-reference "http://nassella_lldap:17170/auth/simple/login")
    	                    headers: (headers `((content-type application/json))))
            (lambda ()
              (write-json
               `((username . "admin") (password . ,(string-trim-right (with-input-from-file "/run/secrets/nassella_lldap_admin_password" read-string)))))) ;; trim to remove newline
            read-json))))
    (with-input-from-request
        (make-request method: 'POST
    	              uri: (uri-reference "http://nassella_lldap:17170/api/graphql")
    	              headers: (headers `((content-type application/json)
                                          (authorization #(,(string-append "Bearer " api-token) raw)))))
      (lambda ()
        (write-json
         `((query . "mutation createUser($user:CreateUserInput!){createUser(user:$user){id email displayName firstName lastName avatar}}")
           (variables . ((user . ((id . ,username)
                                  (email . ,email))))))))
      read-json)))

(define (get-digital-ocean-regions api-token)
  (filter
   (lambda (r)
     (alist-ref 'available r))
   (if (test-mode)
       *digital-ocean-regions-response*
       (alist-ref
        'regions
        (let* ((uri (uri-reference "https://api.digitalocean.com/v2/regions"))
               (req (make-request method: 'GET
                                  uri: uri
                                  headers: (headers `((content-type application/json)
                                                      (Authorization ,(conc "Bearer " api-token)))))))
          (with-input-from-request req #f read-json))))))

(define (get-digital-ocean-sizes api-token)
  (filter
   (lambda (r)
     (alist-ref 'available r))
   (alist-ref
    'sizes
    (if (test-mode)
        *digital-ocean-sizes-response*
        (let* ((uri (uri-reference "https://api.digitalocean.com/v2/sizes?per_page=200"))
               (req (make-request method: 'GET
                                  uri: uri
                                  headers: (headers `((content-type application/json)
                                                      (Authorization ,(conc "Bearer " api-token)))))))
          (with-input-from-request req #f read-json))))))

(define (get-cloudflare-domains api-token)
  (map
   (lambda (x)
     (alist-ref 'name x))
   (alist-ref
    'result
    (let* ((uri (uri-reference "https://api.cloudflare.com/client/v4/zones"))
         (req (make-request method: 'GET
                            uri: uri
                            headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw)))))))
  (with-input-from-request req #f read-json)
  ;; (handle-exceptions exn (get-condition-property exn 'client-error 'body)
  ;;                    (with-input-from-request req #f read-json))
  ))))

;; TODO this currently only supports the first page
;; Example return json:
;; ((result ((id . "aaa") (name . "example.org") (status . "active")
;;           (paused . #f) (type . "full") (development_mode . 0)
;;           (name_servers "abby.ns.cloudflare.com" "toby.ns.cloudflare.com")
;;           (original_name_servers . null) (original_registrar . null) (original_dnshost . null)
;;           (modified_on . "2025-08-13T17:17:10.664419Z") (created_on . "2025-08-13T17:17:05.956271Z")
;;           (activated_on . "2025-08-13T17:17:10.476671Z") (vanity_name_servers)
;;           (vanity_name_servers_ips . null)
;;           (meta (step . 4) (custom_certificate_quota . 0) (page_rule_quota . 3) (phishing_detected . #f))
;;           (owner (id . null) (type . "user") (email . null))
;;           (account (id . "aaa") (name . "XXX's Account"))
;;           (tenant (id . null) (name . null)) (tenant_unit (id . null))
;;           (permissions "#dns_records:edit" "#dns_records:read" "#zone:read")
;;           (plan (id . "0feeeeeeeeeeeeeeeeeeeeeeeeeeeeee") (name . "Free Website") (price . 0)
;;                 (currency . "USD") (frequency . "") (is_subscribed . #f) (can_subscribe . #f)
;;                 (legacy_id . "free") (legacy_discount . #f) (externally_managed . #f))))
;;  (result_info (page . 1) (per_page . 20) (total_pages . 1) (count . 1) (total_count . 1))
;;  (success . #t) (errors) (messages))
(define (test-cloudflare-connection api-token zone-id account-id)
  (let* ((uri (uri-reference "https://api.cloudflare.com/client/v4/zones"))
         (req (make-request method: 'GET
                            uri: uri
                            headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw)))))))
    (let ((res (handle-exceptions exn (read-json (get-condition-property exn 'client-error 'body))
                                  (with-input-from-request req #f read-json))))
      (if (alist-ref 'success res)
          (let ((matches
                 (filter (lambda (x) (and (string=? (alist-ref 'id x) zone-id)
                                          (string=? (alist-ref 'id (alist-ref 'account x)) account-id)))
                         (alist-ref 'result res))))
            (if (null? matches)
                '((success . #f)
                  (errors ((message . "Account ID and/or Zone ID does not match API Token."))))
                '((success . #t)
                  (result ,matches))))
          res))))

(define (test-digitalocean-connection api-token)
  (let* ((uri (uri-reference "https://api.digitalocean.com/v2/account"))
         (req (make-request method: 'GET
                            uri: uri
                            headers: (headers `((Authorization #(,(conc "Bearer " api-token) raw)))))))
    (let ((res (handle-exceptions exn (read-json (get-condition-property exn 'client-error 'body))
                                  (with-input-from-request req #f read-json))))
      (if (alist-ref 'account res)
          (if (string=? (alist-ref 'status (alist-ref 'account res)) "active")
              `((success . #t)
                (result ,res))
              '((success . #f)
                (errors ((message . "Token is valid but account status is not 'active'.")))))
          `((success . #f)
            (errors ((message . ,(alist-ref 'message res)))))))))

;; (define (test-backblaze-connection key-id application-key bucket-url)
;;   )

(define (deployment-directory user-id instance-id)
  (string-append "deploy-" (number->string user-id) "-" (->string instance-id)))

(define (setup-deploy-files dir state state-backup)
  (when (directory-exists? dir)
    (delete-directory dir #t))
  (create-directory dir)
  (process-wait (process-run (string-append "tar -xf nassella-latest.tar -C " dir)))
  (create-directory (string-append dir "/config"))
  (cond-expand
    (dev
     ;; in dev copy personal ssh key
     (copy-file "../config/ssh-keys" (string-append dir "/config/ssh-keys")))
    (else '()))
  (with-output-to-file (string-append dir "/terraform.tfstate") (lambda () (write-string state)))
  (with-output-to-file (string-append dir "/terraform.tfstate.backup") (lambda () (write-string state-backup))))

(define (parse-deployment-log log)
  (define (search complete in-progress)
    (cond ((irregex-search complete log)
           'complete)
          ((irregex-search in-progress log)
           'in-progress)
          (else 'queued)))
  `((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start"))
    ;; TODO this didn't seem to work right when upgrading the flatcar image
    ;; log: [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 "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Modifying"))
    (machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..."))
    (machine-destroy . ,(search "droplet.machine: Destruction complete"
                                '(: "droplet.machine (deposed object " (* alphanum) "): Destroying...")))))

(define (write-config-entry name value)
  (display name)
  (display "=\"")
  (display value)
  (print "\""))

(define (progress-status->text status)
  (case status
    ((queued) "queued")
    ((in-progress) "in progress")
    ((complete) "complete")
    ((failed) "failed")))

;; (with-db/transaction
;;  (lambda (db)
;;    (update-instance-ssh-pub-key db 1 22 "")))

;; (with-db/transaction
;;  (lambda (db)
;;    (get-instance-ssh-pub-key db 1 22)))

;; Generates an ssh key via ssh-keygen running in docker
;; Returns a list with the first element being the private key
;; and the second element being the corresponding public key.
;; Does not leave a trace of the generated keys on the filesystem.
(define (generate-ssh-key user-id)
  (define (generate-ssh-key_ filepath counter)
    (if (directory-exists? (conc filepath counter))
        (generate-ssh-key_ filepath (+ counter 1))
        (conc filepath counter)))
  (let ((key-path (generate-ssh-key_ (conc "temp-ssh-keys-" user-id "-") 0)))
    (create-directory key-path)
    (receive (in-port out-port pid err-port)
        ;; There are docker images that exist that include ssh-keygen
        ;; but none of them are "official". For something sensitive like
        ;; this it seems much better to only use an official image so there
        ;; is less chance of an image doing something malicious and we don't
        ;; notice when updating the image this command uses.
        ;;
        ;; This command maps a volume to the unique directory we created above
        ;; and uses that to store the generated ssh keys.
        ;; Later on this directory gets deleted after we read the keys into
        ;; strings to return from this function.
        (cond-expand
          (dev
           (create-directory key-path)
           (process* "docker" `("run" "--rm" "--volume"
                                ,(conc (current-directory) "/" key-path ":/opt/keys")
                                "debian:12-slim" "bash" "-c" "apt update
apt install -y openssh-client
ssh-keygen -t ed25519 -f /opt/keys/key -N \"\"
chmod -R 777 /opt/keys")))
          (else
           (process* "ssh-keygen" `("-t" "ed25519" "-f" ,(conc (current-directory) "/" key-path "/key") "-N" "\"\""))))
      (let ((thread
             (thread-start!
              (lambda ()
                (let loop ()
                  (thread-sleep! 1)
                  ;; We do a non-blocking wait here so that we don't
                  ;; block the entire web process.
                  (receive (wait-pid exit-normal status) (process-wait pid #t)
                    (if (= wait-pid 0) ;; wait-pid is 0 until the process has finished
                        (loop)
                        (if exit-normal
                            (begin
                              (with-input-from-port in-port read-string) ;; left here for debugging and to clear ports
                              (with-input-from-port err-port read-string)
                              ;; left here for debugging and to clear ports
                              (let ((priv-key (with-input-from-file (conc key-path "/key") read-string))
                                    (pub-key (with-input-from-file (conc key-path "/key.pub") read-string)))
                                (delete-directory key-path #t)
                                (list priv-key pub-key)))
                            (begin (log-to (debug-log) "generate-ssh-key: docker command error")
                                   (error "Generating ssh key docker command had abnormal exit"))))))))))
        (thread-join! thread)))))

(define (generate-restic-password)
  (generator->string (gtake (make-random-char-generator
                             "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
                            30)))

(define (generate-jwt-secret)
  (generator->string (gtake (make-random-char-generator
                             "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
                            32)))

(define (generate-key-seed)
  (generator->string (gtake (make-random-char-generator
                             "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()_-+={}[]|<>,.?")
                            32)))

(define (generate-authelia-key-seed)
  (generator->string (gtake (make-random-char-generator
                             "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
                            64)))

(define (generate-postgres-password)
  (generator->string (gtake (make-random-char-generator
                             "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
                            40)))

(define (generate-redis-password)
  (generator->string (gtake (make-random-char-generator
                             "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
                            40)))

(with-schematra-app app
  (lambda ()

;;; UNSECURED PAGES
(get/widgets
 ("/unsecured/account/create")
 `(App
   (form
    (@ (action "/unsecured/account/create-submit") (method POST))
    (VStack
     (Fieldset
      (@ (title "Account Details"))
      (Field (@ (name "username") (label ("Username"))))
      (input (@ (type "hidden") (name "sid") (value ,(alist-ref 'sid (current-params) equal?))))
      (Button (@ (type "submit")) "Create Account"))))))

(post "/unsecured/account/create-submit"
  (let ((email (stripe-session-email (alist-ref 'sid (current-params))))
        (username (alist-ref 'username (current-params))))
    (create-lldap-user username email)
    (with-db/transaction (lambda (db) (create-user db email username))))
  (redirect "/authelia/reset-password"))

;;; REQUIRES AUTHED USER
(post "/config/wizard/create-instance"
 (let* ((ssh-keys (generate-ssh-key (session-user-id)))
        (instance-id (with-db/transaction
                      (lambda (db)
                        (create-instance db (session-user-id) (first ssh-keys) (second ssh-keys)
                                         (generate-restic-password))))))
   (redirect (conc "/config/wizard/services/" instance-id))))

;; TODO should all these key related form fields be of type password
;; so the browser doesn't save them???
(get/widgets
 ("/config/wizard/services/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (config (with-db/transaction
                 (lambda (db)
                   (get-user-service-config db (session-user-id)
                                            instance-id)))))
   `(App
     (Configuration-Wizard
      (@ (step "Services"))
      (form
       (@ (action ,(conc "/config/wizard/services-submit/" instance-id))
          (method POST))
       (VStack
        (Fieldset
         (@ (title "Cloudflare"))
         (Field (@ (name "cloudflare-api-token") (label ("API Token")) (type "password")
                   (value ,(alist-ref 'cloudflare-api-token config))))
         (Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (type "password")
                   (value ,(alist-ref 'cloudflare-zone-id config))))
         (Field (@ (name "cloudflare-account-id") (label ("Account ID")) (type "password")
                   (value ,(alist-ref 'cloudflare-account-id config)))))
        (Fieldset
         (@ (title "DigitalOcean"))
         (Field (@ (name "digitalocean-api-token") (label ("API Token")) (type "password")
                   (value ,(alist-ref 'digitalocean-api-token config)))))
        (Fieldset
         (@ (title "Backblaze"))
         (Field (@ (name "backblaze-application-key") (label ("Application Key"))
                   (type "password")
                   (value ,(alist-ref 'backblaze-application-key config))))
         (Field (@ (name "backblaze-key-id") (label ("Key ID")) (type "password")
                   (value ,(alist-ref 'backblaze-key-id config))))
         (Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (type "password")
                   (value ,(alist-ref 'backblaze-bucket-url config)))))
        (Form-Nav)))))))

(post "/config/wizard/services-submit/:id"
 (let ((instance-id (alist-ref "id" (current-params) equal?)))
   (with-db/transaction
    (lambda (db)
      (update-user-service-config
       db
       (session-user-id)
       instance-id
       `((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (current-params)))
         (cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (current-params)))
         (cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (current-params)))
         (digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (current-params)))
         (backblaze-application-key . ,(alist-ref 'backblaze-application-key (current-params)))
         (backblaze-key-id . ,(alist-ref 'backblaze-key-id (current-params)))
         (backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (current-params)))))))
   (redirect (conc "/config/wizard/services-success/" instance-id))))

(get/widgets
 ("/config/wizard/services-success/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (service-config
         (with-db/transaction
          (lambda (db)
            (get-user-service-config db (session-user-id) instance-id))))
        (cloudflare-result (test-cloudflare-connection (alist-ref 'cloudflare-api-token service-config)
                                                       (alist-ref 'cloudflare-zone-id service-config)
                                                       (alist-ref 'cloudflare-account-id service-config)))
        (digitalocean-result (test-digitalocean-connection (alist-ref 'digitalocean-api-token service-config))))
   `(App
     (Configuration-Wizard
      (@ (step "Services"))
      (form
       (@ (action ,(conc "/config/wizard/apps/" instance-id)))
       (VStack
        (Fieldset
         (@ (title "Cloudflare"))
         ,@(if (alist-ref 'success cloudflare-result)
               `((h3 "Connected")
                 (p "Your Cloudflare account was successfully connected!"))
               `((h3 "Connection Failed")
                 (p "Unable to make a connection via Cloudflare API. Message is: \""
                    ,(string-intersperse
                      (map (lambda (err)
                             (alist-ref 'message err))
                           (alist-ref 'errors cloudflare-result))
                      "\" & \"")
                    "\""))))
        (Fieldset
         (@ (title "DigitalOcean"))
         ,@(if (alist-ref 'success digitalocean-result)
               `((h3 "Connected")
                 (p "Your DigitalOcean account was successfully connected!"))
               `((h3 "Connection Failed")
                 (p "Unable to make a connection via DigitalOcean API. Message is: \""
                    ,(string-intersperse
                      (map (lambda (err)
                             (alist-ref 'message err))
                           (alist-ref 'errors digitalocean-result))
                      "\" & \"")
                    "\""))))
        (Fieldset
         (@ (title "Backblaze"))
         (h3 "Connected")
         (p "Your Backblaze account was successfully connected!"))
        (Form-Nav (@ (back-to ,(conc "/config/wizard/services/" instance-id))
                     (submit-enabled ,(and (alist-ref 'success cloudflare-result)
                                           (alist-ref 'success digitalocean-result)))))))))))

(get/widgets
 ("/config/wizard/apps/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (results
         (with-db/transaction
          (lambda (db)
            `((selected-apps . ,(map
                                 car
                                 (filter cdr
                                         (get-user-selected-apps db (session-user-id) instance-id))))
              (app-config . ,(get-user-app-config db (session-user-id) instance-id))
              (service-config . ,(get-user-service-config db (session-user-id) instance-id)))))))
   `(App
     (Configuration-Wizard
      (@ (step "Apps"))
      (form
       (@ (action ,(conc "/config/wizard/apps-submit/" instance-id)) (method POST))
       (VStack
        (Fieldset
         (@ (title "Root Domain"))
         (Field (@ (element select) (name "root-domain"))
                ,@(map (lambda (domain)
                         `(option (@ (value ,domain)
                                     ,@(if (equal? domain
                                                   (alist-ref 'root-domain (alist-ref 'app-config results)))
                                           '(selected)
                                           '()))
                                  ,domain))
                       (get-cloudflare-domains (alist-ref 'cloudflare-api-token
                                                          (alist-ref 'service-config results))))
                ))
        (Fieldset
         (@ (title "Selected Apps"))
         (Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps results)))))
         (Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'nextcloud (alist-ref 'selected-apps results)))))
         (Field (@ (name "ghost") (type "checkbox") (label ("Ghost")) (checked ,(member 'ghost (alist-ref 'selected-apps results)))))
         ,@(cond-expand
            (dev
             `((Field (@ (name "nassella") (type "checkbox") (label ("Nassella")) (checked ,(member 'nassella (alist-ref 'selected-apps results)))))))
            (else
             '()))
         (Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
        ;; TODO add config for when automatic upgrades are scheduled for?
        ;; TODO add config for server timezone?
        (Form-Nav (@ (back-to ,(conc "/config/wizard/services-success/" instance-id))))))))))

(post "/config/wizard/apps-submit/:id"
  (let ((instance-id (alist-ref "id" (current-params) equal?)))
    (with-db/transaction
     (lambda (db)
       (update-user-selected-apps
        db
        (session-user-id)
        instance-id
        `((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "15.1.0") (sql-null)))
          (nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "31.0.8") (sql-null)))
          (ghost . ,(or (and (alist-ref 'ghost (current-params)) "6.10.0") (sql-null)))
          (nassella . ,(or (and (alist-ref 'nassella (current-params)) "b0.0.1") (sql-null)))))
       (update-root-domain db
                           (session-user-id)
                           instance-id
                           (alist-ref 'root-domain (current-params)))))
    (redirect (conc "/config/wizard/apps2/" instance-id))))

(get/widgets
 ("/config/wizard/apps2/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (results
         (with-db/transaction
          (lambda (db)
            `((selected-apps . ,(map
                                 car
                                 (filter cdr
                                         (get-user-selected-apps db (session-user-id) instance-id))))
              (app-config . ,(get-user-app-config db (session-user-id) instance-id))))))
        (selected-apps (alist-ref 'selected-apps results))
        (app-config (alist-ref 'config (alist-ref 'app-config results))))
   `(App
     (Configuration-Wizard
      (@ (step "Apps"))
      (form
       (@ (action ,(conc "/config/wizard/apps2-submit/" instance-id)) (method POST))
       (VStack
        ,@(if (member 'ghost selected-apps)
              `((Fieldset
                 (@ (title "Ghost"))
                 (Field (@ (name "ghost-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'ghost app-config eq? '()) eq? "ghost"))))))
              '())
        ,@(if (member 'wg-easy selected-apps)
              `((Fieldset
                 (@ (title "WG-Easy"))
                 (Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'wg-easy app-config eq? '()) eq? "wg-easy"))))))
              '())
        ,@(if (member 'nextcloud selected-apps)
              `((Fieldset
                 (@ (title "NextCloud"))
                 (Field (@ (name "nextcloud-subdomain") (label ("Subdomain"))
                           (value ,(alist-ref 'subdomain (alist-ref 'nextcloud app-config eq? '()) eq? "nextcloud"))))
                 (Field (@ (name "nextcloud-admin-user") (label ("Admin Username"))
                           (value ,(alist-ref 'admin-user (alist-ref 'nextcloud app-config eq? '()) eq? "admin"))))
                 (Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password")
                           (value ,(alist-ref 'admin-password (alist-ref 'nextcloud app-config eq? '()) eq? ""))))))
              '())
        ,@(if (member 'nassella selected-apps)
              `((Fieldset
                 (@ (title "Nassella"))
                 (Field (@ (name "nassella-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'nassella app-config eq? '()) eq? "app"))))
                 (Field (@ (name "nassella-lldap-subdomain") (label ("LLDAP Subdomain"))
                           (value ,(alist-ref 'lldap-subdomain (alist-ref 'nassella app-config eq? '()) eq? "lldap"))))
                 (Field (@ (name "nassella-lldap-admin-password") (label ("Admin Password")) (type "password")
                           (value ,(alist-ref 'lldap-admin-password (alist-ref 'nassella app-config eq? '()) eq? ""))))
                 (Field (@ (name "nassella-stripe-api-key") (label ("Stripe API Key")) (type "password")
                           (value ,(alist-ref 'stripe-api-key (alist-ref 'nassella app-config eq? '()) eq? ""))))))
              '())
        (Fieldset
         (@ (title "Log Viewer"))
         (Field (@ (name "log-viewer-subdomain") (label ("Subdomain"))
                   (value ,(alist-ref 'subdomain (alist-ref 'log-viewer app-config eq? '()) eq? "logs"))))
         (Field (@ (name "log-viewer-user") (label ("Username"))
                   (value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
         (Field (@ (name "log-viewer-password") (label ("Password")) (type "password")
                   (value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? "")))))
        ,@(if (or (member 'nextcloud selected-apps) (member 'ghost selected-apps) (member 'nassella selected-apps))
              `((Fieldset
                 (@ (title "All Apps - Email - SMTP"))
                 (Field (@ (name "smtp-host") (label ("Host"))
                           (value ,(alist-ref 'smtp-host (alist-ref 'all-apps app-config eq? '()) eq? ""))))
                 (Field (@ (name "smtp-port") (label ("Port"))
                           (value ,(alist-ref 'smtp-port (alist-ref 'all-apps app-config eq? '()) eq? ""))))
                 (Field (@ (name "smtp-auth-user") (label ("Auth User"))
                           (value ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps app-config eq? '()) eq? ""))))
                 (Field (@ (name "smtp-auth-password") (label ("Auth Password")) (type "password")
                           (value ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps app-config eq? '()) eq? ""))))
                 (Field (@ (name "smtp-from") (label ("From"))
                           (value ,(alist-ref 'smtp-from (alist-ref 'all-apps app-config eq? '()) eq? "My Name <no-reply@example.org>"))))))
              '())
        (Form-Nav (@ (back-to ,(conc "/config/wizard/apps/" instance-id))))))))))

(post "/config/wizard/apps2-submit/:id"
 (let ((instance-id (alist-ref "id" (current-params) equal?)))
   (with-db/transaction
    (lambda (db)
      (let ((config (alist-ref 'config (get-user-app-config db (session-user-id) instance-id))))
        (update-user-app-config
         db
         (session-user-id)
         instance-id
         `((ghost . ((subdomain . ,(alist-ref 'ghost-subdomain (current-params)))
                     (postgres-root-password . ,(or (alist-ref 'postgres-root-password
                                                               (alist-ref 'ghost config eq? '()))
                                                    (generate-postgres-password)))
                     (postgres-password . ,(or (alist-ref 'postgres-password
                                                          (alist-ref 'ghost config eq? '()))
                                               (generate-postgres-password)))))
           (wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params)))))
           (nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params)))
                         (admin-user . ,(alist-ref 'nextcloud-admin-user (current-params)))
                         (admin-password . ,(alist-ref 'nextcloud-admin-password (current-params)))
                         (postgres-password . ,(or (alist-ref 'postgres-password
                                                              (alist-ref 'nextcloud config eq? '()))
                                                   (generate-postgres-password)))
                         (redis-password . ,(or (alist-ref 'redis-password
                                                           (alist-ref 'nextcloud config eq? '()))
                                                (generate-redis-password)))))
           (nassella . ((subdomain . ,(alist-ref 'nassella-subdomain (current-params)))
                        (postgres-password . ,(or (alist-ref 'postgres-password
                                                             (alist-ref 'nassella config eq? '()))
                                                  (generate-postgres-password)))
                        (authelia-postgres-password . ,(or (alist-ref 'authelia-postgres-password
                                                                      (alist-ref 'nassella config eq? '()))
                                                           (generate-postgres-password)))
                        (lldap-postgres-password . ,(or (alist-ref 'lldap-postgres-password
                                                                      (alist-ref 'nassella config eq? '()))
                                                           (generate-postgres-password)))
                        (lldap-jwt-secret . ,(or (alist-ref 'lldap-jwt-secret
                                                                      (alist-ref 'nassella config eq? '()))
                                                           (generate-jwt-secret)))
                        (lldap-key-seed . ,(or (alist-ref 'lldap-key-seed
                                                                      (alist-ref 'nassella config eq? '()))
                                                           (generate-key-seed)))
                        (lldap-subdomain . ,(alist-ref 'nassella-lldap-subdomain (current-params)))
                        (lldap-admin-password . ,(alist-ref 'nassella-lldap-admin-password (current-params)))
                        (stripe-api-key . ,(alist-ref 'nassella-stripe-api-key (current-params)))
                        (authelia-jwt-secret . ,(or (alist-ref 'authelia-jwt-secret
                                                               (alist-ref 'nassella config eq? '()))
                                                    (generate-jwt-secret)))
                        (authelia-key-seed . ,(or (alist-ref 'authelia-key-seed
                                                              (alist-ref 'nassella config eq? '()))
                                                   (generate-authelia-key-seed)))))
           (log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
                          (user . ,(alist-ref 'log-viewer-user (current-params)))
                          (password . ,(alist-ref 'log-viewer-password (current-params)))))
           (all-apps . ((smtp-host . ,(alist-ref 'smtp-host (current-params)))
                        (smtp-port . ,(alist-ref 'smtp-port (current-params)))
                        (smtp-auth-user . ,(alist-ref 'smtp-auth-user (current-params)))
                        (smtp-auth-password . ,(alist-ref 'smtp-auth-password (current-params)))
                        (smtp-from . ,(alist-ref 'smtp-from (current-params))))))))))
   (redirect (conc "/config/wizard/machine/" instance-id))))

(get/widgets
 ("/config/wizard/machine/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (config (with-db/transaction
                 (lambda (db)
                   (get-user-service-config db (session-user-id) instance-id)))))
   `(App
     (Configuration-Wizard
      (@ (step "Machine"))
      (form
       (@ (action ,(conc "/config/wizard/machine-submit/" instance-id))
          (method POST))
       (VStack
        (Fieldset
         (@ (title "Region"))
         (Field (@ (element select) (name "region"))
                (option (@ (value "")) "")
                ,@(map (lambda (r)
                         `(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r)))
                       (get-digital-ocean-regions (alist-ref 'digitalocean-api-token config)))))
        (Form-Nav (@ (back-to ,(conc "/config/wizard/apps2/" instance-id))))))))))

;; TODO if the region is changed, all of the data is DELETED because the
;; volume is deleted and re-created
(post "/config/wizard/machine-submit/:id"
      (let ((instance-id (alist-ref "id" (current-params) equal?)))
        (with-db/transaction
         (lambda (db)
           (update-user-service-config
            db
            (session-user-id)
            instance-id
            `((digitalocean-region . ,(alist-ref 'region (current-params)))))))
        (redirect (conc "/config/wizard/machine2/" instance-id))))

(get/widgets
 ("/config/wizard/machine2/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (config (with-db/transaction
                 (lambda (db)
                   (get-user-service-config db (session-user-id) instance-id))))
        (region (alist-ref 'digitalocean-region config))
        (all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token config)))
        (sizes (filter (lambda (s) (member region (alist-ref 'regions s))) all-sizes)))
   `(App
     (Configuration-Wizard
      (@ (step "Machine"))
      (form
       (@ (action ,(conc "/config/wizard/machine2-submit/" instance-id))
          (method POST))
       (VStack
        (Fieldset
         (@ (title "Size"))
         (Field (@ (element select) (name "size") (input-style ((max-width "100%"))))
                ,@(map (lambda (s) `(option (@ (value ,(alist-ref 'slug s))
                                               ,@(if (equal? (alist-ref 'slug s) "s-2vcpu-2gb") `((selected "selected")) '()))
                                            "$" ,(alist-ref 'price_monthly s)
                                            " (CPU: ",(alist-ref 'vcpus s)
                                            " Mem: " ,(/ (alist-ref 'memory s) 1024)
                                            " Disk: " ,(alist-ref 'disk s)
                                            ") " ,(alist-ref 'description s)))
                       sizes)))
        (Form-Nav (@ (back-to ,(conc "/config/wizard/machine/" instance-id))))))))))

(post "/config/wizard/machine2-submit/:id"
 (let ((instance-id (alist-ref "id" (current-params) equal?)))
   (with-db/transaction
    (lambda (db)
      (update-user-service-config
       db
       (session-user-id)
       instance-id
       `((digitalocean-size . ,(alist-ref 'size (current-params)))))))
   (redirect (conc "/config/wizard/review/" instance-id))))

(get/widgets
 ("/config/wizard/review/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (results
         (with-db/transaction
          (lambda (db)
            `((selected-apps . ,(map
                                 car
                                 (filter cdr
                                         (get-user-selected-apps db (session-user-id) instance-id))))
              (app-config . ,(get-user-app-config db (session-user-id) instance-id))
              (service-config . ,(get-user-service-config db (session-user-id) instance-id))))))
        (selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
        (app-config (alist-ref 'app-config results))
        (config (alist-ref 'config app-config))
        (root-domain (alist-ref 'root-domain app-config))
        (service-config (alist-ref 'service-config results)))
   `(App
     (Configuration-Wizard
      (@ (step "Review"))
      (h2 "Root Domain")
      ,root-domain
      (h2 "Apps") ;; TODO if an app that was previously selected is now unselected we need to somehow delete its data
                  ;; so that if the user then re-deploys the app later we don't have key conflicts
      (ul ,@(map (lambda (app) `(li ,app " @ "
                                    ,(alist-ref 'subdomain (alist-ref app config))
                                    "."
                                    ,root-domain))
                 selected-apps))
      (h2 "Machine")
      (ul (li "Region: " ,(alist-ref 'digitalocean-region service-config))
          (li "Size: " ,(alist-ref 'digitalocean-size service-config)))
      (form
       (@ (action ,(conc "/config/wizard/review-submit/" instance-id)) (method POST))
       (VStack
        (Form-Nav (@ (back-to ,(conc "/config/wizard/machine2/" instance-id)) (submit-button "Launch")))))))))

;; TODO run restic-init if needed (like the first run or if the backblaze
;; config changes
;; TODO should this perform a backup and then run the systemctl stop app command first?
(post "/config/wizard/review-submit/:id"
  (let* ((instance-id (alist-ref "id" (current-params) equal?))
         (status (string->symbol
                  (->string
                   (with-db/transaction
                    (lambda (db)
                      (get-most-recent-deployment-status db (session-user-id) instance-id)))))))
    (when (not (or (eq? status 'queued) (eq? status 'in-progress)))
      (let* ((instance-id (alist-ref "id" (current-params) equal?))
             (restic-snapshot-id (alist-ref 'restic-snapshot-id (current-params)))
             (results
              (with-db/transaction
               (lambda (db)
                 `((selected-apps . ,(map
                                      car
                                      (filter cdr
                                              (get-user-selected-apps db (session-user-id) instance-id))))
                   (app-config . ,(get-user-app-config db (session-user-id) instance-id))
                   (service-config . ,(get-user-service-config db (session-user-id) instance-id))
                   (terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))
                   (ssh-pub-key . ,(get-instance-ssh-pub-key db (session-user-id) instance-id))
                   (restic-password . ,(get-instance-restic-password db (session-user-id) instance-id))))))
             (selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
             (app-config (alist-ref 'app-config results))
             (config (alist-ref 'config app-config))
             (root-domain (alist-ref 'root-domain app-config))
             (service-config (alist-ref 'service-config results))
             (terraform-state (alist-ref 'terraform-state results))
             (ssh-pub-key (alist-ref 'ssh-pub-key results))
             (restic-password (alist-ref 'restic-password results))
             (dir (deployment-directory (session-user-id) instance-id)))
        (setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
        (with-output-to-file (string-append dir "/config/apps.config")
          (lambda ()
            (map (lambda (e)
                   (write-config-entry (car e) (cdr e)))
                 `(("ROOT_DOMAIN" . ,root-domain)
                   ("APP_CONFIGS" . ,(string-intersperse
                                      (map (lambda (app)
                                             (conc (if (eq? app 'log-viewer) 'dozzle app)
                                                   ","
                                                   (alist-ref 'subdomain (alist-ref app config))))
                                           selected-apps)
                                      " "))
                   ("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
                   ("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config)))
                   ("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
                   ("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
                   ("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
                   ("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
                   ("NEXTCLOUD_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nextcloud config)))
                   ("NEXTCLOUD_REDIS_PASSWORD" . ,(alist-ref 'redis-password (alist-ref 'nextcloud config)))
                   ("GHOST_DATABASE_ROOT_PASSWORD" . ,(alist-ref 'postgres-root-password (alist-ref 'ghost config)))
                   ("GHOST_DATABASE_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'ghost config)))
                   ("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config)))
                   ("NASSELLA_POSTGRES_DB" . "nassella")
                   ("NASSELLA_POSTGRES_USER" . "nassella")
                   ("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config)))
                   ("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia")
                   ("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia")
                   ("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config)))
                   ("NASSELLA_LLDAP_POSTGRES_DB" . "lldap")
                   ("NASSELLA_LLDAP_POSTGRES_USER" . "lldap")
                   ("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config)))
                   ("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config)))
                   ("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config)))
                   ("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config)))
                   ("NASSELLA_STRIPE_API_KEY" . ,(alist-ref 'stripe-api-key (alist-ref 'nassella config)))
                   ("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config)))
                   ("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella config)))
                   ("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
                   ("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
                   ("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
                   ("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
                   ("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
                   ("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
                   ("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
                   ("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
                   ("RESTIC_PASSWORD" . ,restic-password)
                   ,@(if (and restic-snapshot-id (not (string=? restic-snapshot-id ""))) `(("RESTIC_SNAPSHOT_ID" . ,restic-snapshot-id)) '())))))
        (with-output-to-file (string-append dir "/config/production.tfvars")
          (lambda ()
            (map (lambda (e)
                   (write-config-entry (car e) (cdr e)))
                 `(("server_type" . ,(alist-ref 'digitalocean-size service-config))
                   ("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
                   ("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
                   ("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
                   ("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
                   ("cluster_name" . "nassella")
                   ("datacenter" . ,(alist-ref 'digitalocean-region service-config))
                   ;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
                   ("flatcar_stable_version" . "4459.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))
             (deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
             (dir (deployment-directory user-id instance-id)))
        (thread-start!
         (lambda ()
           (change-directory dir)
           (let ((pid (process-run "make apply > make-out 2>&1")))
             (with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
             (change-directory "../")
             (let loop ()
               (thread-sleep! 5)
               (receive (pid exit-normal status) (process-wait pid #t)
                 (if (= pid 0) ;; process is still running
                     (begin (let ((progress (parse-deployment-log
                                             (with-input-from-file
                                                 (string-append (deployment-directory user-id instance-id) "/make-out")
                                               read-string)))
                                  (tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string))
                                  (tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))
                              (with-db/transaction
                               (lambda (db)
                                 (update-deployment-progress db deployment-id progress)
                                 (when (file-exists? (string-append dir "/terraform.tfstate"))
                                   (update-user-terraform-state db user-id instance-id
                                                                (if (eof-object? tf-state) "" tf-state)
                                                                (if (eof-object? tf-state-backup) "" tf-state-backup))))))
                            (loop))
                     (let ((progress (parse-deployment-log
                                      (with-input-from-file
                                          (string-append (deployment-directory user-id instance-id) "/make-out")
                                        read-string)))
                           (tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string))
                           (tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))
                       (with-db/transaction
                        (lambda (db)
                          (update-deployment-progress db deployment-id progress)
                          ;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES
                          ;; like the random digital ocean error saying the IP can't be
                          ;; updated because another operation is in progress.
                          ;; it still registers as "success".
                          ;; probably need to also write stderr to a file and read/store/parse that?
                          ;; Should we parse make-out for string "Apply complete!" ?
                          (update-deployment-status
                           db user-id deployment-id
                           (if exit-normal 'complete 'failed)
                           (with-input-from-file (string-append dir "/make-out") read-string))
                          (update-user-terraform-state db user-id instance-id
                                                       (if (eof-object? tf-state) "" tf-state)
                                                       (if (eof-object? tf-state-backup) "" tf-state-backup))))))))))))))
      (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))

(get/widgets
 ("/config/wizard/success/:id"
  (let* ((instance-id (alist-ref "id" (current-params) equal?))
         (res (with-db/transaction
               (lambda (db)
                 `((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))))))
         (status (string->symbol (alist-ref 'status res))))
    (if (or (eq? status 'complete) (eq? status 'failed))
        '()
        '((meta (@ (http-equiv "refresh") (content "5")))))))
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (res (with-db/transaction
              (lambda (db)
                `((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))
                  (progress . ,(get-most-recent-deployment-progress db (session-user-id) instance-id))))))
        (output (with-input-from-file (string-append (deployment-directory (session-user-id) instance-id) "/make-out") read-string))
        (progress (alist-ref 'progress res))
        (status (alist-ref 'status res)))
   `(App
     (Main-Container
      (VStack
       (h1
        ,(case (string->symbol status)
           ((queued) "Deployment queued")
           ((in-progress) "Deployment in progress")
           ((complete) "Deployment complete!")
           ((failed) "Deployment failed")))
       (ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
           (li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
           (li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress)))
           (li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
       (div
        (a (@ (href "/dashboard")) "Dashboard")
        ,@(if (or (eq? (string->symbol status) 'complete) (eq? (string->symbol status) 'failed))
              '()
              " (deployment will continue in the background if you leave this page)"))
       (hr)
       (pre (@ (style ((overflow-x "scroll"))))
            ,output)
       )))))

(get/widgets
 ("/dashboard")
 `(App
   (Main-Container
    (main
     (h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Instances")
     (form
      (@ (action "/config/wizard/create-instance")
         (method POST))
      (Button "Setup New Instance"))
     (ul ,@(map (lambda (instance)
                  (let ((root-domain (alist-ref 'root-domain instance))
                        (config (alist-ref 'config instance)))
                    `(li (VStack
                          (h2 ,root-domain)
                          (HStack
                           "status: " ,(if (equal? (alist-ref 'status instance) "complete")
                                           "deployed successfully"
                                           (alist-ref 'status instance)))
                          (h3 "Apps")
                          (ul ,@(filter
                                 identity
                                 (map (lambda (app-map)
                                        (let ((app (car app-map))
                                              (doc-url (cdr app-map)))
                                          (if (or (alist-ref app instance)
                                                  (eq? app 'log-viewer))
                                              `((li (a (@ (href ,doc-url)) ,app)
                                                    " (v" ,(alist-ref app instance eq? "-") ") "
                                                    (a (@ (href "https://"
                                                                ,(alist-ref 'subdomain (alist-ref app config))
                                                                "." ,root-domain))
                                                       ,(alist-ref 'subdomain (alist-ref app config))
                                                       "." ,root-domain)))
                                              #f)))
                                      '((wg-easy . "https://wg-easy.github.io/wg-easy/Pre-release/")
                                        (nextcloud . "https://nextcloud.com/support/")
                                        (ghost . "https://nextcloud.com/support/")
                                        (nassella . "https://nextcloud.com/support/")
                                        (log-viewer . "https://nextcloud.com/support/")))))
                          (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)))))
        (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" . "4459.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)
                             ;; TODO THIS DOESN'T WORK RIGHT FOR TERRAFORM OP FAILURES
                             ;; like the random digital ocean error saying the IP can't be
                             ;; updated because another operation is in progress.
                             ;; it still registers as "success".
                             ;; probably need to also write stderr to a file and read/store/parse that?
                             ;; Should we parse make-out for string "Apply complete!" ?
                             (update-deployment-status
                              db user-id deployment-id
                              (if exit-normal 'complete 'failed)
                              (with-input-from-file (string-append dir "/make-out") read-string))
                             (update-user-terraform-state db user-id instance-id
                                                          (if (eof-object? tf-state) "" tf-state)
                                                          (if (eof-object? tf-state-backup) "" tf-state-backup))
                             (when exit-normal
                               (destroy-instance db instance-id))))))))))))
         (redirect (conc "/destroy-success/" (alist-ref "id" (current-params) equal?)))))))

(get/widgets
 ("/destroy-success/:id"
  (let* ((instance-id (alist-ref "id" (current-params) equal?))
         (res (with-db/transaction
               (lambda (db)
                 `((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))))))
         (status (or (and (alist-ref 'status res) (string->symbol (alist-ref 'status res))) 'destroyed)))
    (if (or (eq? status 'complete) (eq? status 'failed) (eq? status 'destroyed))
        '()
        '((meta (@ (http-equiv "refresh") (content "5")))))))
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (res (with-db/transaction
              (lambda (db)
                `((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))
                  (progress . ,(get-most-recent-deployment-progress db (session-user-id) instance-id))))))
        (output (with-input-from-file (string-append (deployment-directory (session-user-id) instance-id) "/make-out") read-string))
        (progress (alist-ref 'progress res))
        (status (alist-ref 'status res)))
   `(App
     (Main-Container
      (VStack
       (h1
        ,(case (string->symbol status)
           ((queued) "Destroy queued")
           ((in-progress) "Destroy in progress")
           ((destroyed) "Destroy complete!")
           ((failed) "Destroy failed")))
       ,@(if (eq? status 'destroyed)
            '((a (@ (href "/dashboard")) "Dashboard"))
            `((ul (li "generate configs: " ,(progress-status->text (alist-ref 'generate-configs progress)))
                   (li "custom flatcar image: " ,(progress-status->text (alist-ref 'custom-image progress)))
                   (li "machine create: " ,(progress-status->text (alist-ref 'machine-create progress)))
                   (li "cleanup previous machine: " ,(progress-status->text (alist-ref 'machine-destroy progress))))
              (div
               (a (@ (href "/dashboard")) "Dashboard")
               ,@(if (or (eq? (string->symbol status) 'complete) (eq? (string->symbol status) 'failed))
                     '()
                     " (deployment will continue in the background if you leave this page)"))
              (hr)
              (pre (@ (style ((overflow-x "scroll"))))
                   ,output)))
       )))))

(get/widgets
 ("/backups/: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))
        ;;           (progress . ,(get-most-recent-deployment-progress db (session-user-id) instance-id))))))
)
   `(App
     (Main-Container
      (VStack
       (h1 "Backups")
       (a (@ (href "/")) "Create Snapshot") ;; TODO
       (table
        (thead
         (tr (th "Time") (th "Size") (th "Tag") (th "*")))
        (tbody
         (tr (td "2026-04-22 22:24:41") (td "139.742 MiB") (td "") (td (a (@ (href "/")) "Restore")))
         (tr (td "2026-04-21 12:01:03") (td "139.742 MiB") (td "before upgrade") (td (a (@ (href "/")) "Restore")))
         (tr (td "2026-04-21 22:24:41") (td "129.742 MiB") (td "") (td (a (@ (href "/")) "Restore"))))))))))

(schematra-install)

))