diff --git a/guix-data-service/builds.scm b/guix-data-service/builds.scm index 2c37885..c3421b9 100644 --- a/guix-data-service/builds.scm +++ b/guix-data-service/builds.scm @@ -135,11 +135,11 @@ initial connection on which HTTP requests are sent." (let ((build-servers (select-build-servers conn))) (for-each (match-lambda - ((id url lookup-all-derivations?) + ((id url lookup-all-derivations? lookup-builds?) (when (or (or (not build-servers) (not build-server-ids)) (member id build-server-ids)) - (when lookup-all-derivations? + (when lookup-builds? (simple-format #t "\nQuerying ~A\n" url) (catch #t (lambda () diff --git a/guix-data-service/model/build-server.scm b/guix-data-service/model/build-server.scm index 44b4b7d..a03410d 100644 --- a/guix-data-service/model/build-server.scm +++ b/guix-data-service/model/build-server.scm @@ -19,21 +19,23 @@ #:use-module (ice-9 match) #:use-module (squee) #:export (select-build-servers - select-build-server)) + select-build-server + select-build-server-urls-by-id)) (define (select-build-servers conn) (define query " -SELECT id, url, lookup_all_derivations +SELECT id, url, lookup_all_derivations, lookup_builds FROM build_servers ORDER BY id") (map (match-lambda - ((id url lookup-all-derivations) + ((id url lookup-all-derivations lookup-builds) (list (string->number id) url - (string=? lookup-all-derivations "t")))) + (string=? lookup-all-derivations "t") + (string=? lookup-builds)))) (exec-query conn query))) (define (select-build-server conn id) @@ -46,6 +48,13 @@ WHERE id = $1") (match (exec-query conn query (list (number->string id))) (() #f) - (((url lookup_all_derivations)) + (((url lookup_all_derivations lookup_builds)) (list url - (string=? lookup_all_derivations "t"))))) + (string=? lookup_all_derivations "t") + (string=? lookup_builds "t"))))) + +(define (select-build-server-urls-by-id conn) + (map (match-lambda + ((id url lookup-all-derivations? lookup-builds?) + (cons id url))) + (select-build-servers conn))) diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm index 6dd069e..b6c29f2 100644 --- a/guix-data-service/substitutes.scm +++ b/guix-data-service/substitutes.scm @@ -35,7 +35,7 @@ (let ((build-servers (select-build-servers conn))) (for-each (match-lambda - ((id url lookup-all-derivations?) + ((id url lookup-all-derivations? lookup-builds?) (when (or (or (not build-servers) (not build-server-ids)) (member id build-server-ids)) diff --git a/guix-data-service/web/build-server/html.scm b/guix-data-service/web/build-server/html.scm index bb15e11..319ab79 100644 --- a/guix-data-service/web/build-server/html.scm +++ b/guix-data-service/web/build-server/html.scm @@ -103,7 +103,7 @@ (h2 "Build servers") ,@(map (match-lambda - ((id url lookup-all-derivations?) + ((id url lookup-all-derivations? lookup-builds?) `(dl (@ (class "dl-horizontal")) (dt "URL") @@ -111,6 +111,10 @@ ,url)) (dt "Lookup all " (br) "derivations?") (dd ,(if lookup-all-derivations? + "Yes" + "No")) + (dt "Lookup " (br) "builds?") + (dd ,(if lookup-builds? "Yes" "No"))))) build-servers))))))) diff --git a/guix-data-service/web/build/controller.scm b/guix-data-service/web/build/controller.scm index e7d1399..a79d558 100644 --- a/guix-data-service/web/build/controller.scm +++ b/guix-data-service/web/build/controller.scm @@ -38,7 +38,7 @@ (lambda (v) (let ((build-servers (select-build-servers conn))) (or (any (match-lambda - ((id url lookup-all-derivations?) + ((id url lookup-all-derivations? lookup-builds?) (if (eq? (string->number v) id) id diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index 88739d5..0f8a5e7 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -295,11 +295,7 @@ target package-name)) (build-server-urls - (group-to-alist - (match-lambda - ((id url lookup-all-derivations) - (cons id url))) - (select-build-servers conn)))) + (select-build-server-urls-by-id conn))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -364,11 +360,7 @@ package-name output-name)) (build-server-urls - (group-to-alist - (match-lambda - ((id url lookup-all-derivations) - (cons id url))) - (select-build-servers conn)))) + (select-build-server-urls-by-id conn))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 0dc6eb4..f5ed8f0 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -77,7 +77,7 @@ (lambda (v) (let ((build-servers (select-build-servers conn))) (or (any (match-lambda - ((id url lookup-all-derivations?) + ((id url lookup-all-derivations? lookup-builds?) (if (eq? (string->number v) id) id @@ -454,11 +454,7 @@ (let ((substitute-availability (select-package-output-availability-for-revision conn commit-hash)) (build-server-urls - (group-to-alist - (match-lambda - ((id url lookup-all-derivations) - (cons id url))) - (select-build-servers conn)))) + (select-build-server-urls-by-id conn))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -796,11 +792,7 @@ #:after-name (assq-ref query-parameters 'after_name) #:include-builds? (member "builds" fields)))) (build-server-urls - (group-to-alist - (match-lambda - ((id url lookup-all-derivations) - (cons id url))) - (select-build-servers conn))) + (select-build-server-urls-by-id conn)) (show-next-page? (if all-results #f @@ -898,11 +890,7 @@ #:limit-results limit-results #:after-path (assq-ref query-parameters 'after_path))) (build-server-urls - (group-to-alist - (match-lambda - ((id url lookup-all-derivations) - (cons id url))) - (select-build-servers conn))) + (select-build-server-urls-by-id conn)) (show-next-page? (if all-results #f @@ -960,7 +948,8 @@ (valid-targets->options (valid-targets conn)) (map (match-lambda - ((id url lookup-all-derivations) + ((id url lookup-all-derivations + lookup-builds) (cons url id))) (select-build-servers conn)) (select-build-stats diff --git a/scripts/guix-data-service-manage-build-servers.in b/scripts/guix-data-service-manage-build-servers.in index b994e2b..0ca1706 100644 --- a/scripts/guix-data-service-manage-build-servers.in +++ b/scripts/guix-data-service-manage-build-servers.in @@ -54,7 +54,7 @@ (lambda (conn) (for-each (match-lambda - ((id url lookup-all-derivations?) + ((id url lookup-all-derivations? lookup-builds?) (simple-format #t "\nBuild server: ~A (id: ~A)\n" url id) diff --git a/sqitch/deploy/build_servers_lookup_builds.sql b/sqitch/deploy/build_servers_lookup_builds.sql new file mode 100644 index 0000000..dc16602 --- /dev/null +++ b/sqitch/deploy/build_servers_lookup_builds.sql @@ -0,0 +1,7 @@ +-- Deploy guix-data-service:build_servers_lookup_builds to pg + +BEGIN; + +ALTER TABLE build_servers ADD COLUMN lookup_builds boolean NOT NULL DEFAULT TRUE; + +COMMIT; diff --git a/sqitch/revert/build_servers_lookup_builds.sql b/sqitch/revert/build_servers_lookup_builds.sql new file mode 100644 index 0000000..62f55a1 --- /dev/null +++ b/sqitch/revert/build_servers_lookup_builds.sql @@ -0,0 +1,7 @@ +-- Revert guix-data-service:build_servers_lookup_builds from pg + +BEGIN; + +-- XXX Add DDLs here. + +COMMIT; diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan index ab6ce17..6e73371 100644 --- a/sqitch/sqitch.plan +++ b/sqitch/sqitch.plan @@ -57,3 +57,4 @@ drop_package_versions_by_guix_revision_range 2020-03-24T20:40:38Z Christopher Ba create_narinfo_fetch_records_index 2020-03-25T19:07:28Z Christopher Baines # Create an index on narinfo_fetch_records load_new_guix_revision_jobs_make_commits_unique 2020-03-27T21:38:42Z Christopher Baines # Make load_new_guix_revision_jobs commits unique remove_odd_package_derivations 2020-04-24T20:36:06Z Christopher Baines # Remove odd package derivations +build_servers_lookup_builds 2020-05-24T15:18:09Z Christopher Baines # Add build_servers.lookup_builds diff --git a/sqitch/verify/build_servers_lookup_builds.sql b/sqitch/verify/build_servers_lookup_builds.sql new file mode 100644 index 0000000..7db4be7 --- /dev/null +++ b/sqitch/verify/build_servers_lookup_builds.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:build_servers_lookup_builds on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK;