diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix-data-service/branch-updated-emails.scm | 91 | ||||
| -rw-r--r-- | guix-data-service/database.scm | 17 | ||||
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 16 | ||||
| -rw-r--r-- | guix-data-service/model/git-commit.scm | 11 | ||||
| -rw-r--r-- | guix-data-service/model/git-repository.scm | 24 | ||||
| -rw-r--r-- | guix-data-service/poll-git-repository.scm | 168 | ||||
| -rw-r--r-- | guix-data-service/web/repository/controller.scm | 4 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 2 | ||||
| -rw-r--r-- | scripts/guix-data-service.in | 26 | ||||
| -rw-r--r-- | sqitch/deploy/git_repositories_poll_interval.sql | 8 | ||||
| -rw-r--r-- | sqitch/revert/git_repositories_poll_interval.sql | 7 | ||||
| -rw-r--r-- | sqitch/sqitch.plan | 1 | ||||
| -rw-r--r-- | sqitch/verify/git_repositories_poll_interval.sql | 7 |
14 files changed, 329 insertions, 54 deletions
diff --git a/Makefile.am b/Makefile.am index 193ec7c..dac2943 100644 --- a/Makefile.am +++ b/Makefile.am @@ -69,6 +69,7 @@ check-with-tmp-database: SOURCES = \ guix-data-service/branch-updated-emails.scm \ + guix-data-service/poll-git-repository.scm \ guix-data-service/builds.scm \ guix-data-service/comparison.scm \ guix-data-service/config.scm \ diff --git a/guix-data-service/branch-updated-emails.scm b/guix-data-service/branch-updated-emails.scm index 38432e6..b36eced 100644 --- a/guix-data-service/branch-updated-emails.scm +++ b/guix-data-service/branch-updated-emails.scm @@ -20,6 +20,10 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (email email) + #:use-module (squee) + #:use-module (guix store) + #:use-module (guix channels) + #:use-module (guix-data-service database) #:use-module (guix-data-service model git-repository) #:use-module (guix-data-service model git-branch) #:use-module (guix-data-service model git-commit) @@ -60,25 +64,72 @@ (when (and (not excluded-branch?) (or (null? included-branches) included-branch?)) - (insert-git-commit-entry conn - (or (git-branch-for-repository-and-name - conn - git-repository-id - branch-name) - (insert-git-branch-entry - conn - git-repository-id - branch-name)) - (if (string=? commit-all-zeros - x-git-newrev) + (if (string=? commit-all-zeros x-git-newrev) + (insert-git-commit-entry conn + (or (git-branch-for-repository-and-name + conn + git-repository-id + branch-name) + (insert-git-branch-entry + conn + git-repository-id + branch-name)) "" - x-git-newrev) - date) + date) - (unless (string=? commit-all-zeros x-git-newrev) - (enqueue-load-new-guix-revision-job - conn - git-repository-id - x-git-newrev - (string-append x-git-repo " " - x-git-refname " updated"))))))))))) + ;; Fetch the latest channel instance to check if this + ;; email matches up with the current state of the Git + ;; repository, and ignore it if it doesn't. + (let* ((git-repository-details + (select-git-repository conn git-repository-id)) + (channel-for-commit + (channel (name 'guix) + (url (second git-repository-details)) + (commit x-git-repo))) + (channel-instance + ;; Obtain a session level lock here, to avoid conflicts with + ;; other jobs over the Git repository. + (with-advisory-session-lock/log-time + conn + 'latest-channel-instances + (lambda () + (with-store store + (first + (latest-channel-instances store + (list channel-for-commit) + #:authenticate? + (fourth git-repository-details)))))))) + + (if (string=? (channel-instance-commit channel-instance) + x-git-newrev) + (with-postgresql-transaction + conn + (lambda (conn) + (exec-query conn "LOCK TABLE git_commits IN EXCLUSIVE MODE") + + (if (git-commit-exists? conn x-git-newrev) + (simple-format #t "commit already exists for revision ~A (date: ~A)\n" + x-git-newrev + date) + (begin + (insert-git-commit-entry conn + (or (git-branch-for-repository-and-name + conn + git-repository-id + branch-name) + (insert-git-branch-entry + conn + git-repository-id + branch-name)) + x-git-newrev + date) + + (enqueue-load-new-guix-revision-job + conn + git-repository-id + x-git-newrev + (string-append x-git-repo " " + x-git-refname " updated")))))) + (simple-format #t "email newrev ~A doesn't match latest channel instance commit ~A\n" + x-git-newrev + (channel-instance-commit channel-instance))))))))))))) diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm index e768d55..756bfef 100644 --- a/guix-data-service/database.scm +++ b/guix-data-service/database.scm @@ -39,6 +39,7 @@ check-test-database! with-advisory-session-lock + with-advisory-session-lock/log-time obtain-advisory-transaction-lock exec-query-with-null-handling)) @@ -298,6 +299,22 @@ "SELECT pg_advisory_unlock($1)" (list lock-number)))))) +(define (with-advisory-session-lock/log-time conn lock f) + (simple-format #t "debug: Acquiring advisory session lock: ~A\n" lock) + (let ((start-time (current-time))) + (with-advisory-session-lock + conn + lock + (lambda () + (let ((time-taken (- (current-time) start-time))) + (simple-format #t "debug: Finished aquiring lock ~A, took ~A seconds\n" + lock time-taken)) + (let ((result (f))) + (let ((time-spent (- (current-time) start-time))) + (simple-format #t "debug: Releasing lock ~A, spent ~A seconds\n" + lock time-spent)) + result))))) + (define (obtain-advisory-transaction-lock conn lock) (let ((lock-number (number->string (symbol-hash lock)))) (exec-query conn diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index c10c9d4..d54afea 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -344,22 +344,6 @@ WHERE job_id = $1") (simple-format #t "debug: Finished ~A, took ~A seconds\n" action time-taken))))) -(define (with-advisory-session-lock/log-time conn lock f) - (simple-format #t "debug: Acquiring advisory session lock: ~A\n" lock) - (let ((start-time (current-time))) - (with-advisory-session-lock - conn - lock - (lambda () - (let ((time-taken (- (current-time) start-time))) - (simple-format #t "debug: Finished aquiring lock ~A, took ~A seconds\n" - lock time-taken)) - (let ((result (f))) - (let ((time-spent (- (current-time) start-time))) - (simple-format #t "debug: Releasing lock ~A, spent ~A seconds\n" - lock time-spent)) - result))))) - (define (inferior-guix-systems inf) ;; The order shouldn't matter here, but bugs in Guix can lead to different ;; results depending on the order, so sort the systems to try and provide diff --git a/guix-data-service/model/git-commit.scm b/guix-data-service/model/git-commit.scm index d017384..0e8f773 100644 --- a/guix-data-service/model/git-commit.scm +++ b/guix-data-service/model/git-commit.scm @@ -21,7 +21,8 @@ #:use-module (squee) #:use-module (srfi srfi-19) #:use-module (guix-data-service model utils) - #:export (insert-git-commit-entry)) + #:export (insert-git-commit-entry + git-commit-exists?)) (define (insert-git-commit-entry conn git-branch-id @@ -36,3 +37,11 @@ ON CONFLICT DO NOTHING" (list commit (number->string git-branch-id) (date->string datetime "~s")))) + +(define (git-commit-exists? conn commit) + (match (exec-query + conn + "SELECT 1 FROM git_commits WHERE commit = $1" + (list commit)) + (#f #f) + (_ #t))) diff --git a/guix-data-service/model/git-repository.scm b/guix-data-service/model/git-repository.scm index 102dc43..feae290 100644 --- a/guix-data-service/model/git-repository.scm +++ b/guix-data-service/model/git-repository.scm @@ -35,28 +35,36 @@ (define (all-git-repositories conn) (map (match-lambda - ((id label url cgit-base-url) + ((id label url cgit-base-url poll-interval) (list (string->number id) label url - cgit-base-url))) + cgit-base-url + (and=> poll-interval string->number)))) (exec-query conn - (string-append - "SELECT id, label, url, cgit_url_base FROM git_repositories ORDER BY id ASC")))) + " +SELECT id, label, url, cgit_url_base, poll_interval +FROM git_repositories ORDER BY id ASC"))) (define (select-git-repository conn id) (match (exec-query conn - "SELECT label, url, cgit_url_base, fetch_with_authentication FROM git_repositories WHERE id = $1" - (list id)) + " +SELECT label, url, cgit_url_base, fetch_with_authentication, poll_interval +FROM git_repositories +WHERE id = $1" + (list (if (number? id) + (number->string id) + id))) (() #f) - (((label url cgit_url_base fetch_with_authentication)) + (((label url cgit_url_base fetch_with_authentication poll-interval)) (list label url cgit_url_base - (string=? fetch_with_authentication "t"))))) + (string=? fetch_with_authentication "t") + (and=> poll-interval string->number))))) (define (git-repository-query-substitutes? conn id) (match (exec-query diff --git a/guix-data-service/poll-git-repository.scm b/guix-data-service/poll-git-repository.scm new file mode 100644 index 0000000..6c9112b --- /dev/null +++ b/guix-data-service/poll-git-repository.scm @@ -0,0 +1,168 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2023 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service poll-git-repository) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-71) + #:use-module (ice-9 threads) + #:use-module (squee) + #:use-module (git oid) + #:use-module (git branch) + #:use-module (git reference) + #:use-module (guix git) + #:use-module (guix channels) + #:use-module (guix-data-service database) + #:use-module (guix-data-service model git-repository) + #:use-module (guix-data-service model git-branch) + #:use-module (guix-data-service model git-commit) + #:use-module (guix-data-service jobs load-new-guix-revision) + #:export (start-thread-to-poll-git-repository)) + +(define (start-thread-to-poll-git-repository git-repository-id) + (call-with-new-thread + (lambda () + (with-postgresql-connection + (simple-format #f "poll-git-repository-~A" + git-repository-id) + (lambda (conn) + (let loop () + (with-exception-handler + (lambda (exn) + (simple-format #t "exception when polling git repository (~A): ~A\n" + git-repository-id exn)) + (lambda () + (with-throw-handler #t + (lambda () + (poll-git-repository conn git-repository-id)) + (lambda _ + (backtrace)))) + #:unwind? #t) + + (and=> + (fifth (select-git-repository conn git-repository-id)) + (lambda (poll-interval) + (sleep poll-interval) + (loop))))))))) + +(define (poll-git-repository conn git-repository-id) + (define git-repository-details + (select-git-repository conn git-repository-id)) + + ;; Obtain a session level lock here, to avoid conflicts with other jobs over + ;; the Git repository. + (with-advisory-session-lock/log-time + conn + 'latest-channel-instances + (lambda () + ;; Maybe this helps avoid segfaults? + (monitor + (update-cached-checkout (second git-repository-details))) + + (let* ((repository-directory + (url-cache-directory + (second git-repository-details))) + + (included-branches + excluded-branches + (select-includes-and-excluded-branches-for-git-repository + conn + git-repository-id)) + + (repository-branches + (with-repository repository-directory repository + (map + (lambda (branch-reference) + (let* ((branch-name + (last + (string-split + (reference-shorthand branch-reference) + #\/)))) + (cons + branch-name + ;; TODO Not sure what the right way to do this is + (and=> (false-if-exception + (reference-target branch-reference)) + oid->string)))) + (branch-list repository BRANCH-REMOTE))))) + + (with-postgresql-transaction + conn + (lambda (conn) + (exec-query conn "LOCK TABLE git_commits IN EXCLUSIVE MODE") + + (let* ((repository-branch-details + (all-branches-with-most-recent-commit conn + git-repository-id)) + (branch-names + (filter + (lambda (branch-name) + (let ((excluded-branch? + (member branch-name excluded-branches string=?)) + (included-branch? + (member branch-name included-branches string=?))) + (and (not excluded-branch?) + (or (null? included-branches) + included-branch?)))) + (delete-duplicates! + (append! + (map car repository-branches) + (map car repository-branch-details)))))) + + (for-each + (lambda (branch-name) + (define (git-branch-entry) + (or (git-branch-for-repository-and-name + conn + git-repository-id + branch-name) + (insert-git-branch-entry + conn + git-repository-id + branch-name))) + + (let ((repository-commit + (assoc-ref repository-branches branch-name)) + (database-commit + (and=> (assoc-ref repository-branch-details + branch-name) + first))) + (if repository-commit + (if (and database-commit + (string=? database-commit + repository-commit)) + #f ;; Nothing to do + (begin + (insert-git-commit-entry conn + (git-branch-entry) + repository-commit + (current-date 0)) + + (unless #f + (enqueue-load-new-guix-revision-job + conn + git-repository-id + repository-commit + "poll")))) + (if database-commit + #f ;; Nothing to do + (insert-git-commit-entry conn + (git-branch-entry) + "" + (current-date 0)))))) + branch-names)))))))) diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index e1a9b9c..b77ca1f 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -58,7 +58,7 @@ `((repositories . ,(list->vector (map (match-lambda - ((id label url cgit-base-url) + ((id label url cgit-base-url _) `((id . ,id) (label . ,label) (url . ,url)))) @@ -70,7 +70,7 @@ (('GET "repository" id) (match (with-resource-from-pool (connection-pool) conn (select-git-repository conn id)) - ((label url cgit-url-base fetch-with-authentication?) + ((label url cgit-url-base fetch-with-authentication? poll-interval) (letpar& ((branches (with-resource-from-pool (connection-pool) conn (all-branches-with-most-recent-commit diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index db1cdc4..29eaf62 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -314,7 +314,7 @@ "Jobs")))) ,@(map (match-lambda - (((repository-id label url cgit-url-base) . branches-with-most-recent-commits) + (((repository-id label url cgit-url-base poll-interval) . branches-with-most-recent-commits) `(div (@ (class "row")) (div diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in index 1a41bd4..dc6b432 100644 --- a/scripts/guix-data-service.in +++ b/scripts/guix-data-service.in @@ -37,6 +37,8 @@ (guix-data-service config) (guix-data-service database) (guix-data-service substitutes) + (guix-data-service poll-git-repository) + (guix-data-service model git-repository) (guix-data-service model guix-revision-package-derivation) (guix-data-service web server) (guix-data-service web controller) @@ -204,12 +206,24 @@ (start-substitute-query-threads) - (when (assoc-ref opts 'update-database) - (call-with-new-thread - (lambda () - (run-sqitch) - - (atomic-box-set! startup-completed #t)))) + (call-with-new-thread + (lambda () + (run-sqitch) + + (for-each + (lambda (git-repository-details) + (when (fifth git-repository-details) + (simple-format #t "starting thread to poll ~A (~A)\n" + (second git-repository-details) + (third git-repository-details)) + + (start-thread-to-poll-git-repository + (first git-repository-details)))) + (with-postgresql-connection + "poll-startup" + all-git-repositories)) + + (atomic-box-set! startup-completed #t))) ;; Provide some visual space between the startup output and the ;; server starting diff --git a/sqitch/deploy/git_repositories_poll_interval.sql b/sqitch/deploy/git_repositories_poll_interval.sql new file mode 100644 index 0000000..a75cac6 --- /dev/null +++ b/sqitch/deploy/git_repositories_poll_interval.sql @@ -0,0 +1,8 @@ +-- Deploy guix-data-service:git_repositories_poll_interval to pg + +BEGIN; + +ALTER TABLE git_repositories + ADD COLUMN poll_interval INTEGER DEFAULT NULL; + +COMMIT; diff --git a/sqitch/revert/git_repositories_poll_interval.sql b/sqitch/revert/git_repositories_poll_interval.sql new file mode 100644 index 0000000..fcb875d --- /dev/null +++ b/sqitch/revert/git_repositories_poll_interval.sql @@ -0,0 +1,7 @@ +-- Revert guix-data-service:git_repositories_poll_interval from pg + +BEGIN; + +-- XXX Add DDLs here. + +COMMIT; diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan index a3f8952..a4f14e8 100644 --- a/sqitch/sqitch.plan +++ b/sqitch/sqitch.plan @@ -96,3 +96,4 @@ blocked_builds_blocked_builds_blocked_derivation_output_details_set_id_2 2023-03 guix_revision_package_derivation_distribution_counts 2023-03-08T16:53:44Z Chris <chris@felis> # Add guix_revision_package_derivation_distribution_counts table cascade_nar_foreign_keys 2023-08-01T09:42:33Z Chris <chris@felis> # Make it easier to delete nars entries nar_indexes 2023-08-01T11:37:35Z Chris <chris@felis> # Add nar related indexes +git_repositories_poll_interval 2023-10-08T20:36:09Z Chris <chris@felis> # Add git_repositories.poll_interval diff --git a/sqitch/verify/git_repositories_poll_interval.sql b/sqitch/verify/git_repositories_poll_interval.sql new file mode 100644 index 0000000..a2efd06 --- /dev/null +++ b/sqitch/verify/git_repositories_poll_interval.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:git_repositories_poll_interval on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; |