diff options
| -rw-r--r-- | guix-data-service/poll-git-repository.scm | 46 |
1 files changed, 34 insertions, 12 deletions
diff --git a/guix-data-service/poll-git-repository.scm b/guix-data-service/poll-git-repository.scm index 399299d..1ce271a 100644 --- a/guix-data-service/poll-git-repository.scm +++ b/guix-data-service/poll-git-repository.scm @@ -112,21 +112,42 @@ 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 - (map + (filter-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)))) + (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 @@ -187,7 +208,8 @@ git-repository-id repository-commit "poll")))) - (if database-commit + (if (or (not database-commit) + (string=? database-commit "")) #f ;; Nothing to do (insert-git-commit-entry conn (git-branch-entry) |