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

Working nassella deployment.

Browse Source
This commit is contained in:
Thomas Hintz
2026-04-08 19:54:32 -07:00
parent 265a682b52
commit dcd1df754a
21 changed files with 835 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

48
src/db.scm
View File

@@ -7,7 +7,8 @@
db-init db-clean
create-user delete-user
create-instance get-user-instances
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
@@ -41,10 +42,17 @@
crypto-tools
spiffy)
(define connection-spec (make-parameter '((dbname . "nassella") (user . "nassella") (password . "password")
;; (host . "127.0.0.1")
(host . "nassella_db")
)))
(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)
@@ -101,7 +109,7 @@
(define *root-key-key* (ensure-root-key))
(define (get-user-key-and-iv conn user-id)
(row-alist (query conn "select auth_user_id, key_key, key_iv from users where user_id=$1;" 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))
@@ -109,9 +117,9 @@
(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 (number->string (alist-ref 'auth_user_id auth-user-id-and-user-key-and-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 'auth_user_id 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)
@@ -131,17 +139,17 @@
(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 auth-user-id email username)
(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 (number->string auth-user-id)))
(encrypt user-key *root-key-key* *root-key-iv* (string->blob username))
(let ((user-id
(value-at
(query conn
"insert into users(auth_user_id, email, username, key_key, key_iv) values ($1, $2, $3, $4, $5)
"insert into users(email, username, key_key, key_iv) values ($1, $2, $3, $4)
returning users.user_id;"
auth-user-id email username
email username
(string-append (blob->hexstring/uppercase (string->blob enc-user-key))
(blob->hexstring/uppercase (string->blob tag)))
user-iv))))
@@ -150,6 +158,12 @@ returning users.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
@@ -171,6 +185,9 @@ returning users.user_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)
@@ -386,7 +403,10 @@ returning users.user_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)
(value-at (query conn "select status from deployments where user_id=$1 and instance_id=$2 order by id DESC limit 1;" 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")
@@ -550,7 +570,7 @@ returning users.user_id;"
(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 1 "me@example.com" "username")
(create-user db "me@example.com" "username")
(log-to (debug-log) "test user creation finished"))))))
(define (db-clean)