From mboxrd@z Thu Jan 1 00:00:00 1970 From: Mathieu Othacehe Subject: bug#38320: Cuirass: Allow to use authenticated Git repositories as inputs Date: Mon, 09 Dec 2019 17:41:52 +0100 Message-ID: <87h829sb73.fsf@gmail.com> References: <875zjc8ciz.fsf@lassieur.org> <878so4t6mk.fsf@gmail.com> <87r21v9cmi.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:470:142:3::10]:37120) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ieM7l-0003Kp-KN for bug-guix@gnu.org; Mon, 09 Dec 2019 11:43:08 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ieM7i-0008Tl-8c for bug-guix@gnu.org; Mon, 09 Dec 2019 11:43:05 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:48376) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1ieM7i-0008Tf-2s for bug-guix@gnu.org; Mon, 09 Dec 2019 11:43:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ieM7i-0000B6-0n for bug-guix@gnu.org; Mon, 09 Dec 2019 11:43:02 -0500 Sender: "Debbugs-submit" Resent-Message-ID: In-reply-to: <87r21v9cmi.fsf@gnu.org> List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guix-bounces+gcggb-bug-guix=m.gmane.org@gnu.org Sender: "bug-Guix" To: Ludovic =?UTF-8?Q?Court=C3=A8s?= , =?UTF-8?Q?Cl=C3=A9ment?= Lassieur Cc: 38320@debbugs.gnu.org, Erik Edrosa --=-=-= Content-Type: text/plain 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 --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-Add-ssh-authentication-support.patch Content-Transfer-Encoding: quoted-printable >From ae3c5a9851b02e78096963616d4e2f999119fc4d Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe 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 =3D \ 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 =3D \ =20 TESTS =3D \ 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" =3D "x"], [ ]) AC_SUBST([LIBGIT2_LIBDIR]) =20 -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]) =20 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 =C2=A9 2019 Mathieu Othacehe +;;; +;;; 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 . + +(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 + (%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 + (%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 @@ =20 (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 e= rror +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 =C2=A9 2017 Mathieu Othacehe +;;; Copyright =C2=A9 2017, 2019 Mathieu Othacehe ;;; ;;; This file is part of Guile-Git. ;;; @@ -18,25 +18,37 @@ =20 (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) =20 - #: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!)) =20 (define FETCH-OPTIONS-VERSION 1) =20 -(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))) =20 (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. + ((=3D allowed CREDTYPE-SSH-USERNAME) + (cred-username-new cred (getlogin))) + (else + (cred-ssh-key-from-agent cred username)))))))) =20 -(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. + ((=3D 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 @@ =20 (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_str= array %null-pointer - (if fetch-options - (fetch-options->pointer fetch-options) - %null-pointer) + (fetch-options->pointer fetch-options) (string->pointer reflog-message))))) =20 ;; FIXME https://libgit2.github.com/libgit2/#HEAD/group/reset/git_reset_de= fault 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! =20 - make-clone-options-bytestructure clone-options->pointer clone-= options-fetch-options + make-clone-options-bytestructure clone-options-bytestructure c= lone-options->pointer clone-options-fetch-options =20 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))) =20 (define (clone-options-fetch-options clone-options) - (%make-fetch-options - (bytestructure-ref (clone-options-bytestructure clone-options) 'fetch-o= pts))) + (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-b= s) + fetch-options-offset))) + (%make-fetch-options + (pointer->bytestructure fetch-options-pointer %fetch-options)))) =20 ;; git remote head =20 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=3D=3D +-----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+XIT= ce5mEKDeyK0I0t/wZogKwe89PVKkwed+OCqxP9ltiEhe99sWMMqKY2u713xPBw7KdRH/Df54g68= qURXOn6dh8JQ5qF7SoosCb7bWJi3VSKeF+SqmecXZ9r1mF/4JE4gxkKNf38WF3ZZXnVgywPc1SJ= FQrhfHuCebelIAVb0SV2pWjMHYnDJ0JfH9ZuhTvAmq1xRlvF4wrbv4MNG7gq5+d/XVslNvr711I= S0q4qFqEptxGlBSVyBF4K6XzHwzy5+ySQFq3EyDJS4LV7LyC/V8LYW9Dpy3eyQEU7wHdwgXadiF= vr6zvn 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=3D +-----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 =C2=A9 2019 Mathieu Othacehe +;;; +;;; 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 . + +(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 =C2=A9 2019 Mathieu Othacehe +;;; +;;; 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 . + +(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=3D\"PATH=3D~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=3D(.*); export SSH_AUTH_SOCK;")) + +(define %ssh-agent-pid-regexp + (make-regexp "SSH_AGENT_PID=3D(.*); 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"))) --=20 2.24.0 --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hi Mathieu, > > Mathieu Othacehe 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=E2=80=99s 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=E2=80=99d like to see that happen! > > Thanks, > Ludo=E2=80=99. --=-=-=--