app/src/nassella.scm

;; Copyright 2025-2026 Thomas Hintz

;; This file is part of Nassella.

;; Nassella is free software: you can redistribute it and/or modify it under the
;; terms of the GNU Affero General Public License as published by the Free
;; Software Foundation, either version 3 of the License, or (at your option) any
;; later version.

;; Nassella is distributed in the hope that it will be useful, but WITHOUT ANY
;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with Nassella. If not, see <https://www.gnu.org/licenses/>.

;; (import (chicken platform))
;; (register-feature! 'dev)
;; (load "src/db.scm")
;; (load "src/mocks.scm")
(include "db")
(include "mocks")

(import (chicken string)
        (chicken port)
        (chicken io)
        (chicken pretty-print)
        (chicken process)
        (chicken process-context)
        (chicken irregex)
        (chicken file)
        (chicken condition)
        (chicken sort)
        (chicken random)

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

        html-widgets
        sxml-transforms
        schematra
        schematra.body-parser
        uri-common
        http-client
        medea
        intarweb
        nassella-db
        sql-null
        openssl
        spiffy
        hmac
        sha256-primitive
        string-hexadecimal
        base64)

(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 base))
                      (tint . "#bd7ab4")
                      (shade . "#64275e")
                      (tone . "#92528b")
                      (background . "#EBF6D3")
                      (background-contrast . "#983490")))
            (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))
                   (default . "#DAE7BD")))
            (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.base))
                                       (font-family ,($ 'font.family.label))
                                       (color ,($ 'color.primary.background-contrast)))))
         ,@contents))

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

(define-widget (Configuration-Wizard ((step "Services")) contents)
  `(VStack
    (@ (style ((border-top-width ,($ 'space.12))
               (border-top-color ,($ 'color.primary.background-contrast))
               (border-top-style "solid")
               (padding-top ,($ 'space.50))
               (border-bottom-width ,($ 'space.12))
               (border-bottom-color ,($ 'color.primary.background-contrast))
               (border-bottom-style "solid")
               (padding-bottom ,($ 'space.50)))))
    (h2 "Nassella - Instance Setup Wizard")
    (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 ((color ,($ 'color.primary.background-contrast))
               (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) (required #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)) '())
                             ,@(if required `((required)) '()))
                  ,@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)))

