(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)))

)