[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#38320: Cuirass: Allow to use authenticated Git repositories as input
|
From: |
Mathieu Othacehe |
|
Subject: |
bug#38320: Cuirass: Allow to use authenticated Git repositories as inputs |
|
Date: |
Mon, 09 Dec 2019 17:41:52 +0100 |
|
User-agent: |
mu4e 1.2.0; emacs 26.3 |
Hello,
Here's a patch that add support for ssh authenticated repositories in
"clone" and "remote-fetch" methods of Guile-Git.
At first, I used Guile-SSH in the tests to start an SSH server, but as
"make-server" call of Guile-SSH is really low level, this is not very
realistic. I just ended up with a half-broken ssh server, poorly
implemented, after (too many hours) spent reading ssh dumps.
So the strategy is to spawn an openssh server for the tests. It seems to
work alright, using key based or ssh-agent authentication.
WDYT?
Mathieu
>From ae3c5a9851b02e78096963616d4e2f999119fc4d Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <address@hidden>
Date: Mon, 9 Dec 2019 16:16:45 +0100
Subject: [PATCH] Add ssh authentication support.
* Makefile.am (SOURCES): Add git/auth.scm,
(TESTS): add tests/clone.scm.
* configure.ac: Check for git and ssh binaries.
* git.scm (%public-modules): Add (git auth) and (git bindings).
* git/auth.scm: New file.
* git/clone.scm (clone): Add an auth-method argument. Pass it to
new init-fetch-options call, before proceeding to clone.
* git/remote.scm (remote-fetch): Add an auth-method. Pass it to
init-fetch-options before proceeding to fetch.
* git/structs.scm (clone-options-fetch-options): Do not return a copy of
fetch-options nested inside clone-options. Instead, find the offset of
fetch-options and use it to create a pointer to fetch-options.
* git/fetch.scm (init-fetch-options): New exported procedure,
(make-fetch-options): call the procedure above to initialize fetch-options,
(set-fetch-auth-with-ssh-agent!): handle the case where username is not set
and libgit2 asks for one.
(set-fetch-auth-with-default-ssh-key!): remove this procedure,
(set-fetch-auth-with-ssh-key): new procedure.
* tests/.ssh/id_rsa_client: New file.
* tests/.ssh/id_rsa_client.pub: New file.
* tests/.ssh/id_rsa_server: New file.
* tests/clone.scm: New file.
* tests/ssh.scm.in: New file.
---
.gitignore | 4 ++
Makefile.am | 2 +
configure.ac | 9 ++-
git.scm | 3 +-
git/auth.scm | 38 ++++++++++++
git/clone.scm | 17 ++++--
git/fetch.scm | 77 +++++++++++++++--------
git/remote.scm | 11 ++--
git/structs.scm | 13 +++-
guix.scm | 5 +-
tests/.ssh/id_rsa_client | 27 ++++++++
tests/.ssh/id_rsa_client.pub | 1 +
tests/.ssh/id_rsa_server | 27 ++++++++
tests/clone.scm | 68 +++++++++++++++++++++
tests/ssh.scm.in | 115 +++++++++++++++++++++++++++++++++++
15 files changed, 378 insertions(+), 39 deletions(-)
create mode 100644 git/auth.scm
create mode 100644 tests/.ssh/id_rsa_client
create mode 100644 tests/.ssh/id_rsa_client.pub
create mode 100644 tests/.ssh/id_rsa_server
create mode 100644 tests/clone.scm
create mode 100644 tests/ssh.scm.in
diff --git a/.gitignore b/.gitignore
index 5d6d9c7..d32d05a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -28,3 +28,7 @@ doc/guile-git.info
doc/version.texi
doc/.dirstamp
doc/stamp-vti
+
+tests/ssh.scm
+tests/.ssh/authorized_keys
+tests/.ssh/sshd.conf
diff --git a/Makefile.am b/Makefile.am
index fba200a..facf9fa 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -28,6 +28,7 @@ SOURCES = \
git.scm \
git/annotated.scm \
git/attr.scm \
+ git/auth.scm \
git/bindings.scm \
git/blame.scm \
git/blob.scm \
@@ -75,6 +76,7 @@ TESTS_UTILS = \
TESTS = \
tests/branch.scm \
+ tests/clone.scm \
tests/commit.scm \
tests/describe.scm \
tests/oid.scm \
diff --git a/configure.ac b/configure.ac
index 5171aba..933679c 100644
--- a/configure.ac
+++ b/configure.ac
@@ -42,7 +42,14 @@ AS_IF([test "x$LIBGIT2_LIBDIR" = "x"], [
])
AC_SUBST([LIBGIT2_LIBDIR])
-AC_CONFIG_FILES([Makefile git/config.scm])
+dnl Those binaries are required for ssh authentication tests.
+AC_PATH_PROG([SSHD], [sshd])
+AC_PATH_PROG([SSH_AGENT], [ssh-agent])
+AC_PATH_PROG([SSH_ADD], [ssh-add])
+AC_PATH_PROG([GIT_UPLOAD_PACK], [git-upload-pack])
+AC_SUBST([SSHD])
+
+AC_CONFIG_FILES([Makefile git/config.scm tests/ssh.scm])
AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
AC_OUTPUT
diff --git a/git.scm b/git.scm
index 1559504..873101e 100644
--- a/git.scm
+++ b/git.scm
@@ -23,7 +23,8 @@
(eval-when (eval load compile)
(begin
(define %public-modules
- '((git bindings)
+ '((git auth)
+ (git bindings)
(git branch)
(git clone)
(git commit)
diff --git a/git/auth.scm b/git/auth.scm
new file mode 100644
index 0000000..c43af6e
--- /dev/null
+++ b/git/auth.scm
@@ -0,0 +1,38 @@
+;;; Guile-Git --- GNU Guile bindings of libgit2
+;;; Copyright © 2019 Mathieu Othacehe <address@hidden>
+;;;
+;;; This file is part of Guile-Git.
+;;;
+;;; Guile-Git is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Guile-Git 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
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Guile-Git. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (git auth)
+ #:use-module (srfi srfi-9)
+ #:export (%make-auth-ssh-credentials
+ auth-ssh-credentials?
+ auth-ssh-credentials-public-key
+ auth-ssh-credentials-private-key
+ auth-ssh-credentials-password-key
+
+ %make-auth-ssh-agent
+ auth-ssh-agent?))
+
+(define-record-type <auth-ssh-credentials>
+ (%make-auth-ssh-credentials public-key private-key)
+ auth-ssh-credentials?
+ (public-key auth-ssh-credentials-public-key)
+ (private-key auth-ssh-credentials-private-key))
+
+(define-record-type <auth-ssh-agent>
+ (%make-auth-ssh-agent)
+ auth-ssh-agent?)
diff --git a/git/clone.scm b/git/clone.scm
index 7f06528..a42c1f7 100644
--- a/git/clone.scm
+++ b/git/clone.scm
@@ -21,6 +21,7 @@
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
#:use-module (git bindings)
+ #:use-module (git fetch)
#:use-module (git structs)
#:use-module (git types)
#:use-module (git repository)
@@ -34,11 +35,17 @@
(define clone
(let ((proc (libgit2->procedure* "git_clone" '(* * * *))))
- (lambda* (url directory #:optional (clone-options (make-clone-options)))
- "Clones a remote repository found at URL into DIRECTORY.
-
-Returns the repository on success or throws an error on failure."
- (let ((out (make-double-pointer)))
+ (lambda* (url directory
+ #:optional (clone-options (make-clone-options))
+ #:key (auth-method #f))
+ "Clones a remote repository found at URL into DIRECTORY. An
+authentication method from (git auth) can be passed optionally if the
+repository is protected. Returns the repository on success or throws an error
+on failure."
+ (let* ((out (make-double-pointer))
+ (fetch-options
+ (clone-options-fetch-options clone-options)))
+ (init-fetch-options fetch-options auth-method)
(proc out
(string->pointer url)
(string->pointer directory)
diff --git a/git/fetch.scm b/git/fetch.scm
index da18bbe..1ac0bf8 100644
--- a/git/fetch.scm
+++ b/git/fetch.scm
@@ -1,5 +1,5 @@
;;; Guile-Git --- GNU Guile bindings of libgit2
-;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
+;;; Copyright © 2017, 2019 Mathieu Othacehe <address@hidden>
;;;
;;; This file is part of Guile-Git.
;;;
@@ -18,25 +18,37 @@
(define-module (git fetch)
#:use-module (system foreign)
+ #:use-module (git auth)
#:use-module (git bindings)
#:use-module (git cred)
#:use-module (git structs)
#:use-module (git types)
#:use-module (srfi srfi-26)
- #:export (make-fetch-options
+ #:export (init-fetch-options
+ make-fetch-options
fetch-init-options ;deprecated!
set-fetch-auth-with-ssh-agent!
+ set-fetch-auth-with-ssh-key!
set-fetch-auth-with-default-ssh-key!))
(define FETCH-OPTIONS-VERSION 1)
-(define make-fetch-options
- (let ((proc (libgit2->procedure* "git_fetch_init_options" `(*
,unsigned-int))))
- (lambda ()
- (let ((fetch-options (make-fetch-options-bytestructure)))
- (proc (fetch-options->pointer fetch-options) FETCH-OPTIONS-VERSION)
- fetch-options))))
+(define init-fetch-options
+ (let ((proc (libgit2->procedure* "git_fetch_init_options"
+ `(* ,unsigned-int))))
+ (lambda* (fetch-options #:optional auth-method)
+ (proc (fetch-options->pointer fetch-options) FETCH-OPTIONS-VERSION)
+ (cond
+ ((auth-ssh-credentials? auth-method)
+ (set-fetch-auth-with-ssh-key! fetch-options auth-method))
+ ((auth-ssh-agent? auth-method)
+ (set-fetch-auth-with-ssh-agent! fetch-options)))
+ fetch-options)))
+
+(define* (make-fetch-options #:optional auth-method)
+ (let ((fetch-options (make-fetch-options-bytestructure)))
+ (init-fetch-options fetch-options auth-method)))
(define fetch-init-options
;; Deprecated alias for compatibility with 0.2.
@@ -52,20 +64,37 @@
fetch-options
(cred-acquire-cb
(lambda (cred url username allowed payload)
- (cred-ssh-key-from-agent cred
- (pointer->string username))))))
+ (let ((username (if (eq? username %null-pointer)
+ ""
+ (pointer->string username))))
+ (cond
+ ;; If no username were specified in URL, we will be asked for
+ ;; one. Try with the current user login.
+ ((= allowed CREDTYPE-SSH-USERNAME)
+ (cred-username-new cred (getlogin)))
+ (else
+ (cred-ssh-key-from-agent cred username))))))))
-(define (set-fetch-auth-with-default-ssh-key! fetch-options)
- (let* ((home (getenv "HOME"))
- (ssh-dir (in-vicinity home ".ssh"))
- (pub-key (in-vicinity ssh-dir "id_rsa.pub"))
- (pri-key (in-vicinity ssh-dir "id_rsa")))
- (set-fetch-auth-callback
- fetch-options
- (cred-acquire-cb
- (lambda (cred url username allowed payload)
- (cred-ssh-key-new cred
- (pointer->string username)
- pub-key
- pri-key
- ""))))))
+(define* (set-fetch-auth-with-ssh-key! fetch-options
+ auth-ssh-credentials)
+ (set-fetch-auth-callback
+ fetch-options
+ (cred-acquire-cb
+ (lambda (cred url username allowed payload)
+ (cond
+ ;; Same as above.
+ ((= allowed CREDTYPE-SSH-USERNAME)
+ (cred-username-new cred (getlogin)))
+ (else
+ (let* ((pri-key-file
+ (auth-ssh-credentials-private-key auth-ssh-credentials))
+ (pub-key-file
+ (auth-ssh-credentials-public-key auth-ssh-credentials))
+ (username (if (eq? username %null-pointer)
+ ""
+ (pointer->string username))))
+ (cred-ssh-key-new cred
+ username
+ pub-key-file
+ pri-key-file
+ ""))) )))))
diff --git a/git/remote.scm b/git/remote.scm
index b889dd2..e39aaf6 100644
--- a/git/remote.scm
+++ b/git/remote.scm
@@ -21,6 +21,7 @@
#:use-module (srfi srfi-9 gnu)
#:use-module (system foreign)
#:use-module (git bindings)
+ #:use-module (git fetch)
#:use-module (git structs)
#:use-module (git types)
#:export (remote-name
@@ -99,13 +100,15 @@
(define remote-fetch
(let ((proc (libgit2->procedure* "git_remote_fetch" '(* * * *))))
- (lambda* (remote #:key (reflog-message "") (fetch-options #f))
+ (lambda* (remote #:key
+ (reflog-message "")
+ (fetch-options (make-fetch-options))
+ (auth-method #f))
+ (init-fetch-options fetch-options auth-method)
(proc (remote->pointer remote)
;; FIXME https://libgit2.github.com/libgit2/#HEAD/type/git_strarray
%null-pointer
- (if fetch-options
- (fetch-options->pointer fetch-options)
- %null-pointer)
+ (fetch-options->pointer fetch-options)
(string->pointer reflog-message)))))
;; FIXME https://libgit2.github.com/libgit2/#HEAD/group/reset/git_reset_default
diff --git a/git/structs.scm b/git/structs.scm
index e854d51..9e1597a 100644
--- a/git/structs.scm
+++ b/git/structs.scm
@@ -53,7 +53,7 @@
fetch-options-download-tags set-fetch-options-download-tags!
set-fetch-options-callbacks! set-remote-callbacks-credentials!
- make-clone-options-bytestructure clone-options->pointer
clone-options-fetch-options
+ make-clone-options-bytestructure clone-options-bytestructure
clone-options->pointer clone-options-fetch-options
make-describe-options-bytestructure describe-options->pointer
describe-options->bytestructure
set-describe-options-max-candidates-tag!
set-describe-options-strategy!
@@ -466,8 +466,15 @@ tag policy in FETCH-OPTIONS."
(bytestructure->pointer (clone-options-bytestructure clone-options)))
(define (clone-options-fetch-options clone-options)
- (%make-fetch-options
- (bytestructure-ref (clone-options-bytestructure clone-options)
'fetch-opts)))
+ (let* ((fetch-options-bs
+ (bytestructure-ref
+ (clone-options-bytestructure clone-options) 'fetch-opts))
+ (fetch-options-offset (bytestructure-offset fetch-options-bs))
+ (fetch-options-pointer (bytevector->pointer
+ (bytestructure-bytevector fetch-options-bs)
+ fetch-options-offset)))
+ (%make-fetch-options
+ (pointer->bytestructure fetch-options-pointer %fetch-options))))
;; git remote head
diff --git a/guix.scm b/guix.scm
index aad396f..e388296 100644
--- a/guix.scm
+++ b/guix.scm
@@ -7,6 +7,7 @@
(gnu packages compression)
(gnu packages guile)
(gnu packages pkg-config)
+ (gnu packages ssh)
(gnu packages texinfo)
(gnu packages tls)
(gnu packages version-control))
@@ -20,7 +21,9 @@
`(("autoconf" ,autoconf)
("automake" ,automake)
("pkg-config" ,pkg-config)
- ("texinfo" ,texinfo)))
+ ("texinfo" ,texinfo)
+ ("openssh" ,openssh)
+ ("git" ,git)))
(inputs
`(("guile" ,guile-2.2)
("libgit2" ,libgit2)
diff --git a/tests/.ssh/id_rsa_client b/tests/.ssh/id_rsa_client
new file mode 100644
index 0000000..7e16000
--- /dev/null
+++ b/tests/.ssh/id_rsa_client
@@ -0,0 +1,27 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIIEpAIBAAKCAQEA6kWDytF6KQO46BPJj7nJQfATeae2l/U/lyE3HuZhCg3sitCN
+Lf8GaICsHvPT1SpMHnfjgqsT/ZbYhIXvfbFjDKimNru9d8TwcOynUR/w3+eIOvKl
+EVzp+nYfCUOahe0qKLAm+21iYt1UinhfkqpnnF2fa9Zhf+CROIMZCjX9/Fhd2WV5
+1YMsD3NUiRUK4Xx7gnm3pSAFW9EldqVozB2JwydCXx/WboU7wJqtcUZbxeMK27+D
+DRu4Kufnf11bJTb6+9dSEtKuKhahKbcRpQUlcgReCul8x8M8ufskkBatxMgyUuC1
+ey8gv1fC2FvQ6ct3skBFO8B3cIF2nYhb6+s75wIDAQABAoIBAQDU7WXB++8aRCXV
+2dZDactAwSISWpsdNm0bwbbFwQLGDq3F5ZPMEJUUeo72ews4Hf+dWb5RT4kV3frh
+SJLKHWY3ZTndWXn11+vp106j73IRL/GkElJxm4+Wc7H1y5owy8Sbwq9LqrnXve9P
+A+Vp+rO9bWKusuVfQw763DzwCO7WYQWHVfS/XpSJW3pgofuTLq8Esd/AMRrB0H3m
+EQ4zd+HR2f+cCux0geuOS0Yt3Ki7h6JKs+Nzhas26FBpyOTYJEQaJQhY5NNHO2p7
+ulk6H6AHHajgW9RBzNLXqpQuGR1ISNSZKvXVzPo/LxK8lPNTFY2iDmyzzjoPD51O
+Y05zFHEhAoGBAPfel/Nlz2nu9hVtTCMrm/4wFKzlTSQ1c2psUsOzYcr1PmmM0yrv
+IPnOZ0HbyKr9QomOQsgAzZm/iPS9Q7Owxzy1IrFHK+H68c853cod9N+L2pIkouSr
+CYUafjsdc+y+eCzYmX4pJMCU4E/AipJXSOUSWiv5ac7KAtzdio9W9nHJAoGBAPH0
+vJMOtGuqO3DBdi5aF8z/DH9sqJXkaoE5e3a9IXWC91L42RnmmKWeYet/VjV2kGgO
+ZTrZPjbGz9pqUTir5gZmOqFEwdjPiqb68SUgV/V8I5cu5WtZMLGLOxaSQMj6Y9+L
+sdAyZ9NnuJqXQ6jdPFGO7CWKhzckIu+/fX++tZgvAoGBAMYjZYvngpnHr2cJa6dh
+oNzcSmq7EaM0JwKXfMF7j1zSFgYB0Hutk8qct+Xpbstgj+OtmKyQF8ojVbNt58So
+N1vL3+OeZPHLy6g/NY/vymM4RIw2RRBNuNpxhx5yOMyypRYUPv6enQZk+7pEy4CX
+zWlv9izYvz/SM9+iKLTUa0QhAoGAI4flCVNne0gMYoqGaFgilp/9ndi/CQP5//AJ
+CW7Msw0AdNbGSt9qGygfCQ4yArfejOlQREwSrsiTTWe/dasIpHfutC/8p3IS0mKX
+dvRA9nO8Zj8kwZbfZ7MigjYH/XuHnxRMkF5WkNzyZwE/llSmvvNWCk1Ffft4heyA
+6XmAAVECgYBGNlXFaSgwDXX00LkRCSaC5zT7iKn6b7AJS+YT5lxDnaJZcM2C+2LG
+fF91Jxmvbhv5Fc3V2jzb24ypS8Y8GgV2C6ki8GzQnzZu5gtm0hwGItFPeZYgttyp
+g6I/2tV/hgctBOQQxKO2ZC0bJFgFZxHP3sPrFQFXyuEjHoem0QYwkQ==
+-----END RSA PRIVATE KEY-----
diff --git a/tests/.ssh/id_rsa_client.pub b/tests/.ssh/id_rsa_client.pub
new file mode 100644
index 0000000..fc0f530
--- /dev/null
+++ b/tests/.ssh/id_rsa_client.pub
@@ -0,0 +1 @@
+ssh-rsa
AAAAB3NzaC1yc2EAAAADAQABAAABAQDqRYPK0XopA7joE8mPuclB8BN5p7aX9T+XITce5mEKDeyK0I0t/wZogKwe89PVKkwed+OCqxP9ltiEhe99sWMMqKY2u713xPBw7KdRH/Df54g68qURXOn6dh8JQ5qF7SoosCb7bWJi3VSKeF+SqmecXZ9r1mF/4JE4gxkKNf38WF3ZZXnVgywPc1SJFQrhfHuCebelIAVb0SV2pWjMHYnDJ0JfH9ZuhTvAmq1xRlvF4wrbv4MNG7gq5+d/XVslNvr711IS0q4qFqEptxGlBSVyBF4K6XzHwzy5+ySQFq3EyDJS4LV7LyC/V8LYW9Dpy3eyQEU7wHdwgXadiFvr6zvn
mathieu@meru
diff --git a/tests/.ssh/id_rsa_server b/tests/.ssh/id_rsa_server
new file mode 100644
index 0000000..192b703
--- /dev/null
+++ b/tests/.ssh/id_rsa_server
@@ -0,0 +1,27 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIIEogIBAAKCAQEAzBpyIyno1lg4Qn4FuutRaP+2r8HTSjDij1hzj6zOBhyuGMG1
+C8cK9gkEbDsnKU4J3e4boZ/AYvMe/oXcsVq20VvWelOcrYtZAa+oi+RdXWQOzxCg
+5VJRl5L+bon3uuNTRLicj2a0F1fcskqgget1XzkSiOyUFKA+lwjk8UScm2s8teaI
+yTNJTkZiQ1JO3H5oHTgY0fV1tst7RS5HOZcH3CQXCBHm0/ss4d3Pn3QO9ahsO3sD
+flGtXJdfbf/Twjg0CeZQBhb9x9D0s8RC37k2eJprU6yhhJzsGdMeH2xfrARWOm9P
+EzcTRWGLPuAR+wG/OpHdk06SYkF9T/SXqcZ2fQIDAQABAoIBABJQuTdQlnVNm1bU
+Kj14ymhqsgEZmpVIx7vnSw90iVRhFHpiP5Xb+a7UZlI0CLKbLyV8LXyWclQuzvQ2
+HPTJWCh3XkrB4AhuvcD5+1z6VCqCRRXtvxJ1DZ9VcIGI3fMmXR2Il3wC0lxZ5RMW
+wUqHT5QI8hHZcPxc2OECylCgQJFtqA2UTs/KufT1YEsSWoPQ+zwUGgOtA4CV0W11
+3z2OYrBwtMAsnI6qS5ptUQkVAqZl/kL+1Yo6WaFdX49fcUo/9nUUCDYT5hd8aWH7
+aQ9DcLyeNhqnBwFkPd6Pa7fgMVNUYODkJglt0VFWPo7DOZ961OKCIHMLhEnwRt8g
+I20usSECgYEA6xA6zIG+6Rkpz8VeWmkWYNucEuiq78ZvRLF08Y5q46tB3tDMo275
+UFvchiE1OCIUY+Gqc8bCq7lAmD0BJQYRNeqt7xxmVKuYANhCfoT/zRxZv02P9Pjs
+lQoNUFnbXMFW0NZ9JYutkK1Coy/M7lbNRP5n2fl1Hh1izr3eSGFCv6kCgYEA3khI
+g3fWJ7gfWOHepKckVkK6At+2mbgP3GoNfb27hL+DqgIxE7eXEhPUTOonhMxTA3nZ
+PnzBHZjC0qac4qLZsjQuLhClB9u7jF6Vs7JUEt0ajUELwXchxJd8kv5KOQuZcdVt
+cT3kBSJN1h/MvAJiV50mAtp+M2O1P+ZcXnYV1LUCgYA4mFC/2mE/uCpD9w4vkGut
+6FIcj15QmqNBk8RHQHXl2N7kKbuLgfWO7n8a4DXzDOmB3txuQaWvOMwfm1iCNILC
+S32TO3A75JCVa3wfACCinrfRAnitj51OiPwJo4jYPUiMwYeiGY4xbjXEGocpv0Zu
+3R3d8lzLYmHeywIQxTIP+QKBgAWiNVxHpEDbdMfu6ZKovc4F4OsDuoAI3zYJ5g+i
+yGbj57VeWtoSFB0cLYxJfvjpqMz0wKHJzacvYPivylggIn5WvjjiqRwa4JT9LLQi
+N+lGe07LMD4WA+AUqs6a7Uym05vD+gMdu3K53NkpcynssYtg6z61RO+OfmCBOSQX
+wBPlAoGADTtG5KbjnOBa+7DcdbBKz5lHxutJkjXKnFFKsLeQcKkmF9UEs13XoTTa
+dMdolZBk/MmWEwVLFZmC0Gaio4iYMI4KcVMbKM357HnOqKt8mRNi4mGxHIxGUtGQ
+I9jDlrUelBFWHdBEUHUzmtY96ye6y37SD6iCydT3prj4kjpWwyY=
+-----END RSA PRIVATE KEY-----
diff --git a/tests/clone.scm b/tests/clone.scm
new file mode 100644
index 0000000..6ec7320
--- /dev/null
+++ b/tests/clone.scm
@@ -0,0 +1,68 @@
+;;; Guile-Git --- GNU Guile bindings of libgit2
+;;; Copyright © 2019 Mathieu Othacehe <address@hidden>
+;;;
+;;; This file is part of Guile-Git.
+;;;
+;;; Guile-Git is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Guile-Git 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
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Guile-Git. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests clone)
+ #:use-module (git)
+ #:use-module (tests helpers)
+ #:use-module (tests ssh)
+ #:use-module (srfi srfi-64))
+
+(test-begin "clone")
+
+(libgit2-init!)
+
+(define (make-ssh-url dir port)
+ (format #f "ssh://localhost:~a/~a" port dir))
+
+(define ssh-server-port 8899)
+
+(define (clone-test directory auth-method)
+ (let* ((repo-dir (in-vicinity (getcwd) directory))
+ (clone-dir (in-vicinity repo-dir "out")))
+ (clone (make-ssh-url repo-dir ssh-server-port)
+ clone-dir
+ #:auth-method auth-method)
+ (let* ((repository (repository-open clone-dir))
+ (oid (reference-target (repository-head repository))))
+ (oid->string (commit-id (commit-lookup repository oid))))))
+
+(with-sshd-server ssh-server-port
+ (with-repository "simple-bare" directory
+ (test-equal "clone-auth-ssh-credentials"
+ "3f848a1a52416ac99a5c5bf2e6bd55eb7b99d55b"
+ (clone-test directory (make-client-ssh-auth))))
+
+ (with-repository "simple-bare" directory
+ (test-equal "clone-auth-ssh-agent"
+ "3f848a1a52416ac99a5c5bf2e6bd55eb7b99d55b"
+ (with-ssh-agent
+ (clone-test directory (%make-auth-ssh-agent)))))
+
+ (with-repository "simple-bare" directory
+ (test-assert "clone-and-fetch-auth-ssh-credentials"
+ (let* ((auth (make-client-ssh-auth))
+ (do-clone (clone-test directory auth))
+ (clone-dir (in-vicinity directory "out"))
+ (repository (repository-open clone-dir))
+ (remote (remote-lookup repository "origin")))
+ (remote-fetch remote #:auth-method auth)
+ #t))))
+
+(libgit2-shutdown!)
+
+(test-end)
diff --git a/tests/ssh.scm.in b/tests/ssh.scm.in
new file mode 100644
index 0000000..ef71524
--- /dev/null
+++ b/tests/ssh.scm.in
@@ -0,0 +1,115 @@
+;;; Guile-Git --- GNU Guile bindings of libgit2
+;;; Copyright © 2019 Mathieu Othacehe <address@hidden>
+;;;
+;;; This file is part of Guile-Git.
+;;;
+;;; Guile-Git is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Guile-Git 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
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Guile-Git. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests ssh)
+ #:use-module (git auth)
+ #:use-module (tests helpers)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:export (with-sshd-server
+ with-ssh-agent
+ make-client-ssh-auth))
+
+(define sshd "@SSHD@")
+(define %ssh-dir (path-join (getenv "srcdir") "/tests/.ssh"))
+(define (in-ssh-folder . args)
+ (apply path-join %ssh-dir args))
+
+(define (start-sshd port)
+ (define (write-authorized-keys file)
+ (call-with-output-file file
+ (lambda (port)
+ ;; We need to pass PATH so that git binary (git-upload-pack) can be
+ ;; found from sshd.
+ (format port "environment=\"PATH=~a\" ~a"
+ (getenv "PATH")
+ (call-with-input-file (in-ssh-folder "id_rsa_client.pub")
+ read-string)))))
+
+ (define (write-sshd-conf conf authorized-keys)
+ (call-with-output-file conf
+ (lambda (port)
+ (format port "AuthorizedKeysFile ~a
+PidFile ~a
+PermitUserEnvironment yes~%"
+ authorized-keys
+ (in-ssh-folder "sshd_pid")))))
+
+ (let ((sshd-conf (in-ssh-folder "sshd.conf"))
+ (sshd-key (in-ssh-folder "id_rsa_server"))
+ (authorized-keys (in-ssh-folder "authorized_keys")))
+ (write-authorized-keys authorized-keys)
+ (write-sshd-conf sshd-conf authorized-keys)
+ (system* sshd "-p" (number->string port) "-f" sshd-conf "-h" sshd-key)))
+
+(define (stop-sshd)
+ (define (read-pid port)
+ (string-trim-right (read-string port) #\newline))
+
+ (let ((pid
+ (call-with-input-file (in-ssh-folder "sshd_pid")
+ read-pid)))
+ (system* "kill" pid)))
+
+(define-syntax-rule (with-sshd-server port body ...)
+ (dynamic-wind
+ (lambda ()
+ (start-sshd port))
+ (lambda ()
+ body ...)
+ (lambda ()
+ (stop-sshd))))
+
+(define %ssh-auth-sock-regexp
+ (make-regexp "SSH_AUTH_SOCK=(.*); export SSH_AUTH_SOCK;"))
+
+(define %ssh-agent-pid-regexp
+ (make-regexp "SSH_AGENT_PID=(.*); export SSH_AGENT_PID;"))
+
+(define (start-ssh-agent)
+ (let* ((p (open-input-pipe "ssh-agent -s"))
+ (ssh-auth-sock-data (read-line p))
+ (ssh-agent-pid-data (read-line p))
+ (sock
+ (let ((match (regexp-exec %ssh-auth-sock-regexp
+ ssh-auth-sock-data)))
+ (match:substring match 1)))
+ (pid (let ((match (regexp-exec %ssh-agent-pid-regexp
+ ssh-agent-pid-data)))
+ (match:substring match 1))))
+ (setenv "SSH_AUTH_SOCK" sock)
+ pid))
+
+(define (ssh-agent-add-client-key)
+ (system* "ssh-add" (in-ssh-folder "id_rsa_client")))
+
+(define-syntax-rule (with-ssh-agent body ...)
+ (let ((pid (start-ssh-agent)))
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (ssh-agent-add-client-key)
+ body ...)
+ (lambda ()
+ (system* "kill" pid)))))
+
+(define (make-client-ssh-auth)
+ (%make-auth-ssh-credentials
+ (in-ssh-folder "id_rsa_client.pub")
+ (in-ssh-folder "id_rsa_client")))
--
2.24.0
Ludovic Courtès writes:
> Hi Mathieu,
>
> Mathieu Othacehe <address@hidden> skribis:
>
>>> I think there are small modifications to do to (guix git) and (git
>>> clone).
>>
>> I did integrate a part of libgit2 ssh authentification mechanism in
>> Guile-Git in 2017. You can find it in (git fetch) module.
>>
>> It is currently broken, because of a regression. See
>> https://lists.gnu.org/archive/html/guix-devel/2019-11/msg00415.html.
>
> Oh I missed that message of yours. Do you have a complete example using
> that functionality that I could use as a test?
>
> It would be great to have a test for that in Guile-Git. We could use
> Guile-SSH, when it’s available, to spawn an SSH server.
>
>> What would be missing to have support for authenticated Git repositories
>> as Cuirass inputs is:
>>
>> * Fix the regression mentionned above.
>>
>> * Add support for a fetch-options argument in clone method of (git clone).
>>
>> * In (guix git), "latest-repository-commit" method would take parameters
>> to setup ssh authentication (such as ssh private key path at least) and
>> pass them to "fetch" and "clone" methods of Guile-Git.
>>
>> * Finally in Cuirass, the ssh authentication parameters could be
>> specified in the specification file (maybe for each input?) and passed
>> to "latest-repository-commit" method accordingly.
>
> I’d like to see that happen!
>
> Thanks,
> Ludo’.
- bug#38320: Cuirass: Allow to use authenticated Git repositories as inputs,
Mathieu Othacehe <=