;;; Guix Data Service -- Information about Guix over time ;;; Copyright © 2023 Christopher Baines ;;; ;;; 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 ;;; . (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) #:use-module (guix git) #:use-module (guix channels) #:use-module ((guix build syscalls) #:select (set-thread-name)) #: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 () (catch 'system-error (lambda () (set-thread-name (simple-format #f "poll git ~A" git-repository-id))) (const #t)) (libgit2-init!) (honor-system-x509-certificates!) (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* (just-update-cached-checkout url #:key (ref '()) recursive? (cache-directory (url-cache-directory url (%repository-cache-directory) #:recursive? recursive?))) (let* ((cache-exists? (openable-repository? cache-directory)) (repository (if cache-exists? (repository-open cache-directory) ((@@ (guix git) clone/swh-fallback) url ref cache-directory)))) ;; Only fetch remote if it has not been cloned just before. (when cache-exists? (remote-fetch (remote-lookup repository "origin") #:fetch-options ((@@ (guix git) make-default-fetch-options)))) (repository-close! repository))) (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 () ;; This was using update-cached-checkout, but it wants to checkout ;; refs/remotes/origin/HEAD by default, and that can fail for some reason ;; on some repositories: ;; ;; reference 'refs/remotes/origin/HEAD' not found ;; ;; I just want to update the cached checkout though, so trying to ;; checkout some revision is unnecessary, hence ;; just-update-cached-checkout (just-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)) ;; remote-ls returns remote-head's where the oid's aren't like the ;; oid's found through branches, and I'm not sure how to handle ;; them. Work around this by just using remote-ls to check what ;; branches exist on the remote. (remote-branch-names (with-repository repository-directory repository (let ((remote (remote-lookup repository "origin"))) (remote-connect remote) (filter-map (lambda (rh) (let ((name (remote-head-name rh))) (if (string-prefix? "refs/heads/" name) (string-drop name (string-length "refs/heads/")) #f))) (remote-ls remote))))) (repository-branches (with-repository repository-directory repository (filter-map (lambda (branch-reference) (let* ((branch-name (string-drop (reference-shorthand branch-reference) (string-length "origin/")))) (and ;; branch-list may list branches which don't exist on the ;; remote, so use the information from remote-ls to ;; filter them out (member branch-name remote-branch-names) (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 (or (not database-commit) (string=? database-commit "")) #f ;; Nothing to do (insert-git-commit-entry conn (git-branch-entry) "" (current-date 0)))))) branch-names))))))))