(define (status-pill-type->color type)
  (case type
    ((info) ($ 'color.util.info))
    ((safe) ($ 'color.util.safe))
    ((warning) ($ 'color.util.warning))
    ((alert) ($ 'color.util.alert))
    (else (error (conc "unknown pill type: " type)))))

(define-widget (Status-Pill ((type 'unknown) (style '())) contents) ;; type can be info, safe, warning, alert
  `(div (@ (style ((border-radius ,($ 'radius.pill))
                   (background ,(status-pill-type->color type))
                   (padding ,($ 'space.25) ,($ 'space.100))
                   (width "fit-content")
                   ,@style)))
        ,@contents))

(define-widget (Deployment-Status-Pill ((status 'unknown)))
  `(Status-Pill
    (@ (type ,(case status
                ((queued) 'info)
                ((in-progress) 'warning)
                ((complete) 'safe)
                ((failed) 'alert)))
       (style ((font-size ,($ 'font.size.s)))))
    ,(case status
       ((queued) "Queued")
       ((in-progress) "In Progress")
       ((complete) "Complete")
       ((failed) "Failed"))))

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

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

(define (send-stripe-request #!key (method 'GET) endpoint (body #f) (username ""))
  (define api-endpoint "https://api.stripe.com/")
  (define api-version "/v1")

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

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


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

;; returns something like:
;; ((accountId . "xxx") (apiInfo (storageApi (absoluteMinimumPartSize . 5000000) (allowed (buckets . #(((id . "yyy") (name . "aaa")))) (capabilities . #("readBucketEncryption" "listFiles" "shareFiles" "listBuckets" "readBucketLifecycleRules" "readBuckets" "readFiles" "writeBucketReplications" "writeBucketNotifications" "listAllBucketNames" "writeFiles" "writeBuckets" "writeBucketEncryption" "deleteFiles" "writeBucketLogging" "readBucketLogging" "readBucketReplications" "writeBucketLifecycleRules" "readBucketNotifications")) (namePrefix . null)) (apiUrl . "https://api004.backblazeb2.com") (downloadUrl . "https://f004.backblazeb2.com") (recommendedPartSize . 100000000) (s3ApiUrl . "https://s3.us-west-004.backblazeb2.com"))) (applicationKeyExpirationTimestamp . null) (authorizationToken . "abc"))
;; #<URI-common: scheme=https port=443 host="api.backblazeb2.com" path=(/ "b2api" "v4" "b2_authorize_account") query=() fragment=#f>
;; #<intarweb#response>
;; ; 3 values
(define (b2-authorize-account key-id key)
  (with-input-from-request
      (make-request method: 'GET
                    uri: (uri-reference "https://api.backblazeb2.com/b2api/v4/b2_authorize_account")
                    headers: (headers `((authorization #(,(string-append "Basic " (base64-encode (string-append key-id ":" key))) raw)))))
    #f
    read-json))

;; request response looks like
;; (((accountId . "xxx") (bucketId . "xxx") (bucketInfo) (bucketName . "xxx") (bucketType . "allPrivate") (corsRules) (defaultServerSideEncryption (isClientAuthorizedToRead . #t) (value (algorithm . null) (mode . null))) (fileLockConfiguration (isClientAuthorizedToRead . #t) (value (defaultRetention (mode . null) (period . null)) (isFileLockEnabled . #f))) (lifecycleRules ((daysFromHidingToDeleting . 1) (daysFromStartingToCancelingUnfinishedLargeFiles . null) (daysFromUploadingToHiding . null) (fileNamePrefix . ""))) (options "s3") (replicationConfiguration (isClientAuthorizedToRead . #t) (value . null)) (revision . 3)) ((accountId . "yyy") (bucketId . "yyy") (bucketInfo) (bucketName . "yyy") (bucketType . "allPrivate") (corsRules) (defaultServerSideEncryption (isClientAuthorizedToRead . #t) (value (algorithm . null) (mode . null))) (fileLockConfiguration (isClientAuthorizedToRead . #t) (value (defaultRetention (mode . null) (period . null)) (isFileLockEnabled . #f))) (lifecycleRules ((daysFromHidingToDeleting . 1) (daysFromStartingToCancelingUnfinishedLargeFiles . null) (daysFromUploadingToHiding . null) (fileNamePrefix . ""))) (options "s3") (replicationConfiguration (isClientAuthorizedToRead . #t) (value . null)) (revision . 3)))
(define (b2-list-buckets api-url account-token account-id)
  (with-input-from-request
      (make-request method: 'POST
                    uri: (uri-reference (string-append api-url "/b2api/v4/b2_list_buckets"))
                    headers: (headers `((authorization #(,account-token raw))
                                        (content-type application/json))))
    (lambda ()
      (write-json
       `((accountId . ,account-id))))
    read-json))

;; a convenience method used to retrieve the buckets either
;; from the key details or via b2-list-buckets.
;; depending on the key config and permissions the way you
;; access the list of buckets you can access will vary
(define (b2-account-buckets key-id key)
  (let* ((auth (b2-authorize-account key-id key))
         (authorization-token (alist-ref 'authorizationToken auth))
         (account-id (alist-ref 'accountId auth))
         (api-url (alist-ref 'apiUrl (alist-ref 'storageApi (alist-ref 'apiInfo auth))))
         (buckets (alist-ref 'buckets (alist-ref 'allowed (alist-ref 'storageApi (alist-ref 'apiInfo auth)))))
         (listed-buckets (and (eq? buckets 'null) ;; if the key does not contain a bucket restriction it should be able to use the api to list buckets
                                (alist-ref 'buckets (b2-list-buckets api-url authorization-token account-id)))))
    (if listed-buckets
        (map (lambda (bucket-info)
               `((name . ,(alist-ref 'bucketName bucket-info))
                 (id . ,(alist-ref 'bucketId bucket-info))))
             listed-buckets)
        (map (lambda (bucket-info)
               `((name . ,(alist-ref 'name bucket-info))
                 (id . ,(alist-ref 'id bucket-info))))
             buckets))))

(define (b2-authorization-details key-id key bucket-name)
  (let* ((auth (b2-authorize-account key-id key))
         (authorization-token (alist-ref 'authorizationToken auth))
         (account-id (alist-ref 'accountId auth))
         (api-url (alist-ref 'apiUrl (alist-ref 'storageApi (alist-ref 'apiInfo auth))))
         (buckets (alist-ref 'buckets (alist-ref 'allowed (alist-ref 'storageApi (alist-ref 'apiInfo auth)))))
         (listed-bucket-id (and (eq? buckets 'null) ;; if the key does not contain a bucket restriction it should be able to use the api to list buckets
                                (alist-ref 'bucketId ;; TODO handle the bucket not being found
                                           (find (lambda (x) (string=? (alist-ref 'bucketName x) bucket-name))
                                                 (alist-ref 'buckets (b2-list-buckets api-url authorization-token account-id)))))))
    (values authorization-token
            account-id
            api-url
            (or listed-bucket-id (alist-ref 'id (car buckets))) ;; assume at least one bucket and the one we want for now, TODO handle better
            buckets)))

(define (b2-list-file-versions api-url account-token bucket-id)
  (with-input-from-request
      (make-request method: 'GET
                    uri: (uri-reference (string-append api-url "/b2api/v4/b2_list_file_versions?bucketId=" bucket-id))
                    headers: (headers `((authorization #(,account-token raw))
                                        (content-type application/json))))
    #f
    read-json))

(define (b2-list-file-versions-only-name-id api-url account-token bucket-id)
  (map (lambda (x)
         (cons (alist-ref 'fileName x)
               (alist-ref 'fileId x)))
       (alist-ref 'files (b2-list-file-versions api-url account-token bucket-id))))

(define (b2-delete-file-version api-url account-token file-name file-id)
  (with-input-from-request
      (make-request method: 'POST
                    uri: (uri-reference (string-append api-url "/b2api/v4/b2_delete_file_version"))
                    headers: (headers `((authorization #(,account-token raw))
                                        (content-type application/json))))
    (lambda ()
      (write-json
       `((fileName . ,file-name)
         (fileId . ,file-id))))
    read-json))

(define (b2-delete-bucket-files key-id app-key bucket-name)
  (receive (token account-id api-url bucket-id _)
      (b2-authorization-details key-id app-key bucket-name)
    (let loop ((files (b2-list-file-versions-only-name-id api-url token bucket-id)))
      (when (not (null? files))
        (for-each (lambda (file)
                    (b2-delete-file-version api-url token (car file) (cdr file)))
                  files)
        (loop (b2-list-file-versions-only-name-id api-url token bucket-id))))))

(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)
  (handle-exceptions
   exn
   `((success . #f)
     (errors ((message . ,(alist-ref 'code (read-json (get-condition-property exn 'client-error 'body)))))))
   (receive (data request-uri response) (b2-authorize-account key-id application-key)
     (if (alist-ref 'authorizationToken data)
         `((success . #t)
           (result ,data))
         `((success . #f)
           (result ,data))))))

(define *instance-up-timeout* 1) ;; seconds
(define *instance-up-retry-time* 120) ;; 120s, 2 minutes
(define *instance-up-retries* (/ *instance-up-retry-time* *instance-up-timeout*))
(define (instance-up? path)
  (let loop ((i 0))
    (let ((thread
           (thread-start!
            (lambda ()
              (condition-case
                  (receive (data uri response) (with-input-from-request path #f read-string)
                    (if (eq? (response-code response) 401)
                        #t
                        (begin (thread-sleep! *instance-up-timeout*) ;; we depend on this taking at least as long as the timeout if the instance is still booting
                               #f)))
                (e (exn client-error)
                   (if (eq? (response-code (get-condition-property e 'client-error 'response)) 401)
                       #t
                       (begin (thread-sleep! *instance-up-timeout*) ;; we depend on this taking at least as long as the timeout if the instance is still booting
                              #f)))
                (e (exn net)
                   (thread-sleep! *instance-up-timeout*)
                   #f)
                (e ()
                   (thread-sleep! *instance-up-timeout*)
                   #f))))))
      (if (thread-join! thread *instance-up-timeout* #f)
          #t
          (if (< i *instance-up-retries*)
              (loop (+ i 1))
              #f)))))


(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
     ;; in prod, no ssh-keys, but we need the file to exist for Make
     (with-output-to-file (string-append dir "/config/ssh-keys") (lambda () (display "")))))
  (with-output-to-file (string-append dir "/terraform.tfstate") (lambda () (write-string state)))
  (with-output-to-file (string-append dir "/terraform.tfstate.backup") (lambda () (write-string state-backup))))

(define (parse-deployment-log log)
  (define (search complete in-progress failed)
    (cond ((irregex-search failed log)
           'failed)
          ((irregex-search complete log)
           'complete)
          ((irregex-search in-progress log)
           'in-progress)
          (else 'queued)))
  `((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start" "Failed to install provider"))
    ;; TODO this didn't seem to work right when upgrading the flatcar image
    ;; log: [0mdigitalocean_custom_image.flatcar: Creating...
;; digitalocean_custom_image.flatcar: Still creating... [00m10s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m20s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m30s elapsed]
;; digitalocean_custom_image.flatcar: Still creating... [00m40s elapsed]
    (custom-image . ,(search '(or "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Creation complete")
                             '(or "custom_image.flatcar: Modifying" "custom_image.flatcar: Creating")
                             "XXX - nothing"))
    (machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..." "XXX - nothing"))
    (machine-destroy . ,(search "droplet.machine: Destruction complete"
                                '(: "droplet.machine (deposed object " (* alphanum) "): Destroying...") "XXX - nothing"))
    (ip-destroy . ,(search "reserved_ip_assignment.machine: Destruction complete" "reserved_ip_assignment.machine: Destroying..." "XXX - nothing"))
    (ip-create . ,(search "reserved_ip_assignment.machine: Creation complete" "reserved_ip_assignment.machine: Creating..." "Error Assigning reserved IP"))
    (volume-create . ,(search "volume_attachment.machine: Creation complete" "volume_attachment.machine: Creating..." "XXX - nothing"))
    (volume-destroy . ,(search "volume_attachment.machine: Destruction complete" "volume_attachment.machine: Destroying..." "XXX - nothing"))))

(define (write-config-entry name value)
  (display name)
  (display "='")
  (display (if value
               (string-translate* (->string value) '(("'" . "\\'"))) ;; escape any single quotes
               ""))+
  (print "'"))

(define (write-terraform-config-entry name value)
  (display name)
  (display "=\"")
  (display (if value
               (string-translate* (->string value) '(("\"" . "\\\""))) ;; escape any double quotes
               ""))+
  (print "\""))

;; (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 (create-authelia-password-hash password)
  ;; docker run --rm -it authelia/authelia:latest authelia crypto hash generate argon2
  (receive (in-port out-port pid err-port)
      (cond-expand
        (dev
         (process* "docker" `("run" "--rm" "authelia/authelia:latest" "authelia" "crypto" "hash" "generate" "argon2" "--password" ,password)))
        (else
         (process* "/usr/local/bin/authelia" `("crypto" "hash" "generate" "argon2" "--password" ,password))))
    (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 err-port read-string) ;; left here for debugging and to clear ports
                            ;; the output is prefixed with "Digest: " and suffixed with a newline
                            ;; so we clean it up
                            (string-drop (string-trim-right (with-input-from-port in-port read-string)) 8))
                          (begin (log-to (debug-log) "authelia: docker command error")
                                 (error "Authelia for generating password hash had abnormal exit"))))))))))
      (thread-join! thread))))

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

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

;; example return value
;; (((time . "2026-04-22T22:24:41.701047574Z") (tree . "42c8556ee6ff87eb2b69a7bc23350026182bc015d7f32ec646d9540f43461754") (paths "/nassella") (hostname . "f042d0fae493") (username . "root") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-22T22:24:41.701047574Z") (backup_end . "2026-04-22T22:24:51.006181344Z") (files_new . 4069) (files_changed . 0) (files_unmodified . 0) (dirs_new . 108) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 1346) (tree_blobs . 67) (data_added . 69399644) (data_added_packed . 11545191) (total_files_processed . 4069) (total_bytes_processed . 146529878)) (id . "77e70711caca6774dabc255dd63dfcaa788c1bd2c1536fda133442e2b5164473") (short_id . "77e70711")) ((time . "2026-04-23T10:00:05.876773568Z") (tree . "5a1650880a1e688576f941b37892617fcb43022b103a7394d994833b6b05ae75") (paths "/nassella") (hostname . "c4e48b3a29e9") (username . "root") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-23T10:00:05.876773568Z") (backup_end . "2026-04-23T10:00:15.208834993Z") (files_new . 4069) (files_changed . 0) (files_unmodified . 0) (dirs_new . 108) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 21) (tree_blobs . 46) (data_added . 2903468) (data_added_packed . 470424) (total_files_processed . 4069) (total_bytes_processed . 146503956)) (id . "312e57caf39295ef7be69569631232f2b1b445322636091d63c2082b48b09079") (short_id . "312e57ca")) ((time . "2026-04-24T01:41:40.890895516Z") (tree . "4367a5665a1c6ebb9ea5ddbe40485d58485d3610a7a07a9e22ee0bfea0f044cc") (paths "/nassella") (hostname . "7d01b0ae1b2e") (username . "root") (tags "daily_automatic") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-24T01:41:40.890895516Z") (backup_end . "2026-04-24T01:41:46.743356138Z") (files_new . 4074) (files_changed . 0) (files_unmodified . 0) (dirs_new . 111) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 29) (tree_blobs . 51) (data_added . 3009785) (data_added_packed . 481008) (total_files_processed . 4074) (total_bytes_processed . 146593600)) (id . "5e7c5f51c46aee69b85e30fade3d6a3b83d07bbe6fa112c75b759966d8848376") (short_id . "5e7c5f51")) ((time . "2026-04-24T10:00:00.956302962Z") (tree . "6edaa49535f5ed860f19c8790d6e4db23b8f79c1b8eb40ac59e73ff524522305") (paths "/nassella") (hostname . "11d8deac4263") (username . "root") (tags "daily_automatic") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-24T10:00:00.956302962Z") (backup_end . "2026-04-24T10:00:07.649733529Z") (files_new . 4074) (files_changed . 0) (files_unmodified . 0) (dirs_new . 112) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 22) (tree_blobs . 68) (data_added . 4097676) (data_added_packed . 601696) (total_files_processed . 4074) (total_bytes_processed . 146594976)) (id . "50f613854ed4d521b596af4435ba4e3f17587124d0a0de248b19f6052117a689") (short_id . "50f61385")) ((time . "2026-04-25T10:00:01.061830384Z") (tree . "ac797c256a6ee09f51ed504c4234e1ced6cef8e1845c67424618658ea6d55abe") (paths "/nassella") (hostname . "f03ffbd8dfe9") (username . "root") (tags "daily_automatic") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-25T10:00:01.061830384Z") (backup_end . "2026-04-25T10:00:07.594710184Z") (files_new . 4074) (files_changed . 0) (files_unmodified . 0) (dirs_new . 112) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs . 21) (tree_blobs . 49) (data_added . 2899995) (data_added_packed . 474478) (total_files_processed . 4074) (total_bytes_processed . 146594977)) (id . "7cb5b3badbcebf8222efe863d61371d8d5017f9df8eeecef42a05125fa33555f") (short_id . "7cb5b3ba")) ((time . "2026-04-26T10:00:01.071960675Z") (tree . "63f60b2b42909fe374a4db97c6dae53b382e69480f17ca1e6b26f218d859d328") (paths "/nassella") (hostname . "6a7def9f0992") (username . "root") (tags "daily_automatic") (program_version . "restic 0.18.0") (summary (backup_start . "2026-04-26T10:00:01.071960675Z") (backup_end . "2026-04-26T10:00:07.762125559Z") (files_new . 4074) (files_changed . 0) (files_unmodified . 0) (dirs_new . 112) (dirs_changed . 0) (dirs_unmodified . 0) (data_blobs

(define (restic-snapshots user-id instance-id)
  (let* ((password-path (conc "restic-password-" user-id "-" instance-id))
         (res
          (with-db/transaction
           (lambda (db)
             `((restic-password . ,(get-instance-restic-password db user-id instance-id))
               (service-config . ,(get-user-service-config db user-id instance-id))))))
         (restic-password (alist-ref 'restic-password res))
         (service-config (alist-ref 'service-config res)))
    (dynamic-wind
      (lambda ()
        (with-output-to-file password-path (lambda () (display restic-password))))
      (lambda ()
        (receive (in-port out-port pid err-port)
            (cond-expand
              (dev
               (process* "docker" `("run" "--rm" "--volume"
                                    ,(conc (current-directory) "/" password-path ":/restic-password")
                                    "-e" ,(conc "AWS_ACCESS_KEY_ID="
                                                (alist-ref 'backblaze-key-id service-config))
                                    "-e" ,(conc "AWS_SECRET_ACCESS_KEY="
                                                (alist-ref 'backblaze-application-key service-config))
                                    "-i" "restic/restic:0.18.0" "snapshots"
                                    "--repo" ,(conc "s3:" (alist-ref 'backblaze-bucket-url service-config))
                                    "--password-file" "/restic-password"
                                    "--json")))
              (else
               (process* "/bin/restic"
                         `("snapshots"
                           "--repo" ,(conc "s3:" (alist-ref 'backblaze-bucket-url service-config))
                           "--password-file" ,password-path
                           "--json")
                         `(("AWS_ACCESS_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
                           ("AWS_SECRET_ACCESS_KEY" . ,(alist-ref 'backblaze-application-key service-config))))))
          (let ((thread
                 (thread-start!
                  (lambda ()
                    (let loop ()
                      (thread-sleep! 1)
                      ;; We do a non-blocking wait here so that we don't
                      ;; block the entire web process.
                      (receive (wait-pid exit-normal status) (process-wait pid #t)
                        (if (= wait-pid 0) ;; wait-pid is 0 until the process has finished
                            (loop)
                            (if exit-normal
                                (let ((res (with-input-from-port in-port read-json)))
                                  ;; left here for debugging and to clear ports
                                  (with-input-from-port err-port read-string)
                                  res)
                                (begin (log-to (debug-log) "restic-snapshots: docker command error")
                                       (error "restic-snapshots docker command had abnormal exit"))))))))))
            (thread-join! thread))))
      (lambda ()
        (delete-file password-path)))))


;; verify subdomains. Not the full check because excludes root domain
;; but should help the user in all but extreme cases
;; based on: https://stackoverflow.com/questions/7930751/regexp-for-subdomain
;; We don't expect the user to include the final "dot" so we add it just
;; to validate the subdomain
(define (valid-subdomain? str)
  (if (string? str)
      (irregex-match? (irregex "(?:[a-z0-9](?:[a-z0-9-]{0,61}[a-z0-9])?\\.)+") (string-append str "."))
      #f))

;; based on the docs here https://docs.nextcloud.com/server/stable/admin_manual/configuration_user/user_configuration.html
;; guessed at the length
(define (valid-nextcloud-user? v)
  (if (string? v)
      (irregex-match? (irregex "[a-zA-Z0-9\\-_\\. @]{1,64}") v)
      #f))

;; Seems to be few restrictions other than a default that it should
;; be at least 10 chars.
;; TODO does our config file have limitations though?
(define (valid-nextcloud-password? v)
  (if (string? v)
      (> (string-length v) 9)
      #f))

;; TODO is this actually needed?
(single-headers (cons 'X-Nassella-Signature (single-headers)))
(header-parsers (cons `(X-Nassella-Signature . ,(single identity)) (header-parsers)))

(define (send-instance-control-command domain subdomain command secret-key data)
  (let ((json (json->string data)))
    (with-input-from-request
        (make-request method: 'POST
    	              uri: (uri-reference (conc "https://" subdomain "." domain "/hooks/" command))
    	              headers: (headers `((content-type application/json)
                                          (X-Nassella-Signature
                                           #(,(string->hex ((hmac secret-key (sha256-primitive)) json))
                                             ())))))
      (lambda ()
        (write-json data))
      read-json)))

(with-schematra-app app
  (lambda ()

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

;; https://app.nassella.org/unsecured/account/create?sid={CHECKOUT_SESSION_ID}
(post "/unsecured/account/create-submit"
      (let ((email (stripe-session-email (alist-ref 'sid (current-params))))
            (username (alist-ref 'username (current-params))))
        (create-lldap-user username email)
        (with-db/transaction (lambda (db) (create-user db email username))))
      (redirect "/authelia/reset-password"))

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

(get/widgets
 ("/config/wizard/services/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (config (with-db/transaction
                 (lambda (db)
                   (get-user-service-config db (session-user-id)
                                            instance-id)))))
   `(App
     (Configuration-Wizard
      (@ (step "Services"))
      (form
       (@ (action ,(conc "/config/wizard/services-submit/" instance-id))
          (method POST))
       (VStack
        (Fieldset
         (@ (title "Cloudflare"))
         (Field (@ (name "cloudflare-api-token") (label ("API Token")) (type "password")
                   (value ,(alist-ref 'cloudflare-api-token config))))
         (Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (type "password")
                   (value ,(alist-ref 'cloudflare-zone-id config))))
         (Field (@ (name "cloudflare-account-id") (label ("Account ID")) (type "password")
                   (value ,(alist-ref 'cloudflare-account-id config)))))
        (Fieldset
         (@ (title "DigitalOcean"))
         (Field (@ (name "digitalocean-api-token") (label ("API Token")) (type "password")
                   (value ,(alist-ref 'digitalocean-api-token config)))))
        (Fieldset
         (@ (title "Backblaze"))
         (Field (@ (name "backblaze-application-key") (label ("Application Key"))
                   (type "password")
                   (value ,(alist-ref 'backblaze-application-key config))))
         (Field (@ (name "backblaze-key-id") (label ("Key ID")) (type "password")
                   (value ,(alist-ref 'backblaze-key-id config)))))
        (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)))))))
   (redirect (conc "/config/wizard/services-success/" instance-id))))

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

(get/widgets
 ("/config/wizard/apps/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (results
         (with-db/transaction
          (lambda (db)
            `((selected-apps . ,(map
                                 car
                                 (filter cdr
                                         (get-user-selected-apps db (session-user-id) instance-id))))
              (app-config . ,(get-user-app-config db (session-user-id) instance-id))
              (service-config . ,(get-user-service-config db (session-user-id) instance-id))))))
        (backblaze-buckets (b2-account-buckets (alist-ref 'backblaze-key-id (alist-ref 'service-config results))
                                               (alist-ref 'backblaze-application-key (alist-ref 'service-config results))))
        (backblaze-s3-api-url (alist-ref
                               's3ApiUrl
                               (alist-ref
                                'storageApi
                                (alist-ref
                                 'apiInfo
                                 (b2-authorize-account (alist-ref 'backblaze-key-id (alist-ref 'service-config results))
                                                       (alist-ref 'backblaze-application-key (alist-ref 'service-config results))))))))
   `(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)
                                     (required #t)
                                     ,@(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 "Backblaze Bucket"))
         (Field (@ (element select) (name "backblaze-bucket-id"))
                ,@(map (lambda (bucket)
                         `(option (@ (value ,(string-append (alist-ref 'id bucket) "|" (alist-ref 'name bucket)))
                                     (required #t)
                                     ,@(if (equal? (alist-ref 'id bucket)
                                                   (alist-ref 'backblaze-bucket-id (alist-ref 'service-config results)))
                                           '(selected)
                                           '()))
                                  ,(alist-ref 'name bucket)))
                       backblaze-buckets)))
        (input (@ (type "hidden") (name "backblaze-s3-url") (value ,backblaze-s3-api-url)))
        (Fieldset
         (@ (title "Selected Apps"))
         (Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps results)))))
         (Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'nextcloud (alist-ref 'selected-apps results)))))
         (Field (@ (name "ghost") (type "checkbox") (label ("Ghost")) (checked ,(member 'ghost (alist-ref 'selected-apps results)))))
         ,@(cond-expand
             (dev
              `((Field (@ (name "nassella") (type "checkbox") (label ("Nassella")) (checked ,(member 'nassella (alist-ref 'selected-apps results)))))))
             (else
              '()))
         (Field (@ (name "wordpress") (type "checkbox") (label ("Wordpress")) (checked ,(member 'wordpress (alist-ref 'selected-apps results)))))
         (Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled")))
         ;; (Field (@ (name "lldap") (type "checkbox") (label ("Admin LLDAP")) (checked #t) (disabled "disabled")))
         ;; (Field (@ (name "authelia") (type "checkbox") (label ("Admin Authelia")) (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?))
         (bucket-values (string-split (alist-ref 'backblaze-bucket-id (current-params)) "|"))
         (bucket-name (cadr bucket-values))
         (bucket-id (car bucket-values)))
    (with-db/transaction
     (lambda (db)
       (update-user-selected-apps
        db
        (session-user-id)
        instance-id
        (filter (lambda (app/version) (cdr app/version)) ;; filter out unused apps
                `((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "15") #f))
                  (nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "34") #f))
                  (ghost . ,(or (and (alist-ref 'ghost (current-params)) "6") #f))
                  (nassella . ,(or (and (alist-ref 'nassella (current-params)) "b0.0.1") #f))
                  (wordpress . ,(or (and (alist-ref 'wordpress (current-params)) "8.4") #f))
                  (lldap . #f) ;; "0.6.3"
                  (authelia . "4")
                  (instance-control . "b0.0.1")
                  (log-viewer . "20"))))
       (update-user-service-config
        db
        (session-user-id)
        instance-id
        `((backblaze-bucket-name . ,bucket-name)
          (backblaze-bucket-id . ,bucket-id)
          (backblaze-bucket-url . ,(string-append (alist-ref 'backblaze-s3-url (current-params)) "/" bucket-name))))
       (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")) (required #t)
                           (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")) (required #t)
                           (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")) (required #t)
                           (value ,(alist-ref 'subdomain (alist-ref 'nextcloud app-config eq? '()) eq? "nextcloud"))))
                 (Field (@ (name "nextcloud-admin-user") (label ("Admin Username")) (required #t)
                           (value ,(alist-ref 'admin-user (alist-ref 'nextcloud app-config eq? '()) eq? "admin"))))
                 (Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password") (required #t)
                           (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")) (required #t)
                           (value ,(alist-ref 'subdomain (alist-ref 'nassella app-config eq? '()) eq? "app"))))
                 (Field (@ (name "nassella-lldap-subdomain") (label ("LLDAP Subdomain")) (required #t)
                           (value ,(alist-ref 'lldap-subdomain (alist-ref 'nassella app-config eq? '()) eq? "lldap"))))
                 (Field (@ (name "nassella-lldap-admin-password") (label ("Admin Password")) (type "password") (required #t)
                           (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") (required #t)
                           (value ,(alist-ref 'stripe-api-key (alist-ref 'nassella app-config eq? '()) eq? ""))))))
              '())
        ,@(if (member 'wordpress selected-apps)
              `((Fieldset
                 (@ (title "Wordpress"))
                 (Field (@ (name "wordpress-subdomain") (label ("Subdomain")) (required #t)
                           (value ,(alist-ref 'subdomain (alist-ref 'wordpress app-config eq? '()) eq? "wordpress"))))))
              '())
        ;; ,@(if (member 'lldap selected-apps)
        ;;       `((Fieldset
        ;;          (@ (title "Admin LLDAP"))
        ;;          (Field (@ (name "lldap-subdomain") (label ("Subdomain")) (required #t)
        ;;                    (value ,(alist-ref 'subdomain (alist-ref 'lldap app-config eq? '()) eq? "lldap"))))
        ;;          (Field (@ (name "lldap-user-email") (label ("Admin Email Address")) (type "email") (required #t)
        ;;                    (value ,(alist-ref 'user-email (alist-ref 'lldap app-config eq? '()) eq? ""))))
        ;;          (Field (@ (name "lldap-admin-password") (label ("Admin Password")) (type "password") (required #t)
        ;;                    (value ,(alist-ref 'admin-password (alist-ref 'lldap app-config eq? '()) eq? ""))))))
        ;;       '())
        ;; ,@(if (member 'authelia selected-apps)
        ;;       `((Fieldset
        ;;          (@ (title "Admin Authelia"))
        ;;          (Field (@ (name "authelia-subdomain") (label ("Subdomain")) (required #t)
        ;;                    (value ,(alist-ref 'subdomain (alist-ref 'authelia app-config eq? '()) eq? "authelia"))))))
        ;;       '())
        (Fieldset
         (@ (title "Log Viewer"))
         (Field (@ (name "log-viewer-subdomain") (label ("Subdomain")) (required #t)
                   (value ,(alist-ref 'subdomain (alist-ref 'log-viewer app-config eq? '()) eq? "logs"))))
         (Field (@ (name "log-viewer-user") (label ("Admin Email")) (required #t)
                   (value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
         (Field (@ (name "log-viewer-password") (label ("Admin Password")) (type "password") (required #t)
                   (value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? "")))))
        ,@(if (or (member 'nextcloud selected-apps) (member 'ghost selected-apps) (member 'nassella selected-apps) (member 'authelia selected-apps))
              `((Fieldset
                 (@ (title "All Apps - Email - SMTP"))
                 (Field (@ (name "smtp-host") (label ("Host")) (required #t)
                           (value ,(alist-ref 'smtp-host (alist-ref 'all-apps app-config eq? '()) eq? ""))))
                 (Field (@ (name "smtp-port") (label ("Port")) (required #t)
                           (value ,(alist-ref 'smtp-port (alist-ref 'all-apps app-config eq? '()) eq? ""))))
                 (Field (@ (name "smtp-auth-user") (label ("Auth User")) (required #t)
                           (value ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps app-config eq? '()) eq? ""))))
                 (Field (@ (name "smtp-auth-password") (label ("Auth Password")) (type "password") (required #t)
                           (value ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps app-config eq? '()) eq? ""))))
                 (Field (@ (name "smtp-from") (label ("From")) (required #t)
                           (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?))
             (redirect-to
              (with-db/transaction
               (lambda (db)
                 (let* ((config (alist-ref 'config (get-user-app-config db (session-user-id) instance-id)))
                        (selected-apps (map
                                        car
                                        (filter cdr
                                                (get-user-selected-apps db (session-user-id) instance-id))))
                        (rules
                         `((nextcloud-subdomain . (nextcloud required ,valid-subdomain? "nextcloud-invalid-subdomain"))
                           (nextcloud-admin-user . (nextcloud required ,valid-nextcloud-user? "nextcloud-admin-user"))
                           (nextcloud-admin-password . (nextcloud required ,valid-nextcloud-password? "nextcloud-admin-password"))
                           (ghost-subdomain . (ghost required ,valid-subdomain? "ghost-invalid-subdomain"))
                           (wg-easy-subdomain . (wg-easy required ,valid-subdomain? "wg-easy-invalid-subdomain"))
                           (nassella-subdomain . (nassella required ,valid-subdomain? "nassella-invalid-subdomain"))
                           (nassella-lldap-subdomain . (nassella required ,valid-subdomain? "nassella-lldap-invalid-subdomain"))
                           ;; lldap does not have restrictions so just use the same as nextcloud for now
                           (nassella-lldap-admin-password . (nassella required ,valid-nextcloud-password? "nassella-lldap-admin-password"))
                           (wordpress-subdomain . (wordpress required ,valid-subdomain? "wordpress-invalid-subdomain"))))
                        (errs (filter
                               identity
                               (map (lambda (rule)
                                      (let* ((param (car rule))
                                             (ruleset (cdr rule))
                                             (app (first ruleset))
                                             (required (eq? (second ruleset) 'required))
                                             (proc (third ruleset))
                                             (error-key (fourth ruleset))
                                             (value (alist-ref param (current-params))))
                                        (if (and (member app selected-apps) (not (proc value))) ;; if user selected app and we fail validation proc
                                          (if required
                                              error-key
                                              (if (or (equal? value #f) (and (string? value) (string=? value ""))) ;; if optional and empty
                                                  #f
                                                  error-key))
                                          #f)))
                                    rules))))
                   (if (> (length errs) 0)
                       (string-append "/config/wizard/apps2/" instance-id "?" (string-join errs "&"))
                       (begin
                         (update-user-app-config
                          db
                          (session-user-id)
                          instance-id
                          `((ghost . ((subdomain . ,(alist-ref 'ghost-subdomain (current-params)))
                                      (postgres-root-password . ,(or (alist-ref 'postgres-root-password
                                                                                (alist-ref 'ghost config eq? '()))
                                                                     (generate-postgres-password)))
                                      (postgres-password . ,(or (alist-ref 'postgres-password
                                                                           (alist-ref 'ghost config eq? '()))
                                                                (generate-postgres-password)))))
                            (wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (current-params)))))
                            (nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (current-params)))
                                          (admin-user . ,(alist-ref 'nextcloud-admin-user (current-params)))
                                          (admin-password . ,(alist-ref 'nextcloud-admin-password (current-params)))
                                          (postgres-password . ,(or (alist-ref 'postgres-password
                                                                               (alist-ref 'nextcloud config eq? '()))
                                                                    (generate-postgres-password)))
                                          (redis-password . ,(or (alist-ref 'redis-password
                                                                            (alist-ref 'nextcloud config eq? '()))
                                                                 (generate-redis-password)))))
                            (nassella . ((subdomain . ,(alist-ref 'nassella-subdomain (current-params)))
                                         (postgres-password . ,(or (alist-ref 'postgres-password
                                                                              (alist-ref 'nassella config eq? '()))
                                                                   (generate-postgres-password)))
                                         (authelia-postgres-password . ,(or (alist-ref 'authelia-postgres-password
                                                                                       (alist-ref 'nassella config eq? '()))
                                                                            (generate-postgres-password)))
                                         (lldap-postgres-password . ,(or (alist-ref 'lldap-postgres-password
                                                                                    (alist-ref 'nassella config eq? '()))
                                                                         (generate-postgres-password)))
                                         (lldap-jwt-secret . ,(or (alist-ref 'lldap-jwt-secret
                                                                             (alist-ref 'nassella config eq? '()))
                                                                  (generate-jwt-secret)))
                                         (lldap-key-seed . ,(or (alist-ref 'lldap-key-seed
                                                                           (alist-ref 'nassella config eq? '()))
                                                                (generate-key-seed)))
                                         (lldap-subdomain . ,(alist-ref 'nassella-lldap-subdomain (current-params)))
                                         (lldap-admin-password . ,(alist-ref 'nassella-lldap-admin-password (current-params)))
                                         (stripe-api-key . ,(alist-ref 'nassella-stripe-api-key (current-params)))
                                         (authelia-jwt-secret . ,(or (alist-ref 'authelia-jwt-secret
                                                                                (alist-ref 'nassella config eq? '()))
                                                                     (generate-jwt-secret)))
                                         (authelia-key-seed . ,(or (alist-ref 'authelia-key-seed
                                                                              (alist-ref 'nassella config eq? '()))
                                                                   (generate-authelia-key-seed)))))
                            (wordpress . ((subdomain . ,(alist-ref 'wordpress-subdomain (current-params)))
                                          (db-password . ,(or (alist-ref 'db-password
                                                                         (alist-ref 'wordpress config eq? '()))
                                                              (generate-postgres-password)))
                                          (db-root-password . ,(or (alist-ref 'db-root-password
                                                                              (alist-ref 'wordpress config eq? '()))
                                                                   (generate-postgres-password)))))
                            (lldap . ((subdomain . ,(alist-ref 'lldap-subdomain (current-params)))
                                      (db-password . ,(or (alist-ref 'db-password
                                                                     (alist-ref 'lldap config eq? '()))
                                                          (generate-postgres-password)))
                                      (jwt-secret . ,(or (alist-ref 'jwt-secret
                                                                    (alist-ref 'lldap config eq? '()))
                                                         (generate-jwt-secret)))
                                      (key-seed . ,(or (alist-ref 'key-seed
                                                                  (alist-ref 'lldap config eq? '()))
                                                       (generate-key-seed)))
                                      (admin-password . ,(alist-ref 'lldap-admin-password (current-params)))
                                      (user-email . ,(alist-ref 'lldap-user-email (current-params)))))
                            (authelia . ((subdomain . ,(alist-ref 'authelia-subdomain (current-params)))
                                         (db-password . ,(or (alist-ref 'db-password
                                                                        (alist-ref 'authelia config eq? '()))
                                                             (generate-postgres-password)))
                                         (jwt-secret . ,(or (alist-ref 'jwt-secret
                                                                       (alist-ref 'authelia config eq? '()))
                                                            (generate-jwt-secret)))
                                         (session-secret . ,(or (alist-ref 'session-secret
                                                                           (alist-ref 'authelia config eq? '()))
                                                                (generate-authelia-key-seed)))
                                         (encryption-key . ,(or (alist-ref 'encryption-key
                                                                           (alist-ref 'authelia config eq? '()))
                                                                (generate-authelia-key-seed)))))
                            (log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (current-params)))
                                           (user . ,(alist-ref 'log-viewer-user (current-params)))
                                           (password . ,(alist-ref 'log-viewer-password (current-params)))))
                            (all-apps . ((smtp-host . ,(alist-ref 'smtp-host (current-params)))
                                         (smtp-port . ,(alist-ref 'smtp-port (current-params)))
                                         (smtp-auth-user . ,(alist-ref 'smtp-auth-user (current-params)))
                                         (smtp-auth-password . ,(alist-ref 'smtp-auth-password (current-params)))
                                         (smtp-from . ,(alist-ref 'smtp-from (current-params)))))
                            (instance-control . ((subdomain . "nassella-instance-control")
                                                 (webhooks-secret . ,(or (alist-ref 'webhooks-secret
                                                                                    (alist-ref 'instance-control config eq? '()))
                                                                         (generate-jwt-secret)))))))
                         (conc "/config/wizard/machine/" instance-id) ;; redirect-to
                         )))))))
        (redirect redirect-to)))

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

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

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

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

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

(post "/config/wizard/review-submit/:id"
  (let* ((instance-id (alist-ref "id" (current-params) equal?))
         (status (string->symbol
                  (->string
                   (with-db/transaction
                    (lambda (db)
                      (get-most-recent-deployment-status db (session-user-id) instance-id)))))))
    (when (or (not (or (eq? status 'queued) (eq? status 'in-progress)))
              (equal? (alist-ref 'force (current-params)) "true"))
      (let* ((instance-id (alist-ref "id" (current-params) equal?))
             (restic-snapshot-id (alist-ref 'restic-snapshot-id (current-params)))
             (results
              (with-db/transaction
               (lambda (db)
                 `((selected-apps . ,(get-user-selected-apps db (session-user-id) instance-id))
                   (app-config . ,(get-user-app-config db (session-user-id) instance-id))
                   (service-config . ,(get-user-service-config db (session-user-id) instance-id))
                   (terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))
                   (ssh-pub-key . ,(get-instance-ssh-pub-key db (session-user-id) instance-id))
                   (restic-password . ,(get-instance-restic-password db (session-user-id) instance-id))))))
             (selected-apps (alist-ref 'selected-apps results))
             (app-config (alist-ref 'app-config results))
             (config (alist-ref 'config app-config))
             (root-domain (alist-ref 'root-domain app-config))
             (service-config (alist-ref 'service-config results))
             (terraform-state (alist-ref 'terraform-state results))
             (ssh-pub-key (alist-ref 'ssh-pub-key results))
             (restic-password (alist-ref 'restic-password results))
             (dir (deployment-directory (session-user-id) instance-id)))
        (setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
        (with-output-to-file (string-append dir "/config/apps.config")
          (lambda ()
            (map (lambda (e)
                   (write-config-entry (car e) (cdr e)))
                 `(("ROOT_DOMAIN" . ,root-domain)
                   ("APP_CONFIGS" . ,(string-intersperse
                                      (map (lambda (app-version)
                                             (conc (if (eq? (car app-version) 'log-viewer) 'dozzle (car app-version))
                                                   ","
                                                   (or (alist-ref 'subdomain (alist-ref (car app-version) config))
                                                       "nassella-ignore") ;; a hack to get authelia to work for now
                                                   ","
                                                   (cdr app-version)))
                                           selected-apps)
                                      " "))
                   ("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
                   ("HOST_ADMIN_PASSWORD" . ,(create-authelia-password-hash (alist-ref 'password (alist-ref 'log-viewer config))))
                   ("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
                   ("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
                   ("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
                   ("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
                   ("NEXTCLOUD_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nextcloud config)))
                   ("NEXTCLOUD_REDIS_PASSWORD" . ,(alist-ref 'redis-password (alist-ref 'nextcloud config)))
                   ("GHOST_DATABASE_ROOT_PASSWORD" . ,(alist-ref 'postgres-root-password (alist-ref 'ghost config)))
                   ("GHOST_DATABASE_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'ghost config)))
                   ("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config)))
                   ("NASSELLA_POSTGRES_DB" . "nassella")
                   ("NASSELLA_POSTGRES_USER" . "nassella")
                   ("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config)))
                   ("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia")
                   ("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia")
                   ("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config)))
                   ("NASSELLA_LLDAP_POSTGRES_DB" . "lldap")
                   ("NASSELLA_LLDAP_POSTGRES_USER" . "lldap")
                   ("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config)))
                   ("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config)))
                   ("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config)))
                   ("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config)))
                   ("NASSELLA_STRIPE_API_KEY" . ,(alist-ref 'stripe-api-key (alist-ref 'nassella config)))
                   ("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config)))
                   ("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella config)))
                   ("WORDPRESS_DB_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'wordpress config)))
                   ("WORDPRESS_DB_ROOT_PASSWORD" . ,(alist-ref 'db-root-password (alist-ref 'wordpress config)))
                   ("LLDAP_POSTGRES_DB" . "lldap")
                   ("LLDAP_POSTGRES_USER" . "lldap")
                   ("LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'lldap config)))
                   ("LLDAP_JWT_SECRET" . ,(alist-ref 'jwt-secret (alist-ref 'lldap config)))
                   ("LLDAP_KEY_SEED" . ,(alist-ref 'key-seed (alist-ref 'lldap config)))
                   ("LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'lldap config)))
                   ("LLDAP_USER_EMAIL" . ,(alist-ref 'user-email (alist-ref 'lldap config)))
                   ("AUTHELIA_POSTGRES_DB" . "authelia")
                   ("AUTHELIA_POSTGRES_USER" . "authelia")
                   ("AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'authelia config)))
                   ("AUTHELIA_JWT_SECRET" . ,(alist-ref 'jwt-secret (alist-ref 'authelia config)))
                   ("AUTHELIA_SESSION_SECRET" . ,(alist-ref 'session-secret (alist-ref 'authelia config)))
                   ("AUTHELIA_ENCRYPTION_KEY" . ,(alist-ref 'encryption-key (alist-ref 'authelia config)))
                   ("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
                   ("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
                   ("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
                   ("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
                   ("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
                   ("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
                   ("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
                   ("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
                   ("RESTIC_PASSWORD" . ,restic-password)
                   ("INSTANCE_CONTROL_WEBHOOKS_SECRET" . ,(alist-ref 'webhooks-secret (alist-ref 'instance-control config)))
                   ,@(if (and restic-snapshot-id (not (string=? restic-snapshot-id ""))) `(("RESTIC_SNAPSHOT_ID" . ,restic-snapshot-id)) '())))))
        (with-output-to-file (string-append dir "/config/production.tfvars")
          (lambda ()
            (map (lambda (e)
                   (write-terraform-config-entry (car e) (cdr e)))
                 `(("server_type" . ,(alist-ref 'digitalocean-size service-config))
                   ("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
                   ("digitalocean_volume_size" . ,(alist-ref 'digitalocean-volume-size service-config))
                   ("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
                   ("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
                   ("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
                   ("cluster_name" . ,(string-append "nassella" (string-delete #\. root-domain))) ;; TODO update to: (import srfi-14) (string-filter char-set:letter+digit root-domain)
                   ("datacenter" . ,(alist-ref 'digitalocean-region service-config))
                   ;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
                   ("flatcar_stable_version" . "4593.2.4")))
            ;; remove the newline that generating the ssh key adds
            (display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]"))))
      (let* ((instance-id (alist-ref "id" (current-params) equal?))
             (user-id (session-user-id))
             (app-config
              (with-db/transaction
               (lambda (db)
                 (get-user-app-config db (session-user-id) instance-id))))
             (first-deployment? (not (with-db/transaction (lambda (db) (get-most-recent-deployment-status db user-id instance-id)))))
             (deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
             (dir (deployment-directory user-id instance-id))
             (backup-request-id (conc (truncate (time->seconds (current-time))) "-" (pseudo-random-integer 10000))))
        (if first-deployment?
            (with-db/transaction
               (lambda (db)
                 (update-deployment-progress db deployment-id '((instance-backup . ignored)
                                                                (machine-destroy . ignored)
                                                                (ip-destroy . ignored)
                                                                (volume-destroy . ignored)))))
            (begin
              (with-db/transaction
               (lambda (db)
                 (update-deployment-progress db deployment-id '((instance-backup . in-progress)))))
              (handle-exceptions
                  exn
                (with-db/transaction
                 (lambda (db)
                   (update-deployment-progress db deployment-id '((instance-backup . failed)))))
                (send-instance-control-command
                 (alist-ref 'root-domain app-config)
                 (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
                 "queue-restic-snapshot-no-restart"
                 (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
                 `((path . "/")
                   (tag . "automated_pre_instance_update")
                   ;; effectively a guid, we just want something unique
                   (request_id . ,backup-request-id)
                   (version . 0))))))
        (thread-start!
         (lambda ()
           (when (not first-deployment?)
             (let ((start-time (time->seconds (current-time))))
               (let loop ()
                 (thread-sleep! 1)
                 (let* ((status-result
                         (handle-exceptions
                             exn
                           '((status . "error"))
                           (send-instance-control-command
                            (alist-ref 'root-domain app-config)
                            (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
                            "restic-snapshot-status"
                            (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
                            `((request_id . ,backup-request-id)
                              (version . 0)))))
                        (complete (string=? (alist-ref 'status status-result) "complete")))
                   (if (or complete (> (- (time->seconds (current-time)) start-time) 120))
                       (with-db/transaction
                        (lambda (db)
                          (update-deployment-progress db deployment-id `((instance-backup . ,(or (and complete 'complete) 'failed))))))
                       (loop))))))
           (change-directory dir)
           (let ((pid (process-run "make preapply && make apply > make-out 2>&1")))
             (with-db/transaction (lambda (db) (update-deployment-in-progress db deployment-id pid)))
             (change-directory "../")
             (let loop ()
               (thread-sleep! 5)
               (receive (pid exit-normal status) (process-wait pid #t)
                 (if (= pid 0) ;; process is still running
                     (begin (let ((progress (parse-deployment-log
                                             (with-input-from-file
                                                 (string-append (deployment-directory user-id instance-id) "/make-out")
                                               read-string)))
                                  (tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string))
                                  (tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))
                              (with-db/transaction
                               (lambda (db)
                                 (update-deployment-progress db deployment-id progress)
                                 (when (file-exists? (string-append dir "/terraform.tfstate"))
                                   (update-user-terraform-state db user-id instance-id
                                                                (if (eof-object? tf-state) "" tf-state)
                                                                (if (eof-object? tf-state-backup) "" tf-state-backup))))))
                            (loop))
                     (let ((progress (parse-deployment-log
                                      (with-input-from-file
                                          (string-append (deployment-directory user-id instance-id) "/make-out")
                                        read-string)))
                           (tf-state (with-input-from-file (string-append dir "/terraform.tfstate") read-string))
                           (tf-state-backup (with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string)))
                       (with-db/transaction
                        (lambda (db)
                          (update-deployment-progress db deployment-id progress)
                          (update-user-terraform-state db user-id instance-id
                                                       (if (eof-object? tf-state) "" tf-state)
                                                       (if (eof-object? tf-state-backup) "" tf-state-backup))
                          (if (= status 0)
                              (update-deployment-progress db deployment-id `((instance-up . in-progress)))
                              (update-deployment-status
                               db user-id deployment-id
                               'failed
                               (with-input-from-file (string-append dir "/make-out") read-string)))))
                       (when (= status 0)
                         (let ((instance-up (instance-up? (string-append "https://"
                                                                         (alist-ref 'subdomain (alist-ref 'log-viewer (alist-ref 'config app-config)))
                                                                         "."
                                                                         (alist-ref 'root-domain app-config)))))
                           (with-db/transaction
                            (lambda (db)
                              (update-deployment-progress db deployment-id `((instance-up . ,(if instance-up 'complete 'failed))))
                              (update-deployment-status
                               db user-id deployment-id
                               (if instance-up
                                   'complete
                                   'failed)
                               (with-input-from-file (string-append dir "/make-out") read-string))))))))))))))))
      (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))

(get/widgets
 ("/config/wizard/success/:id"
  (let* ((instance-id (alist-ref "id" (current-params) equal?))
         (res (with-db/transaction
               (lambda (db)
                 `((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))))))
         (status (string->symbol (alist-ref 'status res))))
    (if (or (eq? status 'complete) (eq? status 'failed))
        '()
        '((meta (@ (http-equiv "refresh") (content "5")))))))
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (res (with-db/transaction
              (lambda (db)
                `((status . ,(get-most-recent-deployment-status db (session-user-id) instance-id))
                  (progress . ,(get-most-recent-deployment-progress db (session-user-id) instance-id))))))
        (output (handle-exceptions exn "" (with-input-from-file (string-append (deployment-directory (session-user-id) instance-id) "/make-out") read-string)))
        (progress (alist-ref 'progress res))
        (status (alist-ref 'status res)))
   `(App
     (Main-Container
      (VStack
       (h1 "Nassella - Deployment Process")
       (HStack (@ (style ((align-items "center"))))
               "Overall: " (Status-Pill
                            (@ (type ,(case (string->symbol status)
                                        ((queued) 'info)
                                        ((in-progress) 'warning)
                                        ((complete) 'safe)
                                        ((failed) 'alert))))
                            ,(case (string->symbol status)
                               ((queued) "Queued")
                               ((in-progress) "In Progress")
                               ((complete) "Complete!")
                               ((failed) "Failed"))))
       (ul ,@(map (lambda (x)
                    (if (eq? (alist-ref (car x) progress) 'ignored)
                        '()
                        `((li (HStack (@ (style ((align-items "center")
                                                 (margin-bottom ,($ 'gap.gutter)))))
                                      (Deployment-Status-Pill (@ (status ,(alist-ref (car x) progress))))
                                      ,(cdr x))))))
                  '((instance-backup . "Backup Instance")
                    (generate-configs . "Generate Custom Image")
                    (custom-image . "Upload Flatcar Image")
                    (volume-destroy . "App Volume Disconnect")
                    (machine-create . "Create Instance")
                    (ip-destroy . "Instance Mapped IP Disconnect")
                    (ip-create . "Instance Mapped IP Connect")
                    (volume-create . "App Volume Connect")
                    (machine-destroy . "Cleanup Previous Instance")
                    (instance-up . "Instance Starting Up"))))
       (form
        (@ (action "/dashboard") (method GET))
        ,@(if (or (eq? (string->symbol status) 'complete) (eq? (string->symbol status) 'failed))
              '()
              '(" (deployment will continue in the background if you leave this page)"))
        (Form-Nav (@ (back-to ,(conc "/config/wizard/review/" instance-id)) (submit-button "Finish"))))
       ,@(if (alist-ref 'log (current-params))
             `((hr)
               (pre (@ (style ((overflow-x "scroll"))))
                    ,output))
             '()))))))

(define (instance-status->display status)
  (case (string->symbol status)
    ((queued) "Queued")
    ((in-progress) "Deploying...")
    ((complete) "Deployed")
    ((failed) "Failed")
    (else "Unknown")))

(define (instance-status->pill-type status)
  (case (string->symbol status)
    ((queued) 'info)
    ((in-progress) 'warning)
    ((complete) 'safe)
    ((failed) 'alert)
    (else 'alert)))

(get/widgets
 ("/dashboard")
 (let* ((res (with-db/transaction
              (lambda (db)
                (get-dashboard db (session-user-id)))))
        (deployed-instances (filter (lambda (x) (alist-ref 'deployed x)) res))
        (not-deployed-instances (filter (lambda (x) (not (alist-ref 'deployed x))) res)))
   `(App
     (Main-Container
      (VStack
       (@ (element main))
       (h1 (@ (style ((font-size ,($ 'font.size.xxl))))) "Nassella - Instances")
       (form
        (@ (action "/config/wizard/create-instance")
           (method POST))
        (Button "Setup New Instance"))
       (ul (@ (style ((list-style "none")
                      (padding-left "0"))))
           ,@(map (lambda (instance)
                    `(li
                      (VStack
                       (@ (style ((background "rgba(0,0,0,0.1)")
                                  (border-radius ,($ 'radius.medium))
                                  (padding ,($ 'space.75))
                                  (margin-bottom ,($ 'space.100)))))
                       (VStack
                        (h2 "Undeployed Instance"))
                       (ul (li (a (@ (href "/config/wizard/services/"
                                           ,(alist-ref 'instance-id instance))
                                     (style ((color ,($ 'color.primary.background-contrast)))))
                                  "Resume Setup"))
                           (li (a (@ (href "/destroy-undeployed/" ,(alist-ref 'instance-id instance))
                                     (style ((color ,($ 'color.primary.background-contrast)))))
                                  "Destroy - deletes data and configuration (confirmation required)"))))))
                  not-deployed-instances))
       (ul (@ (style ((list-style "none")
                      (padding-left "0"))))
           ,@(map (lambda (instance)
                    (let ((root-domain (alist-ref 'root-domain instance))
                          (config (alist-ref 'config instance)))
                      `(li
                        (VStack
                         (@ (style ((background "rgba(0,0,0,0.1)")
                                    (border-radius ,($ 'radius.medium))
                                    (padding ,($ 'space.75))
                                    (margin-bottom ,($ 'space.100)))))
                         (VStack
                          (h2 ,root-domain)
                          ,@(if (alist-ref 'status instance)
                                `((Status-Pill (@ (type ,(instance-status->pill-type (alist-ref 'status instance))))
                                               ,(instance-status->display (alist-ref 'status instance))))
                                '()))
                         (h3 "Apps")
                         (ul ,@(map (lambda (app-info)
                                      (let ((app (alist-ref 'app-name app-info)))
                                        `((li ;; (a (@ (href "#") (style ((color ,($ 'color.primary.background-contrast))))) ,app)
                                              (h4 ,app " (v" ,(alist-ref 'installed-version app-info) ") ")
                                              (a (@ (href "https://"
                                                          ,(alist-ref 'subdomain (alist-ref app config))
                                                          "." ,root-domain)
                                                    (style ((color ,($ 'color.primary.background-contrast)))))
                                                 ,(alist-ref 'subdomain (alist-ref app config))
                                                 "." ,root-domain)))))
                                    (or (filter (lambda (app-info)
                                                  (case (alist-ref 'app-name app-info)
                                                    ((instance-control lldap authelia) #f)
                                                    (else #t)))
                                                (alist-ref 'apps instance))
                                        '())))
                         (h3 "Actions")
                         (ul (li (a (@ (href "/config/wizard/services/"
                                             ,(alist-ref 'instance-id instance))
                                       (style ((color ,($ 'color.primary.background-contrast)))))
                                    "Modify Setup"))
                             ;; (li "Upgrade Now (pending automatic upgrades scheduled for: )")
                             (li (a (@ (href "/backups/" ,(alist-ref 'instance-id instance))
                                       (style ((color ,($ 'color.primary.background-contrast)))))
                                    "Manage Backups"))
                             (li (a (@ (href "/destroy/" ,(alist-ref 'instance-id instance))
                                       (style ((color ,($ 'color.primary.background-contrast)))))
                                    "Destroy - deletes data and configuration (confirmation required)"))
                             (li (a (@ (href "/reset/" ,(alist-ref 'instance-id instance))
                                       (style ((color ,($ 'color.primary.background-contrast)))))
                                    "Reset - deletes data (confirmation required)")))))))
                  deployed-instances)))))))

(get/widgets
 ("/destroy-undeployed/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?)))
   `(App
     (h2 "Destroy Undeployed Instance")
     (h3 "This action is NOT reversible.")
     (form
      (@ (action ,(conc "/destroy-undeployed-submit/" instance-id)) (method POST))
      (VStack
       (Fieldset
        (@ (title "Type the word 'DELETE' to confirm."))
        (Field (@ (name "confirm") (label ("Type DELETE")) (value ""))))
       (Form-Nav (@ (back-to "/dashboard") (submit-button "Destroy"))))))))

(post "/destroy-undeployed-submit/:id"
 (let* ((instance-id (alist-ref "id" (current-params) equal?)))
   (if (not (string=? (alist-ref 'confirm (current-params)) "DELETE"))
       (redirect (conc "/destroy-undeployed/" instance-id))
       (begin (with-db/transaction
               (lambda (db)
                 (destroy-instance db instance-id)))
              (redirect "/dashboard")))))

(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 "Delete Instance"))
        (Field (@ (name "instance-domain") (label ("Type the domain name of the instance to confirm.")) (value "")))
        (Field (@ (name "delete-backups") (label ("Delete backups for this instance")) (type "checkbox"))))
       (Form-Nav (@ (back-to "/dashboard") (submit-button "Destroy"))))))))

(post "/destroy-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)))))))
    (if (or (not (or (eq? status 'queued) (eq? status 'in-progress)))
            (equal? (alist-ref 'force (current-params)) "true"))
        (let* ((instance-id (alist-ref "id" (current-params) equal?))
               (restic-snapshot-id (alist-ref 'restic-snapshot-id (current-params)))
               (results
                (with-db/transaction
                 (lambda (db)
                   `((selected-apps . ,(get-user-selected-apps db (session-user-id) instance-id))
                     (app-config . ,(get-user-app-config db (session-user-id) instance-id))
                     (service-config . ,(get-user-service-config db (session-user-id) instance-id))
                     (terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))
                     (ssh-pub-key . ,(get-instance-ssh-pub-key db (session-user-id) instance-id))
                     (restic-password . ,(get-instance-restic-password db (session-user-id) instance-id))))))
               (selected-apps (alist-ref 'selected-apps results))
               (app-config (alist-ref 'app-config results))
               (config (alist-ref 'config app-config))
               (root-domain (alist-ref 'root-domain app-config))
               (service-config (alist-ref 'service-config results))
               (terraform-state (alist-ref 'terraform-state results))
               (ssh-pub-key (alist-ref 'ssh-pub-key results))
               (restic-password (alist-ref 'restic-password results))
               (dir (deployment-directory (session-user-id) instance-id)))
          (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-version)
                                                     (conc (if (eq? (car app-version) 'log-viewer) 'dozzle (car app-version))
                                                           ","
                                                           (alist-ref 'subdomain (alist-ref (car app-version) config))
                                                           ","
                                                           (cdr app-version)))
                                                   selected-apps)
                                              " "))
                           ("HOST_ADMIN_USER" . ,(alist-ref 'user (alist-ref 'log-viewer config)))
                           ("HOST_ADMIN_PASSWORD" . ,(alist-ref 'password (alist-ref 'log-viewer config)))
                           ("NEXTCLOUD_ADMIN_USER" . ,(alist-ref 'admin-user (alist-ref 'nextcloud config)))
                           ("NEXTCLOUD_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'nextcloud config)))
                           ("NEXTCLOUD_POSTGRES_DB" . "nextcloud")
                           ("NEXTCLOUD_POSTGRES_USER" . "nextcloud")
                           ("NEXTCLOUD_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nextcloud config)))
                           ("NEXTCLOUD_REDIS_PASSWORD" . ,(alist-ref 'redis-password (alist-ref 'nextcloud config)))
                           ("GHOST_DATABASE_ROOT_PASSWORD" . ,(alist-ref 'postgres-root-password (alist-ref 'ghost config)))
                           ("GHOST_DATABASE_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'ghost config)))
                           ("NASSELLA_LLDAP_SUBDOMAIN" . ,(alist-ref 'lldap-subdomain (alist-ref 'nassella config)))
                           ("NASSELLA_POSTGRES_DB" . "nassella")
                           ("NASSELLA_POSTGRES_USER" . "nassella")
                           ("NASSELLA_POSTGRES_PASSWORD" . ,(alist-ref 'postgres-password (alist-ref 'nassella config)))
                           ("NASSELLA_AUTHELIA_POSTGRES_DB" . "authelia")
                           ("NASSELLA_AUTHELIA_POSTGRES_USER" . "authelia")
                           ("NASSELLA_AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'authelia-postgres-password (alist-ref 'nassella config)))
                           ("NASSELLA_LLDAP_POSTGRES_DB" . "lldap")
                           ("NASSELLA_LLDAP_POSTGRES_USER" . "lldap")
                           ("NASSELLA_LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'lldap-postgres-password (alist-ref 'nassella config)))
                           ("NASSELLA_LLDAP_JWT_SECRET" . ,(alist-ref 'lldap-jwt-secret (alist-ref 'nassella config)))
                           ("NASSELLA_LLDAP_KEY_SEED" . ,(alist-ref 'lldap-key-seed (alist-ref 'nassella config)))
                           ("NASSELLA_LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'lldap-admin-password (alist-ref 'nassella config)))
                           ("NASSELLA_STRIPE_API_KEY" . ,(alist-ref 'stripe-api-key (alist-ref 'nassella config)))
                           ("NASSELLA_AUTHELIA_JWT_SECRET" . ,(alist-ref 'authelia-jwt-secret (alist-ref 'nassella config)))
                           ("NASSELLA_AUTHELIA_KEY_SEED" . ,(alist-ref 'authelia-key-seed (alist-ref 'nassella config)))
                           ("WORDPRESS_DB_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'wordpress config)))
                           ("WORDPRESS_DB_ROOT_PASSWORD" . ,(alist-ref 'db-root-password (alist-ref 'wordpress config)))
                           ("LLDAP_POSTGRES_DB" . "lldap")
                           ("LLDAP_POSTGRES_USER" . "lldap")
                           ("LLDAP_POSTGRES_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'lldap config)))
                           ("LLDAP_JWT_SECRET" . ,(alist-ref 'jwt-secret (alist-ref 'lldap config)))
                           ("LLDAP_KEY_SEED" . ,(alist-ref 'key-seed (alist-ref 'lldap config)))
                           ("LLDAP_ADMIN_PASSWORD" . ,(alist-ref 'admin-password (alist-ref 'lldap config)))
                           ("LLDAP_USER_EMAIL" . ,(alist-ref 'user-email (alist-ref 'lldap config)))
                           ("AUTHELIA_POSTGRES_DB" . "authelia")
                           ("AUTHELIA_POSTGRES_USER" . "authelia")
                           ("AUTHELIA_POSTGRES_PASSWORD" . ,(alist-ref 'db-password (alist-ref 'authelia config)))
                           ("AUTHELIA_JWT_SECRET" . ,(alist-ref 'jwt-secret (alist-ref 'authelia config)))
                           ("AUTHELIA_SESSION_SECRET" . ,(alist-ref 'session-secret (alist-ref 'authelia config)))
                           ("AUTHELIA_ENCRYPTION_KEY" . ,(alist-ref 'encryption-key (alist-ref 'authelia config)))
                           ("SMTP_HOST" . ,(alist-ref 'smtp-host (alist-ref 'all-apps config)))
                           ("SMTP_PORT" . ,(alist-ref 'smtp-port (alist-ref 'all-apps config)))
                           ("SMTP_AUTH_USER" . ,(alist-ref 'smtp-auth-user (alist-ref 'all-apps config)))
                           ("SMTP_AUTH_PASSWORD" . ,(alist-ref 'smtp-auth-password (alist-ref 'all-apps config)))
                           ("SMTP_FROM" . ,(alist-ref 'smtp-from (alist-ref 'all-apps config)))
                           ("BACKBLAZE_KEY_ID" . ,(alist-ref 'backblaze-key-id service-config))
                           ("BACKBLAZE_APPLICATION_KEY" . ,(alist-ref 'backblaze-application-key service-config))
                           ("BACKBLAZE_BUCKET_URL" . ,(alist-ref 'backblaze-bucket-url service-config))
                           ("RESTIC_PASSWORD" . ,restic-password)
                           ("INSTANCE_CONTROL_WEBHOOKS_SECRET" . ,(alist-ref 'webhooks-secret (alist-ref 'instance-control config)))
                           ,@(if (and restic-snapshot-id (not (string=? restic-snapshot-id ""))) `(("RESTIC_SNAPSHOT_ID" . ,restic-snapshot-id)) '())))))
                (with-output-to-file (string-append dir "/config/production.tfvars")
                  (lambda ()
                    (map (lambda (e)
                           (write-terraform-config-entry (car e) (cdr e)))
                         `(("server_type" . ,(alist-ref 'digitalocean-size service-config))
                           ("do_token" . ,(alist-ref 'digitalocean-api-token service-config))
                           ("digitalocean_volume_size" . ,(alist-ref 'digitalocean-volume-size service-config))
                           ("cloudflare_api_token" . ,(alist-ref 'cloudflare-api-token service-config))
                           ("cloudflare_zone_id" . ,(alist-ref 'cloudflare-zone-id service-config))
                           ("cloudflare_account_id" . ,(alist-ref 'cloudflare-account-id service-config))
                           ("cluster_name" . ,(string-append "nassella" (string-delete #\. root-domain))) ;; TODO update to: (import srfi-14) (string-filter char-set:letter+digit root-domain)
                           ("datacenter" . ,(alist-ref 'digitalocean-region service-config))
                           ;; (source <(curl -sSfL https://stable.release.flatcar-linux.net/amd64-usr/current/version.txt); echo "${FLATCAR_VERSION_ID}")
                           ("flatcar_stable_version" . "4593.2.4")))
                    ;; remove the newline that generating the ssh key adds
                    (display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]")))
                (let* ((instance-id (alist-ref "id" (current-params) equal?))
                       (delete-backups (alist-ref 'delete-backups (current-params) equal?))
                       (user-id (session-user-id))
                       (app-config
                        (with-db/transaction
                         (lambda (db)
                           (get-user-app-config db (session-user-id) instance-id))))
                       (deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
                       (dir (deployment-directory user-id instance-id)))
                  (thread-start!
                   (lambda ()
                     (change-directory dir)
                     (let ((pid (process-run "make preapply && 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)
                                    (when (= status 0)
                                      (update-deployment-status
                                       db user-id deployment-id
                                       '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))))
                                 ;; todo handle errors here
                                 (when delete-backups
                                   (b2-delete-bucket-files (alist-ref 'backblaze-key-id service-config) (alist-ref 'backblaze-application-key service-config)
                                                           (last (uri-path (uri-reference (alist-ref 'backblaze-bucket-url service-config))))))
                                 (with-db/transaction
                                  (lambda (db)
                                    (update-deployment-status
                                     db user-id deployment-id
                                     'complete
                                     (with-input-from-file (string-append dir "/make-out") read-string))))
                                 (with-db/transaction
                                  (lambda (db)
                                    (destroy-instance db instance-id)))))))))))
                (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))))
        (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))))

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

(define (roundx n)
  (/ (round (* 10 n)) 10.0))

;; The restic date doesn't parse well all the time with srfi-19
;; so we remove the nanoseconds and set it to UTC (which it is)
(define (normalize-restic-date s) (string-append (string-take s (string-index s #\.)) "Z+00:00"))
(define (restic-date-string->date s) (string->date (normalize-restic-date s) "~Y-~m-~dT~H:~M:~S~z"))

(get/widgets
 ("/backups/:id")
 (let* ((instance-id (alist-ref "id" (current-params) equal?))
        (bytes-in-mib 1048576.0))
   `(App
     (Main-Container
      (VStack
       (h1 "Backups")
       (a (@ (href ,(conc "/backups/" instance-id "/create"))) "Create Snapshot")
       (table
        (thead
         (tr (th "Time") (th "Total Size (MiB)") (th "Tag") (th "*")))
        (tbody
         ,@(map (lambda (snapshot)
                  `(tr
                    (td ,(alist-ref 'time snapshot))
                    (td ,(roundx
                          (/ (or (alist-ref 'total_bytes_processed (alist-ref 'summary snapshot)) 0) bytes-in-mib)))
                    (td ,(or (alist-ref 'tags snapshot) ""))
                    (td (a (@ (href ,(conc "/backups/" instance-id "/restore/"
                                           (alist-ref 'short_id snapshot))))
                           "Restore"))))
                (sort
                 (restic-snapshots (session-user-id) instance-id)
                 (lambda (a b) (date>? (restic-date-string->date (alist-ref 'time a))
                                       (restic-date-string->date (alist-ref 'time b)))))))))))))

(get/widgets
 ("/backups/:instance_id/restore/:restic_id")
 (let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
        (restic-id (alist-ref "restic_id" (current-params) equal?))
        (snapshot-info (find (lambda (snapshot)
                               (string=? (alist-ref 'short_id snapshot) restic-id))
                             (restic-snapshots (session-user-id) instance-id)))
        (results
         (with-db/transaction
          (lambda (db)
            `((selected-apps . ,(map
                                 car
                                 (filter cdr
                                         (get-user-selected-apps db (session-user-id) instance-id))))
              (app-config . ,(get-user-app-config db (session-user-id) instance-id))
              (service-config . ,(get-user-service-config db (session-user-id) instance-id))))))
        (selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
        (app-config (alist-ref 'app-config results))
        (config (alist-ref 'config app-config))
        (root-domain (alist-ref 'root-domain app-config))
        (service-config (alist-ref 'service-config results)))
   `(App
     (Main-Container
      (VStack
       (h1 "Instance Snapshot Restore")
       (ul (li "Snapshot date: " ,(alist-ref 'time snapshot-info))
           (li "Snapshot tags: " ,(alist-ref 'tags snapshot-info)))
       (h2 "Root Domain")
       ,root-domain
       (h2 "Apps")
       (ul ,@(map (lambda (app) `(li ,app " @ "
                                     ,(alist-ref 'subdomain (alist-ref app config))
                                     "."
                                     ,root-domain))
                  selected-apps))
       (h2 "Machine")
       (ul (li "Region: " ,(alist-ref 'digitalocean-region service-config))
           (li "Size: " ,(alist-ref 'digitalocean-size service-config)))
       (form
        (@ (action ,(conc "/config/wizard/review-submit/" instance-id)) (method POST))
        (Field (@ (name "restic-snapshot-id") (type "hidden") (value ,restic-id)))
        (VStack
         (Form-Nav (@ (back-to ,(conc "/backups/" instance-id)) (submit-button "Restore"))))))))))

(get/widgets
 ("/backups/:instance_id/create")
 (let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
        (root-domain (alist-ref 'root-domain
                                (with-db/transaction
                                 (lambda (db)
                                   (get-user-app-config db (session-user-id) instance-id))))))
   `(App
     (Main-Container
      (VStack
       (h1 "Create Snapshot")
       (h2 "Root Domain")
       ,root-domain
       (form
        (@ (action ,(conc "/backups/" instance-id "/create-submit")) (method POST))
        (Fieldset (@ (title "Snapshot Properties"))
                  (Field (@ (name "tag") (label ("Tag")))))
        (VStack
         (Form-Nav (@ (back-to ,(conc "/backups/" instance-id)) (submit-button "Create"))))))))))

(post "/backups/:instance_id/create-submit"
 (let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
        (app-config (with-db/transaction
                     (lambda (db)
                       (get-user-app-config db (session-user-id) instance-id))))
        (request-id (conc (truncate (time->seconds (current-time))) "-" (pseudo-random-integer 10000))))
   (send-instance-control-command
    (alist-ref 'root-domain app-config)
    (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
    "queue-restic-snapshot"
    (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
    `((path . "/") ;; unused for now but we do want root until we support backing up individual apps
      (tag . ,(alist-ref 'tag (current-params)))
      ;; effectively a guid, we just want something unique
      (request_id . ,request-id)
      (version . 0)))
   (redirect (conc "/backups/" instance-id "/create-success/" request-id))))

(get/widgets
 ("/backups/:instance_id/create-success/:request_id"
  (let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
         (request-id (alist-ref "request_id" (current-params) equal?))
         (app-config (with-db/transaction
                     (lambda (db)
                       (get-user-app-config db (session-user-id) instance-id))))
         (status-result
          (send-instance-control-command
           (alist-ref 'root-domain app-config)
           (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
           "restic-snapshot-status"
           (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
           `((request_id . ,request-id)
             (version . 0))))
         (complete (string=? (alist-ref 'status status-result) "complete")))
    (if complete
        '()
        '((meta (@ (http-equiv "refresh") (content "5")))))))
 (let* ((instance-id (alist-ref "instance_id" (current-params) equal?))
        (request-id (alist-ref "request_id" (current-params) equal?))
        (app-config (with-db/transaction
                     (lambda (db)
                       (get-user-app-config db (session-user-id) instance-id))))
        (status-result
         (send-instance-control-command
          (alist-ref 'root-domain app-config)
          (alist-ref 'subdomain (alist-ref 'instance-control (alist-ref 'config app-config)))
          "restic-snapshot-status"
          (alist-ref 'webhooks-secret (alist-ref 'instance-control (alist-ref 'config app-config)))
          `((request_id . ,request-id)
            (version . 0))))
        (complete (string=? (alist-ref 'status status-result) "complete")))
   `(App
     (Main-Container
      (VStack
       (h1 ,(if complete "Snapshot Complete" "Snapshot In Progress..."))
       (div
        (a (@ (href "/dashboard")) "Dashboard")
        ,@(if complete
              '()
              " (snapshot will continue in the background if you leave this page)")))))))

(schematra-install)

))