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 = \ 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 +;;; +;;; 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 @@ (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 +;;; Copyright © 2017, 2019 Mathieu Othacehe ;;; ;;; 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 +;;; +;;; 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 © 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=\"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