17/18: Add utility functions for configuring the database

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit 73b53f46a3ae42d9e8d4aeac95c82f567d7c804f
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sun Dec 15 19:14:27 2024 +0000

    Add utility functions for configuring the database
---
 guix-data-service/model/build-server.scm   | 176 ++++++++++++++++++++++++++++-
 guix-data-service/model/git-repository.scm |  42 +++++++
 guix-data-service/model/utils.scm          | 113 +++++++++++++++++-
 3 files changed, 329 insertions(+), 2 deletions(-)

diff --git a/guix-data-service/model/build-server.scm 
b/guix-data-service/model/build-server.scm
index d73dddd..ee25538 100644
--- a/guix-data-service/model/build-server.scm
+++ b/guix-data-service/model/build-server.scm
@@ -16,11 +16,15 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-data-service model build-server)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:use-module (squee)
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model utils)
   #:export (select-build-servers
             select-build-server
-            select-build-server-urls-by-id))
+            select-build-server-urls-by-id
+            specify-build-servers))
 
 (define (select-build-servers conn)
   (define query
@@ -58,3 +62,173 @@ WHERE id = $1")
          ((id url lookup-all-derivations? lookup-builds?)
           (cons id url)))
        (select-build-servers conn)))
+
+(define (specify-build-servers build-servers)
+  (define (specify-token-seeds conn
+                               build-server-id
+                               token-seeds)
+    (define string-build-server-id
+      (number->string build-server-id))
+
+    (let* ((db-token-seeds
+            (map
+             car
+             (exec-query
+              conn
+              "
+SELECT token_seed
+FROM build_server_token_seeds
+WHERE build_server_id = $1"
+              (list string-build-server-id))))
+           (token-seeds-to-delete
+            (lset-difference string=?
+                             db-token-seeds
+                             token-seeds))
+           (token-seeds-to-insert
+            (lset-difference string=?
+                             token-seeds
+                             db-token-seeds)))
+
+      (for-each
+       (lambda (seed)
+         (exec-query
+          conn
+          "
+DELETE FROM build_server_token_seeds
+WHERE build_server_id = $1
+  AND token_seed = $2"
+          (list string-build-server-id
+                seed)))
+       token-seeds-to-delete)
+
+      (for-each
+       (lambda (seed)
+         (exec-query
+          conn
+          "
+INSERT INTO build_server_token_seeds
+VALUES ($1, $2)"
+          (list string-build-server-id
+                seed)))
+       token-seeds-to-insert)))
+
+  (define (specify-build-config conn
+                                build-server-id
+                                systems-and-targets)
+    (define string-build-server-id
+      (number->string build-server-id))
+
+    (define pair-equal?
+      (match-lambda*
+        (((s1 . t1) (s2 . t2))
+         (and (string=? s1 s2)
+              (string=? t1 t2)))))
+
+    (let* ((db-systems-and-targets
+            (map
+             (match-lambda
+               ((system target)
+                (cons system target)))
+             (exec-query
+              conn
+              "
+SELECT system, target
+FROM build_servers_build_config
+WHERE build_server_id = $1"
+              (list string-build-server-id))))
+           (systems-and-targets-to-delete
+            (lset-difference pair-equal?
+                             db-systems-and-targets
+                             systems-and-targets))
+           (systems-and-targets-to-insert
+            (lset-difference pair-equal?
+                             systems-and-targets
+                             db-systems-and-targets)))
+
+      (for-each
+       (match-lambda
+         ((system . target)
+          (exec-query
+           conn
+           "
+DELETE FROM build_servers_build_config
+WHERE build_server_id = $1
+  AND system = $2
+  AND target = $3"
+           (list string-build-server-id
+                 system
+                 target))))
+       systems-and-targets-to-delete)
+
+      (for-each
+       (match-lambda
+         ((system . target)
+          (exec-query
+           conn
+           "
+INSERT INTO build_servers_build_config
+VALUES ($1, $2, $3)"
+           (list string-build-server-id
+                 system
+                 target))))
+       systems-and-targets-to-insert)))
+
+  (with-postgresql-connection
+   "specify-build-servers"
+   (lambda (conn)
+     (with-postgresql-transaction
+      conn
+      (lambda (conn)
+        (let* ((existing-ids
+                (map first (select-build-servers conn)))
+               (target-ids
+                (map (lambda (repo)
+                       (or (assq-ref repo 'id)
+                           (error "build server missing id")))
+                     build-servers))
+               (build-servers-to-delete
+                (lset-difference equal?
+                                 existing-ids
+                                 target-ids)))
+          (for-each
+           (lambda (id-to-remove)
+             (simple-format (current-error-port)
+                            "deleting build server ~A\n"
+                            id-to-remove)
+             (exec-query
+              conn
+              "DELETE FROM build_servers WHERE id = $1"
+              (list (number->string id-to-remove))))
+           build-servers-to-delete)
+
+          (for-each
+           (lambda (build-server)
+             (let* ((related-table-keys '(systems-and-targets
+                                          token-seeds))
+                    (build-servers-without-related-data
+                     (filter-map
+                      (lambda (pair)
+                        (if (memq (car pair) related-table-keys)
+                            #f
+                            pair))
+                      build-server))
+                    (fields (map car build-servers-without-related-data))
+                    (field-vals (map cdr build-servers-without-related-data)))
+               (update-or-insert
+                conn
+                "build_servers"
+                fields
+                field-vals)
+
+               (specify-token-seeds
+                conn
+                (assq-ref build-server 'id)
+                (or (assq-ref build-server 'token-seeds)
+                    '()))
+
+               (specify-build-config
+                conn
+                (assq-ref build-server 'id)
+                (or (assq-ref build-server 'systems-and-targets)
+                    '()))))
+           build-servers)))))))
diff --git a/guix-data-service/model/git-repository.scm 
b/guix-data-service/model/git-repository.scm
index 5c605f8..c05376f 100644
--- a/guix-data-service/model/git-repository.scm
+++ b/guix-data-service/model/git-repository.scm
@@ -20,9 +20,11 @@
   #:use-module (ice-9 match)
   #:use-module (json)
   #:use-module (squee)
+  #:use-module (guix-data-service database)
   #:use-module (guix-data-service model utils)
   #:export (all-git-repositories
             select-git-repository
+            specify-git-repositories
             git-repository-query-substitutes?
             git-repository-id->url
             select-includes-and-excluded-branches-for-git-repository
@@ -68,6 +70,46 @@ WHERE id = $1"
            (string=? fetch_with_authentication "t")
            (and=> poll-interval string->number)))))
 
+(define (specify-git-repositories repositories)
+  (with-postgresql-connection
+   "specify-git-repositories"
+   (lambda (conn)
+     (with-postgresql-transaction
+      conn
+      (lambda (conn)
+        (let* ((existing-ids
+                (map first (all-git-repositories conn)))
+               (target-ids
+                (map (lambda (repo)
+                       (or (assq-ref repo 'id)
+                           (error "repository missing id")))
+                     repositories))
+               (repositories-to-delete
+                (lset-difference equal?
+                                 existing-ids
+                                 target-ids)))
+          (for-each
+           (lambda (id-to-remove)
+             (simple-format (current-error-port)
+                            "deleting repository ~A\n"
+                            id-to-remove)
+             (exec-query
+              conn
+              "DELETE FROM git_repositories WHERE id = $1"
+              (list (number->string id-to-remove))))
+           repositories-to-delete)
+
+          (for-each
+           (lambda (repo)
+             (let ((fields (map car repo))
+                   (field-vals (map cdr repo)))
+               (update-or-insert
+                conn
+                "git_repositories"
+                fields
+                field-vals)))
+           repositories)))))))
+
 (define (git-repository-query-substitutes? conn id)
   (match (exec-query
           conn
diff --git a/guix-data-service/model/utils.scm 
b/guix-data-service/model/utils.scm
index cd59681..acfb704 100644
--- a/guix-data-service/model/utils.scm
+++ b/guix-data-service/model/utils.scm
@@ -34,6 +34,7 @@
             group-to-alist/vector
             insert-missing-data-and-return-all-ids
             insert-missing-data
+            update-or-insert
             bulk-select
             insert-and-return-id
             prepare-insert-and-return-id))
@@ -188,7 +189,7 @@ WHERE table_name = $1"
     ((? number? n)
      (number->string n))
     ((? boolean? b)
-     (if b "TRUE" "FALSE"))
+     (if b "t" "f"))
     ((? vector? v)
      (string-append
       "{" (string-join (map value->sql-literal (vector->list v)) ",") "}"))
@@ -395,6 +396,116 @@ RETURNING id"))
 
     (values result new-ids)))
 
+(define* (update-or-insert conn
+                           table-name
+                           fields
+                           field-vals
+                           #:key (id-fields '(id)))
+  (define id-field-strings
+    (map symbol->string id-fields))
+
+  (define id-field-values
+    (map (lambda (id-field)
+           (any (lambda (field val)
+                  (if (eq? field id-field)
+                      (value->sql-literal val)
+                      #f))
+                fields
+                field-vals))
+         id-fields))
+
+  (define field-strings
+    (map symbol->string fields))
+
+  (define select
+    (string-append
+     "
+SELECT " (string-join field-strings ", ") " FROM " table-name "
+WHERE "
+(string-join
+ (filter-map
+  (lambda (i field)
+    (simple-format #f "(~A = $~A)" field i))
+  (iota (length id-fields) 1)
+  id-field-strings)
+ " AND\n  ")
+";"))
+
+  (define insert
+    (string-append
+     "
+INSERT INTO " table-name " (" (string-join field-strings ", ") ")
+VALUES (" (string-join
+           (map (lambda (i)
+                  (simple-format #f "$~A" i))
+                (iota (length fields) 1))
+           ", ") ")
+ON CONFLICT DO NOTHING
+RETURNING " (string-join id-field-strings ", ") ";"))
+
+  (define (update fields-to-update)
+    (define update-field-strings
+      (map symbol->string fields-to-update))
+
+    (string-append
+     "
+UPDATE " table-name "
+SET " (string-join
+       (map (lambda (field i)
+              (simple-format #f "~A = $~A" field i))
+            update-field-strings
+            (iota (length update-field-strings) 1))
+       ", ") "
+WHERE "
+(string-join
+ (filter-map
+  (lambda (i field)
+    (simple-format #f "(~A = $~A)" field i))
+  (iota (length id-fields) (+ 1 (length fields-to-update)))
+  id-field-strings)
+ " AND\n  ")))
+
+  (let ((sql-field-values
+         (map value->sql-literal field-vals)))
+    (match (exec-query
+            conn
+            select
+            id-field-values)
+      ((db-field-values)
+       (let* ((normalised-field-values
+               (map value->sql-literal
+                    db-field-values))
+              (fields-to-update
+               (filter-map
+                (lambda (field db-val target-val)
+                  ;; TODO This might incorrectly detect differences
+                  (if (equal? db-val target-val)
+                      #f
+                      field))
+                fields
+                normalised-field-values
+                sql-field-values))
+              (update-field-values
+               (filter-map
+                (lambda (field val)
+                  (if (memq field fields-to-update)
+                      val
+                      #f))
+                fields
+                sql-field-values)))
+         (unless (null? fields-to-update)
+           (exec-query
+            conn
+            (update fields-to-update)
+            (append update-field-values
+                    id-field-values)))))
+      (()
+       (exec-query
+        conn
+        insert
+        sql-field-values))))
+  *unspecified*)
+
 (define* (insert-and-return-id conn
                                table-name
                                fields