diff options
| -rw-r--r-- | guix-data-service/model/build-server.scm | 176 | ||||
| -rw-r--r-- | guix-data-service/model/git-repository.scm | 42 | ||||
| -rw-r--r-- | 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 |