Hello community, here is the log from the commit of package guile-git for openSUSE:Factory checked in at 2020-11-26 23:14:48 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/guile-git (Old) and /work/SRC/openSUSE:Factory/.guile-git.new.5913 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "guile-git" Thu Nov 26 23:14:48 2020 rev:5 rq:850989 version:0.4.0 Changes: -------- --- /work/SRC/openSUSE:Factory/guile-git/guile-git.changes 2020-01-14 21:13:57.650947661 +0100 +++ /work/SRC/openSUSE:Factory/.guile-git.new.5913/guile-git.changes 2020-11-26 23:15:55.169062078 +0100 @@ -1,0 +2,8 @@ +Fri Nov 6 17:29:36 UTC 2020 - Jonathan Brielmaier <jbrielma...@opensuse.org> + +- Update to version 0.4.0: + * Support for HTTP and HTTPS proxies + * Support for progress report + * Fix typo that made repository-index and repository-refdb unusable + +------------------------------------------------------------------- Old: ---- guile-git-v0.3.0.tar.gz New: ---- guile-git-v0.4.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ guile-git.spec ++++++ --- /var/tmp/diff_new_pack.Ms3jme/_old 2020-11-26 23:15:55.813062578 +0100 +++ /var/tmp/diff_new_pack.Ms3jme/_new 2020-11-26 23:15:55.813062578 +0100 @@ -17,7 +17,7 @@ Name: guile-git -Version: 0.3.0 +Version: 0.4.0 Release: 0 Summary: Guile bindings of libgit2 License: GPL-3.0-or-later ++++++ guile-git-v0.3.0.tar.gz -> guile-git-v0.4.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/Makefile.am new/guile-git-v0.4.0/Makefile.am --- old/guile-git-v0.3.0/Makefile.am 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/Makefile.am 2020-10-22 09:32:23.000000000 +0200 @@ -1,7 +1,7 @@ # Guile-Git --- GNU Guile bindings of libgit2 # Copyright © 2016-2018 Erik Edrosa <erik.edr...@gmail.com> # Copyright © 2016, 2017 Amirouche Boubekki <amirou...@hypermove.net> -# Copyright © 2017, 2018, 2019 Ludovic Courtès <l...@gnu.org> +# Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <l...@gnu.org> # Copyright © 2017 Mathieu Othacehe <m.othac...@gmail.com> # # This file is part of Guile-Git. @@ -81,6 +81,7 @@ tests/commit.scm \ tests/describe.scm \ tests/oid.scm \ + tests/proxy.scm \ tests/reference.scm \ tests/repository.scm \ tests/reset.scm \ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/NEWS new/guile-git-v0.4.0/NEWS --- old/guile-git-v0.3.0/NEWS 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/NEWS 2020-10-22 09:32:23.000000000 +0200 @@ -9,6 +9,31 @@ notice and this notice are preserved. This file is offered as-is, without any warranty. +* Changes in 0.4.0 (since 0.3.0) + +** New Functionality + +*** Support for HTTP and HTTPS proxies + +One can now specify the HTTP and HTTPS via the ~#:proxy-url~ parameter +of ~make-fetch-options~. Those fetch options must then be passed to +~fetch~, or they can be added to the clone options passed to ~clone~. + +*** Support for progress report + +Clones and fetches can take some time and you may want to tell users +what’s going on. To help with that, ~make-fetch-options~ now takes a +~#:transfer-progress~ option; it should be either ~#f~ or a one-argument +procedure that will be called with an ~<indexer-progress>~ record every +time progress is made. This record contains information about the total +number of objects being processed, the number of objects already +retrieved, and the number of objects already indexed. + +** Bug Fixes + +*** Fix typo that made ~repository-index~ and ~repository-refdb~ unusable + + * Changes in 0.3.0 (since 0.2.0) ** New Functionality diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/configure.ac new/guile-git-v0.4.0/configure.ac --- old/guile-git-v0.3.0/configure.ac 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/configure.ac 2020-10-22 09:32:23.000000000 +0200 @@ -1,6 +1,6 @@ dnl Guile-Git --- GNU Guile bindings of libgit2 dnl Copyright © 2016-2018 Erik Edrosa <erik.edr...@gmail.com> -dnl Copyright © 2017, 2019 Ludovic Courtès <l...@gnu.org> +dnl Copyright © 2017, 2019, 2020 Ludovic Courtès <l...@gnu.org> dnl Copyright © 2019 Mathieu Othacehe <m.othac...@gmail.com> dnl dnl This file is part of Guile-Git. @@ -18,7 +18,7 @@ dnl You should have received a copy of the GNU General Public License dnl along with Guile-Git. If not, see <http://www.gnu.org/licenses/>. -AC_INIT([Guile-Git], [0.3.0], [], [], [https://gitlab.com/guile-git/guile-git/]) +AC_INIT([Guile-Git], [0.4.0], [], [], [https://gitlab.com/guile-git/guile-git/]) AC_CONFIG_SRCDIR(git) AC_CONFIG_AUX_DIR([build-aux]) AC_CONFIG_MACRO_DIR([m4]) @@ -35,7 +35,7 @@ GUILE_MODULE_REQUIRED([bytestructures guile]) -PKG_CHECK_MODULES([LIBGIT2], [libgit2]) +PKG_CHECK_MODULES([LIBGIT2], [libgit2 >= 0.28.0]) PKG_CHECK_VAR([LIBGIT2_LIBDIR], [libgit2], [libdir]) AC_MSG_CHECKING([libgit2 library path]) AS_IF([test "x$LIBGIT2_LIBDIR" = "x"], [ @@ -43,6 +43,17 @@ ]) AC_SUBST([LIBGIT2_LIBDIR]) +dnl Does the 'git_remote_callbacks' struct have a 'resolve_url' field? +dnl It's missing in libgit2 0.28.5, added in 1.0. +AC_CHECK_MEMBER([git_remote_callbacks.resolve_url], [], [], + [[#include <git2.h>]]) +if test "x$ac_cv_member_git_remote_callbacks_resolve_url" = "xyes"; then + HAVE_REMOTE_CALLBACKS_RESOLVE_URL="#true" +else + HAVE_REMOTE_CALLBACKS_RESOLVE_URL="#false" +fi +AC_SUBST([HAVE_REMOTE_CALLBACKS_RESOLVE_URL]) + dnl Those binaries are required for ssh authentication tests. AC_PATH_PROG([SSHD], [sshd]) AC_PATH_PROG([SSH_AGENT], [ssh-agent]) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/doc/guile-git.texi new/guile-git-v0.4.0/doc/guile-git.texi --- old/guile-git-v0.3.0/doc/guile-git.texi 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/doc/guile-git.texi 2020-10-22 09:32:23.000000000 +0200 @@ -80,9 +80,9 @@ @itemize @item -@url{https://www.gnu.org/software/guile/, GNU Guile} +@url{https://www.gnu.org/software/guile/, GNU Guile} 2.x or 3.0 @item -@url{https://libgit2.org/, libgit2} +@url{https://libgit2.org/, libgit2} version 0.28.x or 1.0.x @item @url{https://github.com/TaylanUB/scheme-bytestructures, scheme-bytestructures} @end itemize diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/git/commit.scm new/guile-git-v0.4.0/git/commit.scm --- old/guile-git-v0.3.0/git/commit.scm 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/git/commit.scm 2020-10-22 09:32:23.000000000 +0200 @@ -77,13 +77,13 @@ (define commit-amend (let ((proc (libgit2->procedure* "git_commit_amend" '(* * * * * * * *)))) - (lambda (id commit update-ref author commiter + (lambda (id commit update-ref author committer message-encoding message tree) (proc (oid->pointer id) (commit->pointer commit) (string->pointer update-ref) (signature->pointer author) - (signature->pointer commiter) + (signature->pointer committer) (string->pointer message-encoding) (string->pointer message) (tree->pointer tree))))) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/git/config.scm.in new/guile-git-v0.4.0/git/config.scm.in --- old/guile-git-v0.3.0/git/config.scm.in 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/git/config.scm.in 2020-10-22 09:32:23.000000000 +0200 @@ -18,7 +18,12 @@ ;;; along with Guile-Git. If not, see <http://www.gnu.org/licenses/>. (define-module (git config) - #:export (%libgit2)) + #:export (%libgit2 + %have-remote-callbacks-resolve-url?)) (define %libgit2 "@LIBGIT2_LIBDIR@/libgit2") + +(define %have-remote-callbacks-resolve-url? + ;; True if the 'git_remote_callbacks' struct has a 'resolve_url' field. + @HAVE_REMOTE_CALLBACKS_RESOLVE_URL@) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/git/fetch.scm new/guile-git-v0.4.0/git/fetch.scm --- old/guile-git-v0.3.0/git/fetch.scm 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/git/fetch.scm 2020-10-22 09:32:23.000000000 +0200 @@ -37,14 +37,38 @@ (define make-fetch-options (let ((proc (libgit2->procedure* "git_fetch_init_options" `(* ,unsigned-int)))) - (lambda* (#:optional auth-method) + (lambda* (#:optional auth-method + #:key + proxy-url (proxy-type (if proxy-url 'specified 'none)) + transfer-progress) + "Return a <fetch-options> record. When AUTH-METHOD is true, it must be +an object as returned by '%make-auth-ssh-agent' or +'%make-auth-ssh-credentials'. When TRANSFER-PROGRESS is true, it must be a +one-argument procedure. TRANSFER-PROGRESS is called periodically and passed +an <indexer-progress> record; when TRANSFER-PROGRESS returns #false, +transfers are canceled. + +When PROXY-URL is true, it is the URL of an HTTP/HTTPS proxy to use. +PROXY-TYPE is one of 'none, 'specified, or 'auto. The default is 'specified +when PROXY-URL is true and 'none when PROXY-URL is false. Setting it to +'auto enables proxy detection based on the Git configuration." (let ((fetch-options (make-fetch-options-bytestructure))) (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))) + + (set-fetch-options-proxy-type! fetch-options proxy-type) + (when proxy-url + (set-fetch-options-proxy-url! fetch-options proxy-url)) + + (when transfer-progress + (set-fetch-options-transfer-progress! fetch-options + transfer-progress)) + fetch-options)))) (define fetch-init-options @@ -52,7 +76,7 @@ make-fetch-options) (define (set-fetch-auth-callback fetch-options callback) - (let ((callbacks (fetch-options-callbacks fetch-options))) + (let ((callbacks (fetch-options-remote-callbacks fetch-options))) (set-remote-callbacks-credentials! callbacks (pointer-address callback)))) @@ -95,3 +119,16 @@ pub-key-file pri-key-file ""))) ))))) + +(define (set-fetch-options-transfer-progress! fetch-options + transfer-progress) + (let ((callbacks (fetch-options-remote-callbacks fetch-options))) + (set-remote-callbacks-transfer-progress! callbacks transfer-progress))) + +(define (set-fetch-options-proxy-type! fetch-options type) + (let ((proxy (fetch-options-proxy-options fetch-options))) + (set-proxy-options-type! proxy type))) + +(define (set-fetch-options-proxy-url! fetch-options url) + (let ((proxy (fetch-options-proxy-options fetch-options))) + (set-proxy-options-url! proxy url))) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/git/repository.scm new/guile-git-v0.4.0/git/repository.scm --- old/guile-git-v0.3.0/git/repository.scm 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/git/repository.scm 2020-10-22 09:32:23.000000000 +0200 @@ -140,7 +140,7 @@ (define repository-index (let ((proc (libgit2->procedure* "git_repository_index" '(* *)))) (lambda (repository) - (let ((out ((make-double-pointer)))) + (let ((out (make-double-pointer))) (proc (repository->pointer repository)) (pointer->index (dereference-pointer out)))))) @@ -267,7 +267,7 @@ (define repository-refdb (let ((proc (libgit2->procedure* "git_repository_refdb" `(* *)))) (lambda (repository) - (let ((out ((make-double-pointer)))) + (let ((out (make-double-pointer))) (proc out (repository->pointer repository)) (pointer->refdb (dereference-pointer out)))))) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/git/structs.scm new/guile-git-v0.4.0/git/structs.scm --- old/guile-git-v0.3.0/git/structs.scm 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/git/structs.scm 2020-10-22 09:32:23.000000000 +0200 @@ -1,7 +1,7 @@ ;;; Guile-Git --- GNU Guile bindings of libgit2 ;;; Copyright © 2016 Amirouche Boubekki <amirou...@hypermove.net> ;;; Copyright © 2016, 2017 Erik Edrosa <erik.edr...@gmail.com> -;;; Copyright © 2017, 2019 Ludovic Courtès <l...@gnu.org> +;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <l...@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othac...@gmail.com> ;;; Copyright © 2018 Jelle Licht <jli...@fsfe.org> ;;; Copyright © 2019 Marius Bakke <mar...@devup.no> @@ -25,14 +25,19 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (git config) #:use-module ((system foreign) #:select (null-pointer? bytevector->pointer make-pointer + procedure->pointer pointer->bytevector pointer->string + string->pointer sizeof dereference-pointer - pointer-address)) + pointer-address + void + (int . ffi:int))) #:use-module (bytestructures guile) #:use-module (ice-9 match) #:export (git-error? git-error-code git-error-message git-error-class pointer->git-error @@ -48,10 +53,26 @@ make-status-options-bytestructure status-options->pointer set-status-options-show! set-status-options-flags! - make-remote-callbacks remote-callbacks->pointer set-remote-callbacks-version! - make-fetch-options-bytestructure fetch-options-bytestructure fetch-options->pointer fetch-options-callbacks + make-remote-callbacks remote-callbacks->pointer set-remote-callbacks-version! set-remote-callbacks-transfer-progress! + make-fetch-options-bytestructure fetch-options-bytestructure fetch-options->pointer fetch-options-remote-callbacks fetch-options-download-tags set-fetch-options-download-tags! - set-fetch-options-callbacks! set-remote-callbacks-credentials! + set-remote-callbacks-credentials! + fetch-options-proxy-options + + indexer-progress? + indexer-progress-total-objects + indexer-progress-indexed-objects + indexer-progress-received-objects + indexer-progress-local-objects + indexer-progress-total-deltas + indexer-progress-total-deltas + indexer-progress-received-bytes + + proxy-options? + make-proxy-options-bytestructure proxy-options-bytestructure proxy-options->pointer proxy-options-callbacks + proxy-options-url proxy-options-type + set-proxy-options-url! set-proxy-options-type! + make-clone-options-bytestructure clone-options-bytestructure clone-options->pointer set-clone-options-fetch-opts! @@ -314,8 +335,123 @@ (pointer->diff-delta (make-pointer (bytestructure-ref bs 'index-to-workdir)))))) +;; proxy options: https://libgit2.org/libgit2/#HEAD/type/git_proxy_options + +(define %proxy-options + (bs:struct `((version ,unsigned-int) ;GIT-PROXY-OPTIONS-VERSION + (type ,int) ;git_proxy_t enum + (url ,(bs:pointer void)) ;string | NULL + (credendials ,(bs:pointer void)) ;git_cred_acquire_cb * + ;git_transport_certificate_check_cb + (transport-certificate-check-cb ,(bs:pointer void)) + (payload ,(bs:pointer void))))) + +(define GIT-PROXY-OPTIONS-VERSION 1) ;supported version--see <git2/proxy.h> + +(define-record-type <proxy-options> + (%make-proxy-options bytestructure) + proxy-options? + (bytestructure proxy-options-bytestructure)) + +(define (make-proxy-options-bytestructure) + (let ((bs (bytestructure %proxy-options))) + (bytestructure-set! bs 'version GIT-PROXY-OPTIONS-VERSION) + (%make-proxy-options bs))) + +(define (proxy-options->pointer proxy-options) + (bytestructure->pointer (proxy-options-bytestructure proxy-options))) + +(define %proxy-options-strings + ;; This weak-key 'eq?' hash table maps <proxy-options> records to pointer + ;; objects that must outlive them. + (make-weak-key-hash-table)) + +(define (symbol->proxy-type symbol) + "Convert SYMBOL to an integer of the 'git_proxy_t' enum." + (match symbol + ('none 0) + ('auto 1) + ('specified 2))) + +(define (proxy-type->symbol type) + "Convert INTEGER, a value of the 'git_proxy_t' enum, to a symbol." + (match type + (0 'none) + (1 'auto) + (2 'specified))) + +(define (proxy-options-type proxy-options) + "Return the proxy type, a symbol, specified in PROXY-OPTIONS." + (let ((proxy-options-bs (proxy-options-bytestructure proxy-options))) + (proxy-type->symbol + (bytestructure-ref proxy-options-bs 'type)))) + +(define (proxy-options-url proxy-options) + "Return the proxy URL specified in PROXY-OPTIONS, or #f if there is none." + (let* ((proxy-options-bs (proxy-options-bytestructure proxy-options)) + (ptr (make-pointer + (bytestructure-ref proxy-options-bs 'url)))) + (and (not (null-pointer? ptr)) + (pointer->string ptr -1 "UTF-8")))) + +(define (set-proxy-options-type! proxy-options type) + "Change the type of proxy in PROXY-OPTIONS to TYPE, one of 'none (no +proxy), 'auto (auto-detect proxy), or 'specified (use the specified proxy +URL)." + (let ((proxy-options-bs (proxy-options-bytestructure proxy-options))) + (bytestructure-set! proxy-options-bs 'type + (symbol->proxy-type type)))) + +(define (set-proxy-options-url! proxy-options url) + "Set the proxy URL in PROXY-OPTIONS to URL. Make sure to change the proxy +type to 'specified for this to take effect." + (let ((proxy-options-bs (proxy-options-bytestructure proxy-options)) + (str (and url (string->pointer url "UTF-8")))) + (if str + (begin + ;; Make sure STR is not reclaimed before PROXY-OPTIONS-BS. + (hashq-set! %proxy-options-strings proxy-options-bs str) + (bytestructure-set! proxy-options-bs 'url (pointer-address str))) + (bytestructure-set! proxy-options-bs 'url 0)))) + + ;; git fetch options +(define %indexer-progress + (bs:struct `((total-objects ,unsigned-int) + (indexed-objects ,unsigned-int) + (received-objects ,unsigned-int) + (local-objects ,unsigned-int) + (total-deltas ,unsigned-int) + (indexed-deltas ,unsigned-int) + (received-bytes ,size_t)))) + +(define-record-type <indexer-progress> + (%make-indexer-progress total-objects indexed-objects + received-objects local-objects + total-deltas indexed-deltas + received-bytes) + indexer-progress? + (total-objects indexer-progress-total-objects) + (indexed-objects indexer-progress-indexed-objects) + (received-objects indexer-progress-received-objects) + (local-objects indexer-progress-local-objects) + (total-deltas indexer-progress-total-deltas) + (indexed-deltas indexer-progress-total-deltas) + (received-bytes indexer-progress-received-bytes)) + +(define (bytestructure->indexer-progress bs) + "Return a copy of BS, an %INDEXER-PROGRESS bytestructure, as an +<indexer-progress> record." + (let-syntax ((make (syntax-rules () + ((_ field ...) + (%make-indexer-progress + (bytestructure-ref bs 'field) ...))))) + (make total-objects indexed-objects + received-objects local-objects + total-deltas indexed-deltas + received-bytes))) + (define %remote-callbacks (bs:struct `((version ,unsigned-int) (sideband-progress ,(bs:pointer uint8)) @@ -329,15 +465,25 @@ (push-update-reference ,(bs:pointer uint8)) (push-negotiation ,(bs:pointer uint8)) (transport ,(bs:pointer uint8)) - (payload ,(bs:pointer uint8))))) + (payload ,(bs:pointer uint8)) + + ;; libgit2 1.0 added this field, which is missing from 0.28.5, + ;; even though in both cases GIT_REMOTE_CALLBACKS_VERSION = 1. + ,@(if %have-remote-callbacks-resolve-url? + `((resolve-url ,(bs:pointer uint8))) + '())))) (define-record-type <remote-callbacks> (%make-remote-callbacks bytestructure) remote-callbacks? (bytestructure remote-callbacks-bytestructure)) +(define REMOTE-CALLBACKS-VERSION 1) ;<git2/remote.h> + (define (make-remote-callbacks) - (%make-remote-callbacks (bytestructure %remote-callbacks))) + (let ((bs (bytestructure %remote-callbacks))) + (bytestructure-set! bs 'version REMOTE-CALLBACKS-VERSION) + (%make-remote-callbacks bs))) (define (remote-callbacks->pointer remote-callbacks) (bytestructure->pointer (remote-callbacks-bytestructure remote-callbacks))) @@ -345,14 +491,6 @@ (define (set-remote-callbacks-version! remote-callbacks version) (bytestructure-set! (remote-callbacks-bytestructure remote-callbacks) 'version version)) -(define %proxy-options - (bs:struct `((version ,int) - (type ,int) - (url ,(bs:pointer uint8)) - (credentials ,(bs:pointer uint8)) - (certificate-check ,(bs:pointer uint8)) - (payload ,(bs:pointer uint8))))) - (define %fetch-options (bs:struct `((version ,int) (callbacks ,%remote-callbacks) @@ -408,15 +546,43 @@ 'download-tags (symbol->remote-autotag-option policy))) -(define (fetch-options-callbacks fetch-options) - (bytestructure-ref (fetch-options-bytestructure fetch-options) 'callbacks)) - -(define (set-fetch-options-callbacks! fetch-options callbacks) - (bytestructure-set! (fetch-options-bytestructure fetch-options) - 'callbacks callbacks)) +(define (fetch-options-remote-callbacks fetch-options) + (%make-remote-callbacks + (bytestructure-ref (fetch-options-bytestructure fetch-options) 'callbacks))) (define (set-remote-callbacks-credentials! callbacks credentials) - (bytestructure-set! callbacks 'credentials credentials)) + (bytestructure-set! (remote-callbacks-bytestructure callbacks) + 'credentials credentials)) + +(define (procedure->indexer-progress-callback proc) + "Wrap PROC and return a pointer that can be used as a +'git_indexer_progress_cb' value." + ;; https://libgit2.org/libgit2/#HEAD/group/callback/git_indexer_progress_cb + (procedure->pointer ffi:int + (lambda (ptr _) + ;; Return a value less than zero to cancel the + ;; indexing or download. + (if (proc (bytestructure->indexer-progress + (pointer->bytestructure ptr + %indexer-progress))) + 0 + -1)) + '(* *))) + +(define (set-remote-callbacks-transfer-progress! callbacks proc) + "Set PROC as a transfer-progress callback in CALLBACKS. PROC will be +called periodically as data if fetched from the remote, with one argument: an +indexer progress record. PROC can cancel the on-going transfer by returning +#f." + (bytestructure-set! (remote-callbacks-bytestructure callbacks) + 'transfer-progress + (pointer-address + (procedure->indexer-progress-callback proc)))) + +(define (fetch-options-proxy-options fetch-options) + "Return the <proxy-options> record associated with FETCH-OPTIONS." + (let ((bs (fetch-options-bytestructure fetch-options))) + (%make-proxy-options (bytestructure-ref bs 'proxy-opts)))) ;; git clone options diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/guix.scm new/guile-git-v0.4.0/guix.scm --- old/guile-git-v0.3.0/guix.scm 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/guix.scm 2020-10-22 09:32:23.000000000 +0200 @@ -25,7 +25,7 @@ ("openssh" ,openssh) ("git" ,git))) (inputs - `(("guile" ,guile-2.2) + `(("guile" ,guile-3.0) ("libgit2" ,libgit2) ("openssl" ,openssl) ("zlib" ,zlib) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/tests/clone.scm new/guile-git-v0.4.0/tests/clone.scm --- old/guile-git-v0.3.0/tests/clone.scm 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/tests/clone.scm 2020-10-22 09:32:23.000000000 +0200 @@ -1,5 +1,6 @@ ;;; Guile-Git --- GNU Guile bindings of libgit2 ;;; Copyright © 2019 Mathieu Othacehe <m.othac...@gmail.com> +;;; Copyright © 2020 Ludovic Courtès <l...@gnu.org> ;;; ;;; This file is part of Guile-Git. ;;; @@ -20,7 +21,9 @@ #:use-module (git) #:use-module (tests helpers) #:use-module (tests ssh) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) (test-begin "clone") @@ -65,7 +68,33 @@ (repository (repository-open clone-dir)) (remote (remote-lookup repository "origin"))) (remote-fetch remote #:fetch-options (make-fetch-options auth)) - #t))))) + #t))) + + (test-assert "clone + transfer-progress" + (with-repository "simple-bare" repository-directory + (let ((stats '())) ;list of <indexer-progress> + (let* ((checkout-directory (in-vicinity repository-directory + "checkout")) + (transfer-progress (lambda (progress) + (set! stats (cons progress stats)) + #t)) + (fetch-options (make-fetch-options (make-client-ssh-auth) + #:transfer-progress + transfer-progress))) + + (clone (make-ssh-url (canonicalize-path repository-directory) + ssh-server-port) + checkout-directory + (make-clone-options #:fetch-options fetch-options))) + + ;; Make sure the <indexer-progress> records we got exhibit + ;; monotonic growth. + (match (reverse stats) + ((first rest ...) + (let ((max (indexer-progress-total-objects first))) + (equal? (map indexer-progress-received-objects + (take (cons first rest) (+ max 1))) + (iota (+ max 1))))))))))) (libgit2-shutdown!) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/tests/helpers.scm new/guile-git-v0.4.0/tests/helpers.scm --- old/guile-git-v0.3.0/tests/helpers.scm 2020-01-14 03:01:53.000000000 +0100 +++ new/guile-git-v0.4.0/tests/helpers.scm 2020-10-22 09:32:23.000000000 +0200 @@ -1,7 +1,7 @@ ;;; Guile-Git --- GNU Guile bindings of libgit2 ;;; Copyright © 2016 Amirouche Boubekki <amirou...@hypermove.net> ;;; Copyright © 2017 Erik Edrosa <erik.edr...@gmail.com> -;;; Copyright © 2017 Ludovic Courtès <l...@gnu.org> +;;; Copyright © 2017, 2020 Ludovic Courtès <l...@gnu.org> ;;; ;;; This file is part of Guile-Git. ;;; @@ -81,13 +81,21 @@ (rmdir path) (delete-file path))))) -(define-syntax-rule (with-directory path body ...) - (begin - (when (access? path F_OK) - (rmtree path)) - (path-mkdir path #true) - body ... - (rmtree path))) +(define (call-with-directory directory thunk) + (dynamic-wind + (lambda () + (when (access? directory F_OK) + (rmtree directory)) + (path-mkdir directory #true)) + thunk + (lambda () + (rmtree directory)))) + +(define-syntax-rule (with-directory directory body ...) + "Evaluate BODY... in a context where DIRECTORY exists as an empty directory +and return its result. DIRECTORY is removed when the dynamic extent of +BODY... is left." + (call-with-directory directory (lambda () body ...))) (export with-directory) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/guile-git-v0.3.0/tests/proxy.scm new/guile-git-v0.4.0/tests/proxy.scm --- old/guile-git-v0.3.0/tests/proxy.scm 1970-01-01 01:00:00.000000000 +0100 +++ new/guile-git-v0.4.0/tests/proxy.scm 2020-10-22 09:32:23.000000000 +0200 @@ -0,0 +1,102 @@ +;;; Guile-Git --- GNU Guile bindings of libgit2 +;;; Copyright © 2020 Ludovic Courtès <l...@gnu.org> +;;; +;;; 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 proxy) + #:use-module (git) + #:use-module (tests helpers) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server) + #:use-module (web uri)) + +(define %proxy-port 12345) + +(define-record-type <box> + (make-box value) + box? + (value box-ref box-set!)) + +(define (spawn-proxy box) + "Spawn an HTTP server that serves one request and stores it into BOX." + (define (handle-request request body) + (box-set! box request) + (values (build-response #:code 404) + #vu8())) + + ;; Create the socket here to ensure that the server's up and running when + ;; this procedure returns. + (let* ((socket (socket AF_INET SOCK_STREAM 0)) + (mutex (make-mutex)) + (ready (make-condition-variable))) + (setsockopt socket SOL_SOCKET SO_REUSEPORT 1) + (bind socket AF_INET INADDR_LOOPBACK %proxy-port) + (with-mutex mutex + (call-with-new-thread + (lambda () + (let* ((impl (lookup-server-impl 'http)) + (server (open-server impl `(#:socket ,socket)))) + (signal-condition-variable ready) + (serve-one-client handle-request impl server '()) + (close-server impl server)))) + + (wait-condition-variable ready mutex + (+ (current-time) 10))))) + +(define (clone-through-proxy url) + "Spawn a proxy, attempt to clone URL through that proxy, and return the +request received by the proxy." + (let ((box (make-box #f))) + (spawn-proxy box) + (let* ((fetch-options (make-fetch-options + #:proxy-url + ;; Note: libgit2 wants a proper URL with a path. + (string-append "http://localhost:"; + (number->string %proxy-port) + "/"))) + (clone-options (make-clone-options + #:fetch-options fetch-options))) + (catch 'git-error + (lambda () + (clone url "/tmp/guile-git-clone-test" clone-options)) + (lambda _ + (match (box-ref box) + ((? request? request) + (list (request-method request) + (uri->string (request-uri request)))))))))) + +(test-begin "proxy") + + +;; Guile < 3.0.3 doesn't recognize the CONNECT method in (web http). +(when (string<? (version) "3.0.3") + (test-skip 1)) + +(test-equal "clone with HTTPS proxy" + '(CONNECT "example.org:443") + (clone-through-proxy "https://example.org/example.git";)) + +;; XXX: libgit2 1.0.1 doesn't support HTTP proxy, so we only test HTTPS. See +;; <https://github.com/libgit2/libgit2/issues/5650>. + +(test-end "proxy") _______________________________________________ openSUSE Commits mailing list -- commit@lists.opensuse.org To unsubscribe, email commit-le...@lists.opensuse.org List Netiquette: https://en.opensuse.org/openSUSE:Mailing_list_netiquette List Archives: https://lists.opensuse.org/archives/list/commit@lists.opensuse.org
