From c35747499411d4efc7b437d63745a6dbc6910df4 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 3 Feb 2020 18:05:02 +0100 Subject: [PATCH] git: Add ssh authentication support. If Guile-Git revision is >= 0.3.0, use SSH agent authentication method for both clone and fetch calls. * guix/git.scm (auth-supported?): New variable, (clone*): set auth-method to ssh-agent if the variable above is true, (update-cached-checkout): ditto. --- guix/git.scm | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/guix/git.scm b/guix/git.scm index a12f1eec8e..341a2b8dda 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. @@ -108,6 +108,10 @@ (define* (url-cache-directory url (string-append "R:" url) url)))))) +;; Authentication appeared in Guile-Git 0.3.0, check if it is available. +(define auth-supported? + (false-if-exception (resolve-interface '(git auth)))) + (define (clone* url directory) "Clone git repository at URL into DIRECTORY. Upon failure, make sure no empty directory is left behind." @@ -119,7 +123,13 @@ (define (clone* url directory) ;; value in Guile-Git: . (if (module-defined? (resolve-interface '(git)) 'clone-init-options) - (clone url directory (clone-init-options)) + (let ((auth-method (and auth-supported? + (%make-auth-ssh-agent)))) + (clone url directory + (if auth-supported? + (make-clone-options + #:fetch-options (make-fetch-options auth-method)) + (clone-init-options)))) (clone url directory))) (lambda _ (false-if-exception (rmdir directory))))) @@ -276,12 +286,17 @@ (define canonical-ref (with-libgit2 (let* ((cache-exists? (openable-repository? cache-directory)) (repository (if cache-exists? - (repository-open cache-directory) + (repository-open (pk cache-directory)) (clone* url cache-directory)))) ;; Only fetch remote if it has not been cloned just before. (when (and cache-exists? (not (reference-available? repository ref))) - (remote-fetch (remote-lookup repository "origin"))) + (if auth-supported? + (let ((auth-method (and auth-supported? + (%make-auth-ssh-agent)))) + (remote-fetch (remote-lookup repository "origin") + #:fetch-options (make-fetch-options auth-method))) + (remote-fetch (remote-lookup repository "origin")))) (when recursive? (update-submodules repository #:log-port log-port)) (let ((oid (switch-to-ref repository canonical-ref)))