769 lines
35 KiB
Scheme
769 lines
35 KiB
Scheme
;; 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/>.
|
|
|
|
(module nassella-db
|
|
( ;; parameters
|
|
connection-spec
|
|
|
|
;;functions
|
|
with-db with-db/transaction
|
|
db-init db-clean
|
|
|
|
create-user delete-user
|
|
get-user-id-by-username
|
|
create-instance destroy-instance get-user-instances
|
|
get-instance-ssh-pub-key get-instance-ssh-priv-key
|
|
update-instance-ssh-pub-key
|
|
get-instance-restic-password
|
|
update-user-service-config get-user-service-config
|
|
update-user-selected-apps get-user-selected-apps
|
|
update-user-app-config get-user-app-config
|
|
update-root-domain
|
|
create-deployment
|
|
update-deployment-status get-deployment-status
|
|
get-most-recent-deployment-status
|
|
update-deployment-in-progress
|
|
update-deployment-progress get-deployment-progress
|
|
get-most-recent-deployment-progress
|
|
update-user-terraform-state get-user-terraform-state
|
|
get-dashboard
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken blob)
|
|
(chicken file)
|
|
(chicken string)
|
|
(chicken port)
|
|
(chicken io)
|
|
(chicken sort)
|
|
postgresql
|
|
sql-null
|
|
srfi-1
|
|
srfi-13
|
|
(openssl cipher)
|
|
(openssl random)
|
|
crypto-tools
|
|
spiffy)
|
|
|
|
(define connection-spec
|
|
(make-parameter
|
|
(cond-expand
|
|
(dev
|
|
'((dbname . "nassella") (user . "nassella") (password . "password")
|
|
(host . "127.0.0.1")))
|
|
(else
|
|
(let ((pw (string-trim-right (with-input-from-file "/run/secrets/nassella_postgres_password" read-string)))) ;; remove newline
|
|
`((dbname . "nassella") (user . "nassella") (password . ,pw)
|
|
(host . "nassella_db")))))))
|
|
|
|
(define db-connection (make-parameter #f))
|
|
|
|
(define (with-db proc)
|
|
(if (db-connection)
|
|
(begin (db-connection)
|
|
(proc (db-connection)))
|
|
(let ((conn #f))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(set! conn (connect (connection-spec))))
|
|
(lambda () (proc conn))
|
|
(lambda ()
|
|
(when (and (connection? conn) (connected? conn))
|
|
(disconnect conn)))))))
|
|
|
|
(define (with-db/transaction proc)
|
|
(with-db
|
|
(lambda (conn)
|
|
(with-transaction conn
|
|
(lambda () (proc conn))))))
|
|
|
|
;; (with-db (lambda (db) (row-values (query db "select * from users;"))))
|
|
|
|
(define aes-256-gcm (cipher-by-name "aes-256-gcm"))
|
|
(define tag-length 16)
|
|
|
|
(define (generate-param accessor)
|
|
(random-bytes (accessor aes-256-gcm)))
|
|
|
|
(define (generate-key) (generate-param cipher-key-length))
|
|
(define (generate-iv) (generate-param cipher-iv-length))
|
|
|
|
(define (encrypt message key iv #!optional auth-data)
|
|
(string-encrypt-and-digest aes-256-gcm message key iv
|
|
tag-length: tag-length
|
|
auth-data: auth-data))
|
|
|
|
(define (decrypt message tag key iv #!optional auth-data)
|
|
(string-decrypt-and-verify aes-256-gcm message tag key iv
|
|
auth-data: auth-data))
|
|
|
|
(define *root-key-file* "root-key")
|
|
(define (generate-root-key) (generate-key))
|
|
(define (save-root-key)
|
|
(with-output-to-file *root-key-file* (lambda () (write (blob->hexstring/uppercase (generate-root-key))))))
|
|
(define (load-root-key)
|
|
(hexstring->blob (with-input-from-file *root-key-file* read)))
|
|
|
|
(define *root-key-iv* (hexstring->blob "1EBBCF6B50C68593C559EF93"))
|
|
(define (ensure-root-key)
|
|
(when (not (file-exists? *root-key-file*))
|
|
(save-root-key))
|
|
(load-root-key))
|
|
(define *root-key-key* (ensure-root-key))
|
|
|
|
(define (get-user-key-and-iv conn user-id)
|
|
(row-alist (query conn "select username, key_key, key_iv from users where user_id=$1;" user-id)))
|
|
|
|
(define (get-decrypted-user-key-and-iv conn user-id)
|
|
(let* ((auth-user-id-and-user-key-and-iv (get-user-key-and-iv conn user-id))
|
|
(raw-user-key-and-tag (alist-ref 'key_key auth-user-id-and-user-key-and-iv))
|
|
(raw-user-key (hexstring->blob (string-drop-right raw-user-key-and-tag (* tag-length 2))))
|
|
(raw-user-tag (hexstring->blob (string-take-right raw-user-key-and-tag (* tag-length 2))))
|
|
(user-key (decrypt (blob->string raw-user-key) (blob->string raw-user-tag) *root-key-key* *root-key-iv*
|
|
(string->blob (alist-ref 'username auth-user-id-and-user-key-and-iv))))
|
|
(user-iv (alist-ref 'key_iv auth-user-id-and-user-key-and-iv))
|
|
(auth-user-id (alist-ref 'username auth-user-id-and-user-key-and-iv)))
|
|
(values (hexstring->blob user-key) (hexstring->blob user-iv) auth-user-id)))
|
|
|
|
(define (user-encrypt message user-key user-iv user-id)
|
|
(encrypt message user-key user-iv (string->blob (->string user-id))))
|
|
|
|
(define (user-encrypt-for-db message user-key user-iv user-id)
|
|
(receive (message tag)
|
|
(user-encrypt message user-key user-iv user-id)
|
|
(string-append (blob->hexstring/uppercase (string->blob message))
|
|
(blob->hexstring/uppercase (string->blob tag)))))
|
|
|
|
(define (user-decrypt message tag user-key user-iv user-id)
|
|
(decrypt message tag user-key user-iv (string->blob (->string user-id))))
|
|
|
|
(define (user-decrypt-from-db message-and-tag user-key user-iv user-id)
|
|
(let ((raw-message (hexstring->blob (string-drop-right message-and-tag (* tag-length 2))))
|
|
(raw-tag (hexstring->blob (string-take-right message-and-tag (* tag-length 2)))))
|
|
(user-decrypt (blob->string raw-message) (blob->string raw-tag) user-key user-iv user-id)))
|
|
|
|
(define (create-user conn email username)
|
|
(let ((user-key (blob->hexstring/uppercase (generate-key)))
|
|
(user-iv (blob->hexstring/uppercase (generate-iv))))
|
|
(receive (enc-user-key tag)
|
|
(encrypt user-key *root-key-key* *root-key-iv* (string->blob username))
|
|
(let ((user-id
|
|
(value-at
|
|
(query conn
|
|
"insert into users(email, username, key_key, key_iv) values ($1, $2, $3, $4)
|
|
returning users.user_id;"
|
|
email username
|
|
(string-append (blob->hexstring/uppercase (string->blob enc-user-key))
|
|
(blob->hexstring/uppercase (string->blob tag)))
|
|
user-iv))))
|
|
user-id))))
|
|
|
|
(define (delete-user conn user-id)
|
|
(query conn "delete from users where user_id=$1;" user-id))
|
|
|
|
(define (get-user-id-by-username conn username)
|
|
(let ((res (query conn "select user_id from users where username=$1;" username)))
|
|
(if (> (row-count res) 0)
|
|
(value-at res)
|
|
#f)))
|
|
|
|
;; We also encrypt the ssh pub key not to hide it but to make it
|
|
;; more difficult for someone to tamper with it which could allow
|
|
;; an attacker to poison an instance with an ssh key that they have
|
|
;; access to
|
|
(define (create-instance conn user-id ssh-key-priv ssh-key-pub restic-password)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(let ((instance-id
|
|
(value-at
|
|
(query conn
|
|
"insert into instances(user_id, ssh_key_priv_enc, ssh_key_pub_enc, restic_password_enc) values ($1, $2, $3, $4) returning instances.instance_id;"
|
|
user-id
|
|
(user-encrypt-for-db ssh-key-priv user-key user-iv user-id)
|
|
(user-encrypt-for-db ssh-key-pub user-key user-iv user-id)
|
|
(user-encrypt-for-db restic-password user-key user-iv user-id)))))
|
|
(query conn "insert into user_service_configs(user_id, instance_id) values ($1, $2);" user-id instance-id)
|
|
(query conn "insert into user_selected_apps(user_id, instance_id) values ($1, $2);" user-id instance-id)
|
|
(query conn "insert into user_app_configs(user_id, instance_id) values ($1, $2);" user-id instance-id)
|
|
(query conn "insert into user_terraform_state(user_id, instance_id) values ($1, $2);" user-id instance-id)
|
|
instance-id)))
|
|
|
|
(define (destroy-instance conn instance-id)
|
|
(query conn "delete from instances where instance_id=$1;" instance-id))
|
|
|
|
(define (get-instance-ssh-priv-key conn user-id instance-id)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(user-decrypt-from-db
|
|
(value-at (query conn "select ssh_key_priv_enc from instances where user_id=$1 and instance_id=$2;"
|
|
user-id instance-id))
|
|
user-key user-iv user-id)))
|
|
|
|
(define (get-instance-ssh-pub-key conn user-id instance-id)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(user-decrypt-from-db
|
|
(value-at (query conn "select ssh_key_pub_enc from instances where user_id=$1 and instance_id=$2;"
|
|
user-id instance-id))
|
|
user-key user-iv user-id)))
|
|
|
|
(define (update-instance-ssh-pub-key conn user-id instance-id ssh-pub-key)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(query conn "update instances set ssh_key_pub_enc=$3 where user_id=$1 and instance_id=$2;"
|
|
user-id instance-id
|
|
(user-encrypt-for-db ssh-pub-key user-key user-iv user-id))))
|
|
|
|
(define (get-instance-restic-password conn user-id instance-id)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(user-decrypt-from-db
|
|
(value-at (query conn "select restic_password_enc from instances where user_id=$1 and instance_id=$2;"
|
|
user-id instance-id))
|
|
user-key user-iv user-id)))
|
|
|
|
(define (get-user-instances conn user-id)
|
|
(column-values (query conn "select instance_id from instances where user_id=$1;" user-id)))
|
|
|
|
(define *user-service-configs-column-map*
|
|
'((cloudflare-api-token . ("cloudflare_api_token_enc" #t))
|
|
(cloudflare-account-id . ("cloudflare_account_id_enc" #t))
|
|
(cloudflare-zone-id . ("cloudflare_zone_id_enc" #t))
|
|
(digitalocean-api-token . ("digitalocean_api_token_enc" #t))
|
|
(digitalocean-region . ("digitalocean_region" #f))
|
|
(digitalocean-size . ("digitalocean_size" #f))
|
|
(digitalocean-volume-size . ("digitalocean_volume_size" #f))
|
|
(backblaze-application-key . ("backblaze_application_key_enc" #t))
|
|
(backblaze-key-id . ("backblaze_key_id_enc" #t))
|
|
(backblaze-bucket-url . ("backblaze_bucket_url_enc" #t))))
|
|
|
|
(define *user-service-configs-reverse-column-map*
|
|
(map (lambda (config)
|
|
`(,(string->symbol (cadr config)) . (,(car config) ,(caddr config))))
|
|
*user-service-configs-column-map*))
|
|
|
|
(define (update-user-service-config conn user-id instance-id update-alist)
|
|
(let ((valid-keys (map car *user-service-configs-column-map*)))
|
|
(for-each (lambda (update)
|
|
(if (not (memq (car update) valid-keys))
|
|
(error (string-append "Not a valid update key: " (->string (car update))))))
|
|
update-alist))
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(query* conn
|
|
(string-append
|
|
"update user_service_configs set "
|
|
(string-intersperse
|
|
(map-in-order (lambda (update i)
|
|
(conc (car (alist-ref (car update) *user-service-configs-column-map*))
|
|
"=$" i))
|
|
update-alist
|
|
(iota (length update-alist) 3))
|
|
", ")
|
|
" where user_id=$1 and instance_id=$2;")
|
|
`(,user-id
|
|
,instance-id
|
|
,@(map-in-order (lambda (update)
|
|
(if (cadr (alist-ref (car update) *user-service-configs-column-map*))
|
|
(user-encrypt-for-db (cdr update) user-key user-iv user-id)
|
|
(cdr update)))
|
|
update-alist)))))
|
|
|
|
(define (get-user-service-config conn user-id instance-id)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(let ((res (row-alist
|
|
(query conn
|
|
(string-append
|
|
"select "
|
|
(string-intersperse
|
|
(map-in-order (lambda (update)
|
|
(car (alist-ref (car update) *user-service-configs-column-map*)))
|
|
*user-service-configs-column-map*)
|
|
", ")
|
|
" from user_service_configs where user_id=$1 and instance_id=$2;")
|
|
user-id instance-id))))
|
|
(map (lambda (item)
|
|
(let* ((key (car item))
|
|
(value (cdr item))
|
|
(config (alist-ref key *user-service-configs-reverse-column-map*)))
|
|
`(,(car config) . ,(if (sql-null? value)
|
|
""
|
|
(if (cadr config)
|
|
(user-decrypt-from-db value user-key user-iv user-id)
|
|
value)))))
|
|
res))))
|
|
|
|
(define *user-selected-apps-column-map*
|
|
'((wg-easy . "wg_easy_version")
|
|
(nextcloud . "nextcloud_version")
|
|
(ghost . "ghost_version")
|
|
(nassella . "nassella_version")
|
|
(log-viewer . "log_viewer_version")
|
|
(instance-control . "instance_control_version")
|
|
))
|
|
|
|
(define *user-selected-apps-reverse-column-map*
|
|
(map (lambda (config)
|
|
`(,(string->symbol (cdr config)) . ,(car config)))
|
|
*user-selected-apps-column-map*))
|
|
|
|
(define (update-user-selected-apps conn user-id instance-id app-alist)
|
|
(query conn "delete from user_selected_apps where instance_id=$1 and user_id=$2" instance-id user-id)
|
|
(for-each (lambda (app-version)
|
|
(query conn "insert into user_selected_apps (app_id, installed_version, user_id, instance_id)
|
|
select apps.id, $2, $3, $4 from apps where apps.app_name=$1;"
|
|
(symbol->string (car app-version)) (cdr app-version) user-id instance-id))
|
|
app-alist))
|
|
|
|
(define (get-user-selected-apps conn user-id instance-id)
|
|
(row-map*
|
|
(lambda (name version)
|
|
(cons (string->symbol name) version))
|
|
(query conn "select apps.app_name, usa.installed_version from user_selected_apps usa
|
|
join apps on apps.id = usa.app_id
|
|
where usa.user_id=$1 and usa.instance_id=$2;"
|
|
user-id instance-id)))
|
|
|
|
(define (update-user-app-config conn user-id instance-id config)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(query conn
|
|
"update user_app_configs set config_enc=$1 where user_id=$2 and instance_id=$3;"
|
|
(user-encrypt-for-db
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write config)))
|
|
user-key user-iv user-id)
|
|
user-id instance-id)))
|
|
|
|
(define (update-root-domain conn user-id instance-id root-domain)
|
|
(query conn
|
|
"update user_app_configs set root_domain=$1 where user_id=$2 and instance_id=$3;"
|
|
root-domain
|
|
user-id
|
|
instance-id))
|
|
|
|
(define (get-user-app-config conn user-id instance-id)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(let ((res (row-alist (query conn
|
|
"select root_domain, config_enc from user_app_configs where user_id=$1 and instance_id=$2;"
|
|
user-id instance-id))))
|
|
`((root-domain . ,(if (sql-null? (alist-ref 'root_domain res))
|
|
#f
|
|
(alist-ref 'root_domain res)))
|
|
(config . ,(if (sql-null? (alist-ref 'config_enc res))
|
|
'()
|
|
(with-input-from-string
|
|
(user-decrypt-from-db (alist-ref 'config_enc res) user-key user-iv user-id)
|
|
read)))))))
|
|
|
|
(define *deployment-status*
|
|
'((queued . "queued")
|
|
(in-progress . "in-progress")
|
|
(complete . "complete")
|
|
(failed . "failed")))
|
|
(define (create-deployment conn user-id instance-id)
|
|
(value-at
|
|
(query conn
|
|
"insert into deployments(user_id, instance_id, started) values($1, $2, now()) returning deployments.id;"
|
|
user-id instance-id)))
|
|
(define (update-deployment-in-progress conn deployment-id pid)
|
|
(query conn
|
|
"update deployments set status=$1, pid=$2 where id=$3;"
|
|
(alist-ref 'in-progress *deployment-status*) pid deployment-id))
|
|
|
|
(define (update-deployment-status conn user-id deployment-id status log)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(query conn "update deployments set status=$1, log_enc=$2, finished=now() where id=$3;"
|
|
(alist-ref status *deployment-status*)
|
|
(user-encrypt-for-db log user-key user-iv user-id)
|
|
deployment-id)))
|
|
|
|
(define (get-deployment-status conn deployment-id)
|
|
(value-at (query conn "select status from deployments where id=$1;" deployment-id)))
|
|
|
|
(define (get-most-recent-deployment-status conn user-id instance-id)
|
|
(let ((res (query conn "select status from deployments where user_id=$1 and instance_id=$2 order by id DESC limit 1;" user-id instance-id)))
|
|
(if (> (row-count res) 0)
|
|
(value-at res)
|
|
#f)))
|
|
|
|
(define *deployments-column-map*
|
|
'((generate-configs . "generate_configs")
|
|
(custom-image . "terraform_custom_image")
|
|
(machine-create . "terraform_machine_create")
|
|
(machine-destroy . "terraform_machine_destroy")
|
|
(ip-create . "terraform_ip_create")
|
|
(ip-destroy . "terraform_ip_destroy")
|
|
(volume-create . "terraform_volume_create")
|
|
(volume-destroy . "terraform_volume_destroy")
|
|
(instance-backup . "instance_backup")
|
|
(status . "status")
|
|
(id . "id")
|
|
(instance-id . "instance_id")))
|
|
|
|
(define *deployments-reverse-column-map*
|
|
(map (lambda (config)
|
|
`(,(string->symbol (cdr config)) . ,(car config)))
|
|
*deployments-column-map*))
|
|
|
|
(define (update-deployment-progress conn deployment-id progress-alist)
|
|
(let ((valid-keys (map car *deployments-column-map*)))
|
|
(for-each (lambda (progress)
|
|
(if (not (memq (car progress) valid-keys))
|
|
(error (string-append "Not a valid progress key: " (->string (car progress))))))
|
|
progress-alist))
|
|
(query* conn
|
|
(string-append
|
|
"update deployments set "
|
|
(string-intersperse
|
|
(map-in-order (lambda (progress i)
|
|
(conc (alist-ref (car progress) *deployments-column-map*)
|
|
"=$" i))
|
|
progress-alist
|
|
(iota (length progress-alist) 2))
|
|
", ")
|
|
" where id=$1;")
|
|
(cons deployment-id
|
|
(map-in-order (lambda (progress) (alist-ref (cdr progress) *deployment-status*)) progress-alist))))
|
|
|
|
(define (get-deployment-progress conn deployment-id)
|
|
(let ((res (row-alist
|
|
(query conn
|
|
(string-append
|
|
"select "
|
|
(string-intersperse
|
|
(map-in-order cdr *deployments-column-map*)
|
|
", ")
|
|
" from deployments where id=$1;")
|
|
deployment-id))))
|
|
(map (lambda (item)
|
|
(let* ((key (car item))
|
|
(value (cdr item))
|
|
(config (alist-ref key *deployments-reverse-column-map*)))
|
|
`(,config . ,(if (sql-null? value)
|
|
#f
|
|
(string->symbol value)))))
|
|
res)))
|
|
|
|
(define (get-most-recent-deployment-progress conn user-id instance-id)
|
|
(let ((res (row-alist
|
|
(query conn
|
|
(string-append
|
|
"select "
|
|
(string-intersperse
|
|
(map-in-order cdr *deployments-column-map*)
|
|
", ")
|
|
" from deployments where user_id=$1 and instance_id=$2 order by id DESC limit 1;")
|
|
user-id instance-id))))
|
|
(map (lambda (item)
|
|
(let* ((key (car item))
|
|
(value (cdr item))
|
|
(config (alist-ref key *deployments-reverse-column-map*)))
|
|
`(,config . ,(if (sql-null? value)
|
|
#f
|
|
(if (string? value)
|
|
(string->symbol value)
|
|
value)))))
|
|
res)))
|
|
|
|
(define (get-dashboard conn user-id)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(let ((res
|
|
(query conn
|
|
(string-append
|
|
"select "
|
|
(string-intersperse
|
|
(map-in-order (lambda (d) (string-append "d." (cdr d))) *deployments-column-map*)
|
|
", ")
|
|
", uac.root_domain, uac.config_enc, uac.instance_id "
|
|
"from instances as i "
|
|
"join (select instance_id, max(id) as id from deployments group by instance_id) d2 "
|
|
"on d2.instance_id = i.instance_id "
|
|
"join deployments d on d.id = d2.id "
|
|
"join user_app_configs uac on uac.user_id = d.user_id and uac.instance_id = d.instance_id "
|
|
"where i.user_id=$1;")
|
|
user-id))
|
|
(instance-apps
|
|
(row-fold*
|
|
(lambda (app-name installed-version instance-id lookup)
|
|
(alist-update instance-id
|
|
`(((app-name . ,(string->symbol app-name))
|
|
(installed-version . ,installed-version))
|
|
,@(alist-ref instance-id lookup eqv? '()))
|
|
lookup))
|
|
'()
|
|
(query
|
|
conn
|
|
"select apps.app_name, usa.installed_version, usa.instance_id from user_selected_apps usa
|
|
join apps on apps.id=usa.app_id
|
|
where user_id=$1;"
|
|
user-id))))
|
|
(map
|
|
(lambda (instance)
|
|
(cons `(apps . ,(alist-ref (alist-ref 'instance-id instance) instance-apps))
|
|
instance))
|
|
(map
|
|
(lambda (row-num)
|
|
(map (lambda (item)
|
|
(let* ((key (car item))
|
|
(value (cdr item))
|
|
(config (alist-ref key `((root_domain . root-domain)
|
|
(config_enc . config)
|
|
(instance_id . instance-id)
|
|
;; (wg_easy_version . wg-easy)
|
|
;; (nextcloud_version . nextcloud)
|
|
;; (ghost_version . ghost)
|
|
;; (nassella_version . nassella)
|
|
;; (log_viewer_version . log-viewer)
|
|
;; (instance_control_version . instance-control)
|
|
,@*deployments-reverse-column-map*))))
|
|
`(,config . ,(if (sql-null? value)
|
|
#f
|
|
(if (and (string? value) (member config *deployments-column-map*))
|
|
(string->symbol value)
|
|
(if (eq? key 'config_enc)
|
|
(with-input-from-string
|
|
(user-decrypt-from-db value user-key user-iv user-id)
|
|
read)
|
|
value))))))
|
|
(row-alist res row-num)))
|
|
(iota (row-count res)))))))
|
|
|
|
(define (update-user-terraform-state conn user-id instance-id state backup)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(query conn
|
|
"update user_terraform_state set state_enc=$1, state_backup_enc=$2 where user_id=$3 and instance_id=$4;"
|
|
(user-encrypt-for-db state user-key user-iv user-id)
|
|
(user-encrypt-for-db backup user-key user-iv user-id)
|
|
user-id
|
|
instance-id)))
|
|
|
|
(define (get-user-terraform-state conn user-id instance-id)
|
|
(receive (user-key user-iv auth-user-id)
|
|
(get-decrypted-user-key-and-iv conn user-id)
|
|
(let ((res (row-alist (query conn
|
|
"select state_enc, state_backup_enc from user_terraform_state where user_id=$1 and instance_id=$2;"
|
|
user-id instance-id))))
|
|
`((state . ,(if (or (sql-null? (alist-ref 'config_enc res))
|
|
(sql-null? (alist-ref 'state_enc res)))
|
|
""
|
|
(user-decrypt-from-db (alist-ref 'state_enc res) user-key user-iv user-id)))
|
|
(backup . ,(if (or (sql-null? (alist-ref 'config_enc res))
|
|
(sql-null? (alist-ref 'state_backup_enc res)))
|
|
""
|
|
(user-decrypt-from-db (alist-ref 'state_backup_enc res) user-key user-iv user-id)))))))
|
|
|
|
;; (define (instance-config-for-export conn user-id instance-id)
|
|
;; (receive (user-key user-iv auth-user-id)
|
|
;; (get-decrypted-user-key-and-iv conn user-id)
|
|
;; (let ((res (row-alist
|
|
;; (query conn
|
|
;; "
|
|
;; select
|
|
;; instances.ssh_key_priv_enc,
|
|
;; instances.ssh_key_pub_enc,
|
|
;; instances.restic_password_enc,
|
|
;; user_service_configs.cloudflare_api_token_enc,
|
|
;; user_service_configs.cloudflare_account_id_enc,
|
|
;; user_service_configs.cloudflare_zone_id_enc,
|
|
;; user_service_configs.digitalocean_api_token_enc,
|
|
;; user_service_configs.digitalocean_region,
|
|
;; user_service_configs.digitalocean_size,
|
|
;; user_service_configs.backblaze_application_key_enc,
|
|
;; user_service_configs.backblaze_key_id_enc,
|
|
;; user_service_configs.backblaze_bucket_url_enc,
|
|
;; user_selected_apps.wg_easy_version,
|
|
;; user_selected_apps.nextcloud_version,
|
|
;; user_selected_apps.nassella_version,
|
|
;; user_selected_apps.log_viewer_version,
|
|
;; user_selected_apps.ghost_version,
|
|
;; user_app_configs.root_domain,
|
|
;; user_apps_configs.config_end
|
|
;; from instances
|
|
;; join user_service_configs on user_service_configs.user_id = instances.user_id and user_service_configs.instance_id = instances.instance_id
|
|
;; join user_selected_apps on user_selected_apps.user_id = instances.user_id and user_selected_apps.instance_id = instances.instance_id
|
|
;; join user_app_configs on user_apps_configs.user_id = instances.user_id and user_app_configs.instance_id = instances.instance_id
|
|
;; where instances.user_id=$1 and instance.instance_id=$2;"
|
|
;; user-id instance-id))))
|
|
;; `((state . ,(if (or (sql-null? (alist-ref 'config_enc res))
|
|
;; (sql-null? (alist-ref 'state_enc res)))
|
|
;; ""
|
|
;; (user-decrypt-from-db (alist-ref 'state_enc res) user-key user-iv user-id)))
|
|
;; (backup . ,(if (or (sql-null? (alist-ref 'config_enc res))
|
|
;; (sql-null? (alist-ref 'state_backup_enc res)))
|
|
;; ""
|
|
;; (user-decrypt-from-db (alist-ref 'state_backup_enc res) user-key user-iv user-id)))))))
|
|
|
|
;; TODO can/should this be removed? I don't remember why I put this here
|
|
(debug-log (current-error-port))
|
|
|
|
;; An a-list of migrations. The car is the migration_id in the migrations
|
|
;; table and the cdr is name of the file containing sql for the migration.
|
|
;; The file name is appended with "-up.sql" and "-down.sql", depending on if
|
|
;; an up or down migration should be run.
|
|
;;
|
|
;; After a migration has been run, it's migration id (the car in the alist) is
|
|
;; added to the database so the migration does not get re-run.
|
|
;;
|
|
;; To create a new migration:
|
|
;; add it to the end of this list with the car being one number higher than
|
|
;; the previous migration and the cdr being the filename containing sql statements
|
|
;; to run (not including a prefix of the ID or the suffic -up.sql or -down.sql).
|
|
;; add two sql files in the "migrations" folder, one ending in -up.sql and one ending
|
|
;; in -down.sql.
|
|
;; So to for a migration called "my-migration" with id "13 create two files in the
|
|
;; migrations directory: 13-my-migration-up.sql and 13-my-migration-down.sql
|
|
;;
|
|
;; The "up" file is called to run the migration and the "down" file is called to
|
|
;; "undo" the migration.
|
|
(define *migrations*
|
|
'((0 . "adding-instance-control-app")
|
|
(1 . "adding-service-config-digitalocean-volume-size")
|
|
(2 . "adding-deployments-instance-backup")
|
|
(3 . "normalizing-apps")
|
|
(4 . "fixing-app-normalization")
|
|
(5 . "adding-wordpress-app")
|
|
(6 . "adding-lldap-app")
|
|
(7 . "adding-authelia-app")))
|
|
|
|
(define (run-pending-migrations conn)
|
|
(let* ((migration-ids (sort (map car *migrations*) <))
|
|
(migration-rows (query conn "select migration_id from migrations;"))
|
|
(applied-migration-ids (if (> (row-count migration-rows) 0)
|
|
(column-values migration-rows)
|
|
'())))
|
|
(for-each
|
|
(lambda (id)
|
|
(when (not (member id applied-migration-ids))
|
|
(log-to (debug-log) "running migration: ~A" id)
|
|
(for-each
|
|
(lambda (statement)
|
|
(query conn (conc statement ";")))
|
|
(string-split (with-input-from-file
|
|
(conc "migrations/" id "-" (alist-ref id *migrations*) "-up.sql")
|
|
read-string)
|
|
";"))
|
|
(query conn "insert into migrations(migration_id) values ($1);" id)))
|
|
migration-ids)))
|
|
|
|
(define (db-init)
|
|
(with-db/transaction
|
|
(lambda (db)
|
|
(if (value-at (query db "SELECT EXISTS (SELECT FROM pg_tables WHERE schemaname = 'public' AND tablename = 'users');"))
|
|
(begin
|
|
(log-to (debug-log) "database already initialized")
|
|
#t)
|
|
(begin
|
|
(log-to (debug-log) "tables not found in db. Creating...")
|
|
(for-each
|
|
(lambda (statement)
|
|
(query db (conc statement ";")))
|
|
(string-split (with-input-from-file "db-init.sql" read-string) ";"))
|
|
(log-to (debug-log) "table creation finished")
|
|
(log-to (debug-log) "creating test user")
|
|
(create-user db "me@example.com" "username")
|
|
(log-to (debug-log) "test user creation finished")))
|
|
;; originally there was no migrations table, so first add it if it doesn't exist
|
|
(if (value-at (query db "SELECT EXISTS (SELECT FROM pg_tables WHERE schemaname = 'public' AND tablename = 'migrations');"))
|
|
#t
|
|
(begin
|
|
(log-to (debug-log) "migrations table not found in db. Creating...")
|
|
(query db "create table migrations(
|
|
id bigserial primary key,
|
|
migration_id integer not null unique
|
|
);")
|
|
(log-to (debug-log) "migrations table creation finished")))
|
|
(run-pending-migrations db))))
|
|
|
|
(define (db-clean)
|
|
(with-db/transaction
|
|
(lambda (db)
|
|
(if (value-at (query db "SELECT EXISTS (SELECT FROM pg_tables WHERE schemaname = 'public' AND tablename = 'users');"))
|
|
(begin
|
|
(log-to (debug-log) "cleaning database")
|
|
(for-each
|
|
(lambda (statement)
|
|
(query db (conc statement ";")))
|
|
(string-split (with-input-from-file "db-clean.sql" read-string) ";"))
|
|
(log-to (debug-log) "database cleaning complete"))
|
|
(begin
|
|
(log-to (debug-log) "tables not found, not cleaning")
|
|
#t)))))
|
|
|
|
;; (with-db/transaction (lambda (db) (get-user-deployments db 1)))
|
|
;; (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)))))
|
|
;; (with-db/transaction
|
|
;; (lambda (db)
|
|
;; (update-user-terraform-state db 1 22
|
|
;; (with-input-from-file "src/deploy-7/terraform.tfstate" read-string)
|
|
;; (with-input-from-file "src/deploy-7/terraform.tfstate.backup" read-string))))
|
|
;; (with-db/transaction (lambda (db) (get-user-terraform-state db 7)))
|
|
|
|
;; (with-db/transaction (lambda (db) (create-deployment db 7)))
|
|
;; (with-db/transaction (lambda (db) (get-deployment-status db 1)))
|
|
;; (with-db/transaction (lambda (db) (update-deployment-in-progress db 1 123)))
|
|
;; (with-db/transaction (lambda (db) (update-deployment-status db 1 'complete)))
|
|
;; (with-db/transaction (lambda (db) (get-most-recent-deployment-status db 7)))
|
|
|
|
;; (with-db/transaction (lambda (db) (create-user db 1 "t@thintz.com" "thecombjelly")))
|
|
;; (with-db/transaction (lambda (db) (create-instance db 2)))
|
|
|
|
;; (let ((user-id 7))
|
|
;; (with-db/transaction
|
|
;; (lambda (db)
|
|
;; (receive (user-key user-iv auth-user-id)
|
|
;; (get-decrypted-user-key-and-iv db user-id)
|
|
;; (receive (message tag)
|
|
;; (user-encrypt "hello!" user-key user-iv user-id)
|
|
;; (user-decrypt message tag user-key user-iv user-id))))))
|
|
|
|
;; (with-db/transaction
|
|
;; (lambda (db)
|
|
;; (update-user-service-config db 7 '((cloudflare-api-token . ")
|
|
;; (digitalocean-region . "sfo3")))))
|
|
|
|
;; (with-db/transaction
|
|
;; (lambda (db)
|
|
;; (get-user-service-config db 7)))
|
|
|
|
;; (with-db/transaction
|
|
;; (lambda (db)
|
|
;; (update-user-selected-apps db 7 '((wg-easy . "0.1")
|
|
;; (nextcloud . "1.3")))))
|
|
|
|
;; (with-db/transaction
|
|
;; (lambda (db)
|
|
;; (get-user-selected-apps db 7)))
|
|
|
|
;; (with-db/transaction
|
|
;; (lambda (db)
|
|
;; (update-user-app-config db 7 "domain.com" '())))
|
|
|
|
;; (with-db/transaction
|
|
;; (lambda (db)
|
|
;; (get-user-app-config db 7)))
|
|
|
|
)
|