nassella/app
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Adding tests.

Browse Source
This commit is contained in:
Thomas Hintz
2025-11-30 11:36:19 -08:00
parent 5ca856b1ff
commit e372f2157b
4 changed files with 3873 additions and 321 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
src/db.scm
View File

@@ -5,7 +5,7 @@
;;functions
with-db with-db/transaction
create-user
create-user delete-user
update-user-service-config get-user-service-config
update-user-selected-apps get-user-selected-apps
update-user-app-config get-user-app-config
@@ -126,13 +126,6 @@
(user-iv (blob->hexstring/uppercase (generate-iv))))
(receive (enc-user-key tag)
(encrypt user-key *root-key-key* *root-key-iv* (string->blob (number->string auth-user-id)))
;; (write user-key)
;; (newline)
;; (write user-iv)
;; (newline)
;; (write (blob->hexstring/uppercase (string->blob enc-user-key)))
;; (newline)
;; (write (blob->hexstring/uppercase (string->blob tag)))
(let ((user-id
(value-at
(query conn
@@ -145,7 +138,11 @@ returning users.user_id;"
(query conn "insert into user_service_configs(user_id) values ($1);" user-id)
(query conn "insert into user_selected_apps(user_id) values ($1);" user-id)
(query conn "insert into user_app_configs(user_id) values ($1);" user-id)
(query conn "insert into user_terraform_state(user_id) values ($1);" user-id)))))
(query conn "insert into user_terraform_state(user_id) values ($1);" user-id)
user-id))))
(define (delete-user conn user-id)
(query conn "delete from users where user_id=$1;" user-id))
(define *user-service-configs-column-map*
'((cloudflare-api-token . ("cloudflare_api_token_enc" #t))
@@ -443,7 +440,7 @@ returning users.user_id;"
""
(user-decrypt-from-db (alist-ref 'state_backup_enc res) user-key user-iv user-id)))))))
(with-db/transaction (lambda (db) (get-user-deployments db 7)))
;; (with-db/transaction (lambda (db) (get-user-deployments db 7)))
;; (with-db/transaction (lambda (db) (get-most-recent-deployment-progress db 7)))
;; (with-db/transaction (lambda (db) (get-deployment-progress db 14)))
;; (with-db/transaction (lambda (db) (update-deployment-progress db 14 '((generate-configs . complete) (custom-image . in-progress) (machine-create . queued)))))

3096
src/mocks.scm Normal file
View File

File diff suppressed because one or more lines are too long

653
src/nassella.scm
View File

@@ -1,4 +1,5 @@
(load "db.scm")
(load "mocks.scm")
(import (chicken string)
(chicken port)
@@ -14,7 +15,7 @@
html-widgets
sxml-transforms
(prefix schematra schematra:)
schematra
schematra-body-parser
schematra-session
uri-common
@@ -24,7 +25,11 @@
nassella-db
sql-null)
(schematra:use-middleware! (body-parser-middleware))
(define app (schematra/make-app))
(with-schematra-app app
(lambda ()
(use-middleware! (body-parser-middleware))))
(define *global-css-reset*
"/*
@@ -261,31 +266,45 @@ h1, h2, h3, h4, h5, h6 {
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)))))
(schematra:use-middleware! (session-middleware "your-secret-key-here"))
(with-schematra-app app
(lambda ()
(use-middleware! (session-middleware "your-secret-key-here")))) ;; TODO generate better one
(define-syntax get
(define test-user-id (make-parameter 7))
(define (session-user-id)
(or (session-get "user-id") (test-user-id)))
(define-syntax get/widgets
(syntax-rules ()
((_ (path) body ...)
(schematra:get (path)
(with-output-to-string
(lambda ()
(widget-sxml->html
'((meta (@ (name "viewport") (content "width=device-width"))))
(begin
;; TODO remove once sessions are integrated
(session-set! "user-id" 7)
(session-set! "username" "me")
body ...))))))))
(get path
(with-output-to-string
(lambda ()
(widget-sxml->html
'((meta (@ (name "viewport") (content "width=device-width"))))
(begin
;; TODO remove once sessions are integrated
(session-set! "user-id" (test-user-id))
(session-set! "username" "me")
body ...))))))))
(define-widget (Container ((max-width ($ 'width.main.max)) (style '())) contents)
`(div (@ (data-name "Container")
@@ -479,164 +498,6 @@ h1, h2, h3, h4, h5, h6 {
"Back")
(Button ,submit-button)))
(get
("/config/wizard/services")
(let ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-get "user-id"))))))
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/services-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(Field (@ (name "cloudflare-api-token") (label ("API Token")) (value ,(alist-ref 'cloudflare-api-token config))))
(Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (value ,(alist-ref 'cloudflare-zone-id config))))
(Field (@ (name "cloudflare-account-id") (label ("Account ID")) (value ,(alist-ref 'cloudflare-account-id config)))))
(Fieldset
(@ (title "DigitalOcean"))
(Field (@ (name "digitalocean-api-token") (label ("API Token")) (value ,(alist-ref 'digitalocean-api-token config)))))
(Fieldset
(@ (title "Backblaze"))
(Field (@ (name "backblaze-application-key") (label ("Application Key")) (value ,(alist-ref 'backblaze-application-key config))))
(Field (@ (name "backblaze-key-id") (label ("Key ID")) (value ,(alist-ref 'backblaze-key-id config))))
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url config)))))
(Form-Nav)))))))
(schematra:post ("/config/wizard/services-submit")
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-get "user-id")
`((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (schematra:current-params)))
(cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (schematra:current-params)))
(cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (schematra:current-params)))
(digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (schematra:current-params)))
(backblaze-application-key . ,(alist-ref 'backblaze-application-key (schematra:current-params)))
(backblaze-key-id . ,(alist-ref 'backblaze-key-id (schematra:current-params)))
(backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (schematra:current-params)))))))
(schematra:redirect "/config/wizard/services-success"))
(get
("/config/wizard/services-success")
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/apps"))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(h3 "Connected")
(p "Your Cloudflare account was successfully connected!"))
(Fieldset
(@ (title "DigitalOcean"))
(h3 "Connected")
(p "Your DigitalOcean account was successfully connected!"))
(Fieldset
(@ (title "Backblaze"))
(h3 "Connected")
(p "Your Backblaze account was successfully connected!"))
(Form-Nav (@ (back-to "/config/wizard/services"))))))))
(get
("/config/wizard/apps")
(let ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id"))))))))
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps-submit") (method POST))
(VStack
(Fieldset
(@ (title "Root Domain"))
(Field (@ (element select) (name "root-domain"))
(option (@ (value ,(alist-ref 'root-domain (alist-ref 'app-config results)))) "nassella.cc"))) ;; TODO fetch from cloudflare API?
(Fieldset
(@ (title "Selected Apps"))
(Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps results)))))
(Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'nextcloud (alist-ref 'selected-apps results)))))
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
(Form-Nav (@ (back-to "/config/wizard/services-success")))))))))
(schematra:post ("/config/wizard/apps-submit")
(with-db/transaction
(lambda (db)
(update-user-selected-apps
db
(session-get "user-id")
`((wg-easy . ,(or (and (alist-ref 'wg-easy (schematra:current-params)) "0.0") (sql-null)))
(nextcloud . ,(or (and (alist-ref 'nextcloud (schematra:current-params)) "0.0") (sql-null)))))
(update-root-domain db (session-get "user-id") (alist-ref 'root-domain (schematra:current-params)))))
(schematra:redirect "/config/wizard/apps2"))
(get
("/config/wizard/apps2")
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id")))))))
(selected-apps (alist-ref 'selected-apps results))
(app-config (alist-ref 'app-config results)))
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps2-submit") (method POST))
(VStack
,@(if (member 'wg-easy selected-apps)
`((Fieldset
(@ (title "WG-Easy"))
(Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'wg-easy app-config eq? '()) eq? "wg-easy"))))))
'())
,@(if (member 'nextcloud selected-apps)
`((Fieldset
(@ (title "NextCloud"))
(Field (@ (name "nextcloud-subdomain") (label ("Subdomain"))
(value ,(alist-ref 'subdomain (alist-ref 'nextcloud app-config eq? '()) eq? "nextcloud"))))
(Field (@ (name "nextcloud-admin-user") (label ("Admin Username"))
(value ,(alist-ref 'admin-user (alist-ref 'nextcloud app-config eq? '()) eq? "admin"))))
(Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password")
(value ,(alist-ref 'admin-password (alist-ref 'nextcloud app-config eq? '()) eq? ""))))))
'())
(Fieldset
(@ (title "Log Viewer"))
(Field (@ (name "log-viewer-subdomain") (label ("Subdomain"))
(value ,(alist-ref 'subdomain (alist-ref 'log-viewer app-config eq? '()) eq? "logs"))))
(Field (@ (name "log-viewer-user") (label ("Username"))
(value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
(Field (@ (name "log-viewer-password") (label ("Password")) (type "password")
(value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? "")))))
(Form-Nav (@ (back-to "/config/wizard/apps")))))))))
(schematra:post ("/config/wizard/apps2-submit")
(with-db/transaction
(lambda (db)
(update-user-app-config
db
(session-get "user-id")
`((wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (schematra:current-params)))))
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (schematra:current-params)))
(admin-user . ,(alist-ref 'nextcloud-admin-user (schematra:current-params)))
(admin-password . ,(alist-ref 'nextcloud-admin-password (schematra:current-params)))))
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (schematra:current-params)))
(user . ,(alist-ref 'log-viewer-user (schematra:current-params)))
(password . ,(alist-ref 'log-viewer-password (schematra:current-params)))))))))
(schematra:redirect "/config/wizard/machine"))
;; Parsing JSON arrays as lists instead of vectors
(define array-as-list-parser
(cons 'array (lambda (x) x)))
@@ -647,14 +508,16 @@ h1, h2, h3, h4, h5, h6 {
(filter
(lambda (r)
(alist-ref 'available r))
(alist-ref
'regions
(let* ((uri (uri-reference "https://api.digitalocean.com/v2/regions"))
(req (make-request method: 'GET
uri: uri
headers: (headers `((content-type application/json)
(Authorization ,(conc "Bearer " api-token)))))))
(with-input-from-request req #f read-json)))))
(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
@@ -662,114 +525,14 @@ h1, h2, h3, h4, h5, h6 {
(alist-ref 'available r))
(alist-ref
'sizes
(let* ((uri (uri-reference "https://api.digitalocean.com/v2/sizes?per_page=200"))
(req (make-request method: 'GET
uri: uri
headers: (headers `((content-type application/json)
(Authorization ,(conc "Bearer " api-token)))))))
(with-input-from-request req #f read-json)))))
(get
("/config/wizard/machine")
(let ((config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-get "user-id"))))))
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Region"))
(Field (@ (element select) (name "region"))
(option (@ (value "")) "")
,@(map (lambda (r)
`(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r)))
(get-digital-ocean-regions (alist-ref 'digitalocean-api-token config)))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2"))))))))))
(schematra:post ("/config/wizard/machine-submit")
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-get "user-id")
`((digitalocean-region . ,(alist-ref 'region (schematra:current-params)))))))
(schematra:redirect "/config/wizard/machine2"))
(get
("/config/wizard/machine2")
(let* ((config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-get "user-id")))))
(region (alist-ref 'digitalocean-region config))
(all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token config)))
(sizes (filter (lambda (s) (member region (alist-ref 'regions s))) all-sizes)))
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine2-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Size"))
(Field (@ (element select) (name "size") (input-style ((max-width "100%"))))
,@(map (lambda (s) `(option (@ (value ,(alist-ref 'slug s))
,@(if (equal? (alist-ref 'slug s) "s-2vcpu-2gb") `((selected "selected")) '()))
"$" ,(alist-ref 'price_monthly s)
" (CPU: ",(alist-ref 'vcpus s)
" Mem: " ,(/ (alist-ref 'memory s) 1024)
" Disk: " ,(alist-ref 'disk s)
") " ,(alist-ref 'description s)))
sizes)))
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine"))))))))))
(schematra:post ("/config/wizard/machine2-submit")
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-get "user-id")
`((digitalocean-size . ,(alist-ref 'size (schematra:current-params)))))))
(schematra:redirect "/config/wizard/review"))
(get
("/config/wizard/review")
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id")))
(service-config . ,(get-user-service-config db (session-get "user-id")))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config))
(root-domain (alist-ref 'root-domain app-config))
(service-config (alist-ref 'service-config results)))
`(App
(Configuration-Wizard
(@ (step "Review"))
(h2 "Root Domain")
,root-domain
(h2 "Apps")
(ul ,@(map (lambda (app) `(li ,app " @ "
,(alist-ref 'subdomain (alist-ref app config))
"."
,root-domain))
selected-apps))
(h2 "Machine")
(ul (li "Region: " ,(alist-ref 'digitalocean-region service-config))
(li "Size: " ,(alist-ref 'digitalocean-size service-config)))
(form
(@ (action "/config/wizard/review-submit") (method POST))
(VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2")) (submit-button "Launch")))))))))
(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 (deployment-directory user-id)
(string-append "deploy-" (number->string user-id)))
@@ -803,24 +566,298 @@ h1, h2, h3, h4, h5, h6 {
(display value)
(print "\""))
(schematra:post ("/config/wizard/review-submit")
(define (progress-status->text status)
(case status
((queued) "queued")
((in-progress) "in progress")
((complete) "complete")
((failed) "failed")))
(with-schematra-app app
(lambda ()
(get/widgets
("/config/wizard/services")
(let ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-user-id))))))
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/services-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(Field (@ (name "cloudflare-api-token") (label ("API Token")) (value ,(alist-ref 'cloudflare-api-token config))))
(Field (@ (name "cloudflare-zone-id") (label ("Zone ID")) (value ,(alist-ref 'cloudflare-zone-id config))))
(Field (@ (name "cloudflare-account-id") (label ("Account ID")) (value ,(alist-ref 'cloudflare-account-id config)))))
(Fieldset
(@ (title "DigitalOcean"))
(Field (@ (name "digitalocean-api-token") (label ("API Token")) (value ,(alist-ref 'digitalocean-api-token config)))))
(Fieldset
(@ (title "Backblaze"))
(Field (@ (name "backblaze-application-key") (label ("Application Key")) (value ,(alist-ref 'backblaze-application-key config))))
(Field (@ (name "backblaze-key-id") (label ("Key ID")) (value ,(alist-ref 'backblaze-key-id config))))
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url config)))))
(Form-Nav)))))))
(post "/config/wizard/services-submit"
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
`((cloudflare-api-token . ,(alist-ref 'cloudflare-api-token (current-params)))
(cloudflare-account-id . ,(alist-ref 'cloudflare-account-id (current-params)))
(cloudflare-zone-id . ,(alist-ref 'cloudflare-zone-id (current-params)))
(digitalocean-api-token . ,(alist-ref 'digitalocean-api-token (current-params)))
(backblaze-application-key . ,(alist-ref 'backblaze-application-key (current-params)))
(backblaze-key-id . ,(alist-ref 'backblaze-key-id (current-params)))
(backblaze-bucket-url . ,(alist-ref 'backblaze-bucket-url (current-params)))))))
(redirect "/config/wizard/services-success"))
(get/widgets
("/config/wizard/services-success")
`(App
(Configuration-Wizard
(@ (step "Services"))
(form
(@ (action "/config/wizard/apps"))
(VStack
(Fieldset
(@ (title "Cloudflare"))
(h3 "Connected")
(p "Your Cloudflare account was successfully connected!"))
(Fieldset
(@ (title "DigitalOcean"))
(h3 "Connected")
(p "Your DigitalOcean account was successfully connected!"))
(Fieldset
(@ (title "Backblaze"))
(h3 "Connected")
(p "Your Backblaze account was successfully connected!"))
(Form-Nav (@ (back-to "/config/wizard/services"))))))))
(get/widgets
("/config/wizard/apps")
(let ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-user-id)))))
(app-config . ,(get-user-app-config db (session-user-id))))))))
`(App
(Configuration-Wizard
(@ (step "Apps"))
(form
(@ (action "/config/wizard/apps-submit") (method POST))
(VStack
(Fieldset
(@ (title "Root Domain"))
(Field (@ (element select) (name "root-domain"))
(option (@ (value ,(alist-ref 'root-domain (alist-ref 'app-config results)))) "nassella.cc"))) ;; TODO fetch from cloudflare API?
(Fieldset
(@ (title "Selected Apps"))
(Field (@ (name "wg-easy") (type "checkbox") (label ("WG Easy")) (checked ,(member 'wg-easy (alist-ref 'selected-apps results)))))
(Field (@ (name "nextcloud") (type "checkbox") (label ("NextCloud")) (checked ,(member 'nextcloud (alist-ref 'selected-apps results)))))
(Field (@ (name "log-viewer") (type "checkbox") (label ("Log Viewer")) (checked #t) (disabled "disabled"))))
(Form-Nav (@ (back-to "/config/wizard/services-success")))))))))
(post "/config/wizard/apps-submit"
(with-db/transaction
(lambda (db)
(update-user-selected-apps
db
(session-user-id)
`((wg-easy . ,(or (and (alist-ref 'wg-easy (current-params)) "0.0") (sql-null)))
(nextcloud . ,(or (and (alist-ref 'nextcloud (current-params)) "0.0") (sql-null)))))
(update-root-domain db
(session-user-id)
(alist-ref 'root-domain (current-params)))))
(redirect "/config/wizard/apps2"))
;; TODO should this even allow changing existing username/passwords like for db?
;; wouldn't that break the db connection and you would lose data?
(get/widgets
("/config/wizard/apps2")
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id")))
(service-config . ,(get-user-service-config db (session-get "user-id")))
(terraform-state . ,(get-user-terraform-state db (session-get "user-id")))))))
(get-user-selected-apps db (session-user-id)))))
(app-config . ,(get-user-app-config db (session-user-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 "/config/wizard/apps2-submit") (method POST))
(VStack
,@(if (member 'wg-easy selected-apps)
`((Fieldset
(@ (title "WG-Easy"))
(Field (@ (name "wg-easy-subdomain") (label ("Subdomain")) (value ,(alist-ref 'subdomain (alist-ref 'wg-easy app-config eq? '()) eq? "wg-easy"))))))
'())
,@(if (member 'nextcloud selected-apps)
`((Fieldset
(@ (title "NextCloud"))
(Field (@ (name "nextcloud-subdomain") (label ("Subdomain"))
(value ,(alist-ref 'subdomain (alist-ref 'nextcloud app-config eq? '()) eq? "nextcloud"))))
(Field (@ (name "nextcloud-admin-user") (label ("Admin Username"))
(value ,(alist-ref 'admin-user (alist-ref 'nextcloud app-config eq? '()) eq? "admin"))))
(Field (@ (name "nextcloud-admin-password") (label ("Admin Password")) (type "password")
(value ,(alist-ref 'admin-password (alist-ref 'nextcloud app-config eq? '()) eq? ""))))))
'())
(Fieldset
(@ (title "Log Viewer"))
(Field (@ (name "log-viewer-subdomain") (label ("Subdomain"))
(value ,(alist-ref 'subdomain (alist-ref 'log-viewer app-config eq? '()) eq? "logs"))))
(Field (@ (name "log-viewer-user") (label ("Username"))
(value ,(alist-ref 'user (alist-ref 'log-viewer app-config eq? '()) eq? ""))))
(Field (@ (name "log-viewer-password") (label ("Password")) (type "password")
(value ,(alist-ref 'password (alist-ref 'log-viewer app-config eq? '()) eq? "")))))
(Form-Nav (@ (back-to "/config/wizard/apps")))))))))
(post "/config/wizard/apps2-submit"
(with-db/transaction
(lambda (db)
(update-user-app-config
db
(session-user-id)
`((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)))))
(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)))))))))
(redirect "/config/wizard/machine"))
(get/widgets
("/config/wizard/machine")
(let ((config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-user-id))))))
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Region"))
(Field (@ (element select) (name "region"))
(option (@ (value "")) "")
,@(map (lambda (r)
`(option (@ (value ,(alist-ref 'slug r))) ,(alist-ref 'name r)))
(get-digital-ocean-regions (alist-ref 'digitalocean-api-token config)))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2"))))))))))
(post "/config/wizard/machine-submit"
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
`((digitalocean-region . ,(alist-ref 'region (current-params)))))))
(redirect "/config/wizard/machine2"))
(get/widgets
("/config/wizard/machine2")
(let* ((config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-user-id)))))
(region (alist-ref 'digitalocean-region config))
(all-sizes (get-digital-ocean-sizes (alist-ref 'digitalocean-api-token config)))
(sizes (filter (lambda (s) (member region (alist-ref 'regions s))) all-sizes)))
`(App
(Configuration-Wizard
(@ (step "Machine"))
(form
(@ (action "/config/wizard/machine2-submit")
(method POST))
(VStack
(Fieldset
(@ (title "Size"))
(Field (@ (element select) (name "size") (input-style ((max-width "100%"))))
,@(map (lambda (s) `(option (@ (value ,(alist-ref 'slug s))
,@(if (equal? (alist-ref 'slug s) "s-2vcpu-2gb") `((selected "selected")) '()))
"$" ,(alist-ref 'price_monthly s)
" (CPU: ",(alist-ref 'vcpus s)
" Mem: " ,(/ (alist-ref 'memory s) 1024)
" Disk: " ,(alist-ref 'disk s)
") " ,(alist-ref 'description s)))
sizes)))
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine"))))))))))
(post "/config/wizard/machine2-submit"
(with-db/transaction
(lambda (db)
(update-user-service-config
db
(session-user-id)
`((digitalocean-size . ,(alist-ref 'size (current-params)))))))
(redirect "/config/wizard/review"))
(get/widgets
("/config/wizard/review")
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-user-id)))))
(app-config . ,(get-user-app-config db (session-user-id)))
(service-config . ,(get-user-service-config db (session-user-id)))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config))
(root-domain (alist-ref 'root-domain app-config))
(service-config (alist-ref 'service-config results)))
`(App
(Configuration-Wizard
(@ (step "Review"))
(h2 "Root Domain")
,root-domain
(h2 "Apps")
(ul ,@(map (lambda (app) `(li ,app " @ "
,(alist-ref 'subdomain (alist-ref app config))
"."
,root-domain))
selected-apps))
(h2 "Machine")
(ul (li "Region: " ,(alist-ref 'digitalocean-region service-config))
(li "Size: " ,(alist-ref 'digitalocean-size service-config)))
(form
(@ (action "/config/wizard/review-submit") (method POST))
(VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2")) (submit-button "Launch")))))))))
(post "/config/wizard/review-submit"
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-user-id)))))
(app-config . ,(get-user-app-config db (session-user-id)))
(service-config . ,(get-user-service-config db (session-user-id)))
(terraform-state . ,(get-user-terraform-state db (session-user-id)))))))
(selected-apps (cons 'log-viewer (alist-ref 'selected-apps results)))
(app-config (alist-ref 'app-config results))
(config (alist-ref 'config app-config))
(root-domain (alist-ref 'root-domain app-config))
(service-config (alist-ref 'service-config results))
(terraform-state (alist-ref 'terraform-state results))
(dir (deployment-directory (session-get "user-id"))))
(dir (deployment-directory (session-user-id))))
(setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
(with-output-to-file (string-append dir "/config/apps.config")
(lambda ()
@@ -859,7 +896,7 @@ h1, h2, h3, h4, h5, h6 {
("datacenter" . ,(alist-ref 'digitalocean-region service-config))
("flatcar_stable_version" . "4230.2.3")))
(display "ssh_keys=[\"") (display (with-input-from-file (string-append dir "/config/ssh-keys") read-string)) (print "\"]"))))
(let* ((user-id (session-get "user-id"))
(let* ((user-id (session-user-id))
(deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id))))
(dir (deployment-directory user-id)))
(thread-start!
@@ -900,22 +937,15 @@ h1, h2, h3, h4, h5, h6 {
(update-user-terraform-state db user-id
(with-input-from-file (string-append dir "/terraform.tfstate") read-string)
(with-input-from-file (string-append dir "/terraform.tfstate.backup") read-string))))))))))))
(schematra:redirect "/config/wizard/success"))
(redirect "/config/wizard/success"))
(define (progress-status->text status)
(case status
((queued) "queued")
((in-progress) "in progress")
((complete) "complete")
((failed) "failed")))
(get
(get/widgets
("/config/wizard/success")
(let* ((res (with-db/transaction
(lambda (db)
`((status . ,(get-most-recent-deployment-status db (session-get "user-id")))
(progress . ,(get-most-recent-deployment-progress db (session-get "user-id")))))))
(output (with-input-from-file (string-append (deployment-directory (session-get "user-id")) "/make-out") read-string))
`((status . ,(get-most-recent-deployment-status db (session-user-id)))
(progress . ,(get-most-recent-deployment-progress db (session-user-id)))))))
(output (with-input-from-file (string-append (deployment-directory (session-user-id)) "/make-out") read-string))
(progress (alist-ref 'progress res))
(status (alist-ref 'status res)))
`(VStack
@@ -932,7 +962,7 @@ h1, h2, h3, h4, h5, h6 {
(pre ,output)
)))
(get
(get/widgets
("/dashboard")
`(App
(Main-Container
@@ -945,7 +975,8 @@ h1, h2, h3, h4, h5, h6 {
" - ",(alist-ref 'status deployment)))
(with-db/transaction
(lambda (db)
(get-user-deployments db (session-get "user-id"))))))))))
(get-user-deployments db (session-user-id))))))))))
(schematra:schematra-install)
(schematra:schematra-start)
(schematra-install)
))

428
src/test.scm Normal file
View File

File diff suppressed because one or more lines are too long