[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
branch master updated: Support polling git repositories for new branches
|
From: |
Christopher Baines |
|
Subject: |
branch master updated: Support polling git repositories for new branches/revisions |
|
Date: |
Mon, 09 Oct 2023 17:22:03 -0400 |
This is an automated email from the git hooks/post-receive script.
cbaines pushed a commit to branch master
in repository data-service.
The following commit(s) were added to refs/heads/master by this push:
new 10bad53 Support polling git repositories for new branches/revisions
10bad53 is described below
commit 10bad53ad57e92dbc3c6207c251f0af1148e8ffc
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Mon Oct 9 21:29:58 2023 +0100
Support polling git repositories for new branches/revisions
This is mostly a workaround for the occasional problems with the
guix-commits
mailing list, as it can break and then the data service doesn't learn about
new revisions until the problem is fixed.
I think it's still a generally good feature though, and allows deploying the
data service without it consuming emails to learn about new revisions, and
is
a step towards integrating some kind of way of notifying the data service to
poll.
---
Makefile.am | 1 +
guix-data-service/branch-updated-emails.scm | 91 +++++++++---
guix-data-service/database.scm | 17 +++
guix-data-service/jobs/load-new-guix-revision.scm | 16 ---
guix-data-service/model/git-commit.scm | 11 +-
guix-data-service/model/git-repository.scm | 24 ++--
guix-data-service/poll-git-repository.scm | 168 ++++++++++++++++++++++
guix-data-service/web/repository/controller.scm | 4 +-
guix-data-service/web/view/html.scm | 2 +-
scripts/guix-data-service.in | 26 +++-
sqitch/deploy/git_repositories_poll_interval.sql | 8 ++
sqitch/revert/git_repositories_poll_interval.sql | 7 +
sqitch/sqitch.plan | 1 +
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;
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- branch master updated: Support polling git repositories for new branches/revisions,
Christopher Baines <=