diff options
Diffstat (limited to 'guix-data-service/model/build-server.scm')
| -rw-r--r-- | guix-data-service/model/build-server.scm | 176 |
1 files changed, 175 insertions, 1 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))))))) |