diff options
Diffstat (limited to 'guix-data-service/poll-git-repository.scm')
| -rw-r--r-- | guix-data-service/poll-git-repository.scm | 168 |
1 files changed, 168 insertions, 0 deletions
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)))))))) |