~ruther/guix-local

ee6d2a77a3f07c4b81fd31bc7aa5d07accc317bd — Ludovic Courtès 1 year, 3 months ago 27e62d4 
git: Use ‘graph-descendant?’ from Guile-Git >= 0.10.0 when available.

Fixes <https://issues.guix.gnu.org/66268>.

Fixes a bug whereby ‘commit-relation’ and ‘commit-descendant?’ would
provide an incorrect result when two distinct <commit> objects would
exist for the same commit, which happens when the commit’s metadata is
beyond 4 KiB at least as of libgit2 1.8/1.9.

This, in turn, would lead ‘guix pull’ & co. to wrongfully report an
attempt to downgrade and pull to an unrelated commit.

* guix/git.scm (commit-relation): When (git graph) is available,
rewrite in terms of ‘graph-descendant?’.
(commit-descendant?): Likewise.

Change-Id: Ie52b188a8dfa90c95a73387c3ab2fdd04d2bf3e9
Reported-by: Tomas Volf <~@wolfsden.cz>
patch browse .tar.gz .zip 
1 files changed, 53 insertions(+), 32 deletions(-)

M guix/git.scm

M guix/git.scm => guix/git.scm +53 -32
@@ 732,7 732,7 @@ Log progress and checkout info to LOG-PORT."
;;; Commit difference.
;;;

(define* (commit-closure commit #:optional (visited (setq)))
(define* (commit-closure commit #:optional (visited (setq))) ;to remove
  "Return the closure of COMMIT as a set.  Skip commits contained in VISITED,
a set, and adjoin VISITED to the result."
  (let loop ((commits (list commit))


@@ 768,39 768,60 @@ that of OLD."
                 (cons head result)
                 (set-insert head visited)))))))

(define (commit-relation old new)
  "Return a symbol denoting the relation between OLD and NEW, two commit
(define commit-relation
  (if (resolve-module '(git graph) #:ensure #f)   ;Guile-Git >= 0.10.0
      (lambda (old new)
        "Return a symbol denoting the relation between OLD and NEW, two commit
objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
'unrelated, or 'self (OLD and NEW are the same commit)."
  (if (eq? old new)
      'self
      (let ((newest (commit-closure new)))
        (if (set-contains? newest old)
            'ancestor
            (let* ((seen   (list->setq (commit-parents new)))
                   (oldest (commit-closure old seen)))
              (if (set-contains? oldest new)
                  'descendant
                  'unrelated))))))

(define (commit-descendant? new old)
  "Return true if NEW is the descendant of one of OLD, a list of commits.

When the expected result is likely #t, this is faster than using
'commit-relation' since fewer commits need to be traversed."
  (let ((old (list->setq old)))
    (let loop ((commits (list new))
               (visited (setq)))
      (match commits
        (()
         #f)
        (_
         ;; Perform a breadth-first search as this is likely going to
         ;; terminate more quickly than a depth-first search.
         (let ((commits (remove (cut set-contains? visited <>) commits)))
           (or (any (cut set-contains? old <>) commits)
               (loop (append-map commit-parents commits)
                     (fold set-insert visited commits)))))))))
        (let ((repository (commit-owner old))
              (old (commit-id old))
              (new (commit-id new)))
          (cond ((graph-descendant? repository new old)
                 'ancestor)
                ((oid=? old new)
                 'self)
                ((graph-descendant? repository old new)
                 'descendant)
                (else 'unrelated))))
      (lambda (old new)            ;remove when Guile-Git 0.10.0 is widespread
        (if (eq? old new)
            'self
            (let ((newest (commit-closure new)))
              (if (set-contains? newest old)
                  'ancestor
                  (let* ((seen   (list->setq (commit-parents new)))
                         (oldest (commit-closure old seen)))
                    (if (set-contains? oldest new)
                        'descendant
                        'unrelated))))))))

(define commit-descendant?
  (if (resolve-module '(git graph) #:ensure #f)   ;Guile-Git >= 0.10.0
      (lambda (new old)
        "Return true if NEW is the descendant of one of OLD, a list of
commits."
        (let ((repository (commit-owner new))
              (new (commit-id new)))
          (any (lambda (old)
                 (let ((old (commit-id old)))
                   (or (graph-descendant? repository new old)
                       (oid=? old new))))
               old)))
      (lambda (new old)            ;remove when Guile-Git 0.10.0 is widespread
        (let ((old (list->setq old)))
          (let loop ((commits (list new))
                     (visited (setq)))
            (match commits
              (()
               #f)
              (_
               ;; Perform a breadth-first search as this is likely going to
               ;; terminate more quickly than a depth-first search.
               (let ((commits (remove (cut set-contains? visited <>) commits)))
                 (or (any (cut set-contains? old <>) commits)
                     (loop (append-map commit-parents commits)
                           (fold set-insert visited commits)))))))))))


;;