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

Adding tests.

Browse Source
main
Thomas Hintz 1 week ago
parent 5ca856b1ff
commit e372f2157b
4 changed files with 3718 additions and 166 deletions
Show Stats Download Patch File Download Diff File

17
src/db.scm
Unescape Escape 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
View File

File diff suppressed because one or more lines are too long

327
src/nassella.scm
Unescape Escape 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,29 +266,43 @@ 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 test-user-id (make-parameter 7))
(define (session-user-id)
(or (session-get "user-id") (test-user-id)))
(define-syntax get
(define-syntax get/widgets
(syntax-rules ()
((_ (path) body ...)
(schematra:get (path)
(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! "user-id" (test-user-id))
(session-set! "username" "me")
body ...))))))))
@ -479,9 +498,87 @@ h1, h2, h3, h4, h5, h6 {
"Back")
(Button ,submit-button)))
(get
;; Parsing JSON arrays as lists instead of vectors
(define array-as-list-parser
(cons 'array (lambda (x) x)))
(json-parsers (cons array-as-list-parser (json-parsers)))
(define (get-digital-ocean-regions api-token)
(filter
(lambda (r)
(alist-ref 'available r))
(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 (deployment-directory user-id)
(string-append "deploy-" (number->string user-id)))
(define (setup-deploy-files dir state state-backup)
(when (directory-exists? dir)
(delete-directory dir #t))
(create-directory dir)
(process-wait (process-run (string-append "tar -xf nassella-latest.tar -C " dir)))
(create-directory (string-append dir "/config"))
(copy-file "../config/ssh-keys" (string-append dir "/config/ssh-keys")) ;; TODO remove
(with-output-to-file (string-append dir "/terraform.tfstate") (lambda () (write-string state)))
(with-output-to-file (string-append dir "/terraform.tfstate.backup") (lambda () (write-string state-backup))))
(define (parse-deployment-log log)
(define (search complete in-progress)
(cond ((irregex-search complete log)
'complete)
((irregex-search in-progress log)
'in-progress)
(else 'queued)))
`((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start"))
(custom-image . ,(search "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Modifying"))
(machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..."))
(machine-destroy . ,(search "droplet.machine: Destruction complete"
'(: "droplet.machine (deposed object " (* alphanum) "): Destroying...")))))
(define (write-config-entry name value)
(display name)
(display "=\"")
(display value)
(print "\""))
(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-get "user-id"))))))
(let ((config (with-db/transaction (lambda (db) (get-user-service-config db (session-user-id))))))
`(App
(Configuration-Wizard
(@ (step "Services"))
@ -504,22 +601,22 @@ h1, h2, h3, h4, h5, h6 {
(Field (@ (name "backblaze-bucket-url") (label ("Bucket URL")) (value ,(alist-ref 'backblaze-bucket-url config)))))
(Form-Nav)))))))
(schematra:post ("/config/wizard/services-submit")
(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
(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
@ -541,7 +638,7 @@ h1, h2, h3, h4, h5, h6 {
(p "Your Backblaze account was successfully connected!"))
(Form-Nav (@ (back-to "/config/wizard/services"))))))))
(get
(get/widgets
("/config/wizard/apps")
(let ((results
(with-db/transaction
@ -549,8 +646,8 @@ h1, h2, h3, h4, h5, h6 {
`((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"))))))))
(get-user-selected-apps db (session-user-id)))))
(app-config . ,(get-user-app-config db (session-user-id))))))))
`(App
(Configuration-Wizard
(@ (step "Apps"))
@ -568,18 +665,22 @@ h1, h2, h3, h4, h5, h6 {
(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")
(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
(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
@ -587,10 +688,10 @@ h1, h2, h3, h4, h5, h6 {
`((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")))))))
(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 'app-config results)))
(app-config (alist-ref 'config (alist-ref 'app-config results))))
`(App
(Configuration-Wizard
(@ (step "Apps"))
@ -622,58 +723,26 @@ h1, h2, h3, h4, h5, h6 {
(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")
(post "/config/wizard/apps2-submit"
(with-db/transaction
(lambda (db)
(update-user-app-config
db
(session-get "user-id")
`((wg-easy . ((subdomain . ,(alist-ref 'wg-easy-subdomain (schematra:current-params)))))
(nextcloud . ((subdomain . ,(alist-ref 'nextcloud-subdomain (schematra:current-params)))
(admin-user . ,(alist-ref 'nextcloud-admin-user (schematra:current-params)))
(admin-password . ,(alist-ref 'nextcloud-admin-password (schematra:current-params)))))
(log-viewer . ((subdomain . ,(alist-ref 'log-viewer-subdomain (schematra:current-params)))
(user . ,(alist-ref 'log-viewer-user (schematra:current-params)))
(password . ,(alist-ref 'log-viewer-password (schematra:current-params)))))))))
(schematra:redirect "/config/wizard/machine"))
;; Parsing JSON arrays as lists instead of vectors
(define array-as-list-parser
(cons 'array (lambda (x) x)))
(json-parsers (cons array-as-list-parser (json-parsers)))
(define (get-digital-ocean-regions api-token)
(filter
(lambda (r)
(alist-ref 'available r))
(alist-ref
'regions
(let* ((uri (uri-reference "https://api.digitalocean.com/v2/regions"))
(req (make-request method: 'GET
uri: uri
headers: (headers `((content-type application/json)
(Authorization ,(conc "Bearer " api-token)))))))
(with-input-from-request req #f read-json)))))
(define (get-digital-ocean-sizes api-token)
(filter
(lambda (r)
(alist-ref 'available r))
(alist-ref
'sizes
(let* ((uri (uri-reference "https://api.digitalocean.com/v2/sizes?per_page=200"))
(req (make-request method: 'GET
uri: uri
headers: (headers `((content-type application/json)
(Authorization ,(conc "Bearer " api-token)))))))
(with-input-from-request req #f read-json)))))
(get
(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-get "user-id"))))))
(get-user-service-config db (session-user-id))))))
`(App
(Configuration-Wizard
(@ (step "Machine"))
@ -690,20 +759,20 @@ h1, h2, h3, h4, h5, h6 {
(get-digital-ocean-regions (alist-ref 'digitalocean-api-token config)))))
(Form-Nav (@ (back-to ,(conc "/config/wizard/apps2"))))))))))
(schematra:post ("/config/wizard/machine-submit")
(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"))
(session-user-id)
`((digitalocean-region . ,(alist-ref 'region (current-params)))))))
(redirect "/config/wizard/machine2"))
(get
(get/widgets
("/config/wizard/machine2")
(let* ((config (with-db/transaction
(lambda (db)
(get-user-service-config db (session-get "user-id")))))
(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)))
@ -727,16 +796,16 @@ h1, h2, h3, h4, h5, h6 {
sizes)))
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine"))))))))))
(schematra:post ("/config/wizard/machine2-submit")
(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"))
(session-user-id)
`((digitalocean-size . ,(alist-ref 'size (current-params)))))))
(redirect "/config/wizard/review"))
(get
(get/widgets
("/config/wizard/review")
(let* ((results
(with-db/transaction
@ -744,9 +813,9 @@ h1, h2, h3, h4, h5, h6 {
`((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")))))))
(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))
@ -771,56 +840,24 @@ h1, h2, h3, h4, h5, h6 {
(VStack
(Form-Nav (@ (back-to ,(conc "/config/wizard/machine2")) (submit-button "Launch")))))))))
(define (deployment-directory user-id)
(string-append "deploy-" (number->string user-id)))
(define (setup-deploy-files dir state state-backup)
(when (directory-exists? dir)
(delete-directory dir #t))
(create-directory dir)
(process-wait (process-run (string-append "tar -xf nassella-latest.tar -C " dir)))
(create-directory (string-append dir "/config"))
(copy-file "../config/ssh-keys" (string-append dir "/config/ssh-keys")) ;; TODO remove
(with-output-to-file (string-append dir "/terraform.tfstate") (lambda () (write-string state)))
(with-output-to-file (string-append dir "/terraform.tfstate.backup") (lambda () (write-string state-backup))))
(define (parse-deployment-log log)
(define (search complete in-progress)
(cond ((irregex-search complete log)
'complete)
((irregex-search in-progress log)
'in-progress)
(else 'queued)))
`((generate-configs . ,(search "terraform apply" "NASSELLA_CONFIG: start"))
(custom-image . ,(search "custom_image.flatcar: Modifications complete" "custom_image.flatcar: Modifying"))
(machine-create . ,(search "droplet.machine: Creation complete" "droplet.machine: Creating..."))
(machine-destroy . ,(search "droplet.machine: Destruction complete"
'(: "droplet.machine (deposed object " (* alphanum) "): Destroying...")))))
(define (write-config-entry name value)
(display name)
(display "=\"")
(display value)
(print "\""))
(schematra:post ("/config/wizard/review-submit")
(post "/config/wizard/review-submit"
(let* ((results
(with-db/transaction
(lambda (db)
`((selected-apps . ,(map
car
(filter cdr
(get-user-selected-apps db (session-get "user-id")))))
(app-config . ,(get-user-app-config db (session-get "user-id")))
(service-config . ,(get-user-service-config db (session-get "user-id")))
(terraform-state . ,(get-user-terraform-state db (session-get "user-id")))))))
(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
View File

File diff suppressed because one or more lines are too long
Write Preview
Loading…
Cancel
Save