Commit 7a3d97a7 authored by civodul's avatar civodul
Browse files

fetch: Add support for transfer progress callback.

* git/fetch.scm (make-fetch-options): Add #:transfer-progress and honor
it.  Add docstring.
(set-fetch-options-transfer-progress!): New procedure.
* git/structs.scm (%indexer-progress): New variable.
(<indexer-progress>): New record type.
(bytestructure->indexer-progress, procedure->indexer-progress-callback)
(set-remote-callbacks-transfer-progress!): New procedures.
* tests/clone.scm ("clone + transfer-progress"): New test.
parent 26054efa
Pipeline #197939508 passed with stage
in 3 minutes and 3 seconds
......@@ -38,9 +38,18 @@
(define make-fetch-options
(let ((proc (libgit2->procedure* "git_fetch_init_options"
`(* ,unsigned-int))))
(lambda* (#:optional auth-method #:key proxy-options)
(lambda* (#:optional auth-method
#:key proxy-options 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-OPTIONS is true, it must be a record as
returned by 'make-proxy-options'."
(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))
......@@ -49,6 +58,11 @@
(when proxy-options
(set-fetch-options-proxy-options! fetch-options proxy-options))
(when transfer-progress
(set-fetch-options-transfer-progress! fetch-options
transfer-progress))
fetch-options))))
(define fetch-init-options
......@@ -99,3 +113,8 @@
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)))
......@@ -28,13 +28,15 @@
#:use-module ((system foreign) #:select (null-pointer?
bytevector->pointer
make-pointer
procedure->pointer
pointer->bytevector
pointer->string
string->pointer
sizeof
dereference-pointer
pointer-address
void))
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
......@@ -50,12 +52,21 @@
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-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-remote-callbacks-credentials!
fetch-options-proxy-options set-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
......@@ -402,8 +413,44 @@ type to 'specified for this to take effect."
(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))
......@@ -500,6 +547,31 @@ tag policy in FETCH-OPTIONS."
(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)))
......
;;; Guile-Git --- GNU Guile bindings of libgit2
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Ludovic Courtès <ludo@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!)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment