You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
328 lines
13 KiB
Scheme
328 lines
13 KiB
Scheme
2 weeks ago
|
(module nassella-db
|
||
|
|
(;; parameters
|
||
|
|
connection-spec
|
||
|
|
|
||
|
|
;;functions
|
||
|
|
with-db with-db/transaction
|
||
|
|
|
||
|
|
create-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
|
||
|
|
update-root-domain
|
||
|
|
)
|
||
|
|
|
||
|
|
(import scheme
|
||
|
|
(chicken base)
|
||
|
|
(chicken blob)
|
||
|
|
(chicken file)
|
||
|
|
(chicken string)
|
||
|
|
(chicken port)
|
||
|
|
postgresql
|
||
|
|
sql-null
|
||
|
|
srfi-1
|
||
|
|
srfi-13
|
||
|
|
(openssl cipher)
|
||
|
|
(openssl random)
|
||
|
|
crypto-tools)
|
||
|
|
|
||
|
|
(define connection-spec (make-parameter '((dbname . "nassella") (user . "nassella") (password . "password") (host . "127.0.0.1"))))
|
||
|
|
(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 auth_user_id, 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 (number->string (alist-ref 'auth_user_id 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)))
|
||
|
|
(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 (number->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 (number->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 auth-user-id 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)))
|
||
|
|
;; (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
|
||
|
|
"insert into users(auth_user_id, email, username, key_key, key_iv) values ($1, $2, $3, $4, $5)
|
||
|
|
returning users.user_id;"
|
||
|
|
auth-user-id email username
|
||
|
|
(string-append (blob->hexstring/uppercase (string->blob enc-user-key))
|
||
|
|
(blob->hexstring/uppercase (string->blob tag)))
|
||
|
|
user-iv))))
|
||
|
|
(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)))))
|
||
|
|
|
||
|
|
(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))
|
||
|
|
(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 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) 2))
|
||
|
|
", ")
|
||
|
|
" where user_id=$1;")
|
||
|
|
(cons user-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)
|
||
|
|
(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;")
|
||
|
|
user-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")
|
||
|
|
(log-viewer . "log_viewer_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 app-alist)
|
||
|
|
(let ((valid-keys (map car *user-selected-apps-column-map*)))
|
||
|
|
(for-each (lambda (app)
|
||
|
|
(if (not (memq (car app) valid-keys))
|
||
|
|
(error (string-append "Not a valid app key: " (->string (car app))))))
|
||
|
|
app-alist))
|
||
|
|
(query* conn
|
||
|
|
(string-append
|
||
|
|
"update user_selected_apps set "
|
||
|
|
(string-intersperse
|
||
|
|
(map-in-order (lambda (app i)
|
||
|
|
(conc (alist-ref (car app) *user-selected-apps-column-map*)
|
||
|
|
"=$" i))
|
||
|
|
app-alist
|
||
|
|
(iota (length app-alist) 2))
|
||
|
|
", ")
|
||
|
|
" where user_id=$1;")
|
||
|
|
(cons user-id
|
||
|
|
(map-in-order cdr app-alist))))
|
||
|
|
|
||
|
|
(define (get-user-selected-apps conn user-id)
|
||
|
|
(let ((res (row-alist
|
||
|
|
(query conn
|
||
|
|
(string-append
|
||
|
|
"select "
|
||
|
|
(string-intersperse
|
||
|
|
(map-in-order cdr *user-selected-apps-column-map*)
|
||
|
|
", ")
|
||
|
|
" from user_selected_apps where user_id=$1;")
|
||
|
|
user-id))))
|
||
|
|
(map (lambda (item)
|
||
|
|
(let* ((key (car item))
|
||
|
|
(value (cdr item))
|
||
|
|
(config (alist-ref key *user-selected-apps-reverse-column-map*)))
|
||
|
|
`(,config . ,(if (sql-null? value)
|
||
|
|
#f
|
||
|
|
value))))
|
||
|
|
res)))
|
||
|
|
|
||
|
|
(define (update-user-app-config conn user-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;"
|
||
|
|
(user-encrypt-for-db
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(write config)))
|
||
|
|
user-key user-iv user-id)
|
||
|
|
user-id)))
|
||
|
|
|
||
|
|
(define (update-root-domain conn user-id root-domain)
|
||
|
|
(query conn
|
||
|
|
"update user_app_configs set root_domain=$1 where user_id=$2;"
|
||
|
|
root-domain
|
||
|
|
user-id))
|
||
|
|
|
||
|
|
(define (get-user-app-config conn user-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;"
|
||
|
|
user-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)))))))
|
||
|
|
|
||
|
|
;; (with-db/transaction (lambda (db) (create-user db 1 "t@thintz.com" "thecombjelly")))
|
||
|
|
|
||
|
|
;; (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)))
|
||
|
|
|
||
|
|
)
|