Git Mock Forge for Guix tests

[Nicolas Graves via "Developers list for Guile, the GNU extensibility library" <guile-devel@gnu.org>]

Hi Guile!

For the needs of tests for Guix's juliahub imports, I was in the
process of writing a cool mock git forge, ie. a HTTP server implement
the Git Dump Protocol, which is actually quite simple to do.

I can't achieve that because of an option missing in upstream guile,
more precisely I need the http server to be able to respond with a

         (content-type . (application/x-git-upload-pack-advertisement))
         
header to git. But in guile's web server implementation, this is not
possible because of sanitize-response's charset addition, which is not
configurable.

I'm actually not that comfortable with guile's source code although I am
with guix's. I'll need some guidance before feeling confident enough to
send a patch.

I see two possible implementations right now:
- adding a field to <request> to allow opting out sanitizing
- adapting the sanitize-response code to ignore the charset in some
specific case, like '(content-type . (text/plain (charset . #f))
for instance.

(Disclaimer: I'm not qualified to assess security implications.)

I'm willing to write this patch and get this merged quickly, since this
patch series is waiting for quite some time now, and guile's about to
release a new version. Thanks if you can provide some guidance on how to
do this!

Cheers,
Nicolas


-------------------- Start of forwarded message --------------------
Subject: [bug#62202] [PATCH v4 6/6] tests: juliahub: Add unit tests for (guix
 import juliahub).
To: Ludovic Courtès <ludo@gnu.org>
Cc: zimoun.toutoune@gmail.com, 62202@debbugs.gnu.org
Date: Thu, 11 Apr 2024 12:56:58 +0200
From:  Nicolas Graves via Guix-patches via <guix-patches@gnu.org>

On 2024-04-09 09:29, Nicolas Graves wrote:
>>
>> I strongly encourage using ‘with-http-server’ using the same strategy
>> that’s used in ‘tests/pypi.scm’ and others instead of mocking.  (‘mock’
>> is very sensitive to inlining, plus you sorta have to make assumptions
>> about the code path to be able to mock the right things.)
>
> I can't however mock a git server, right? I still must mock at least the
> git repo instead of getting it through a custom server, or is there a
> better solution here?

It's actually simpler than I thought, but there's an impediment in guile
http server implementation that doesn't allow me to push this effort to
the end.

https://git-scm.com/book/en/v2/Git-Internals-Transfer-Protocols

I'm currently writing it, it'll result in a handy helper for tests, such
as :

(with-git-forge  ; spawns a dumb but functional git server
      '(("MyPackage" . ((add "a.txt" "A")
                        (commit "First commit")
                        (tag "v1.0.0" "Release 1.0"))))
    (with-julia-test-servers
        `(("/juliahub/MyPackage/" 200 ,juliahub-redirect.html)
          ("/juliahub/MyPackage/" 200 ,juliahub-redirect.html)
          ("/juliahub/MyPackage/MySlg/1.0.0/pkg.json" 200
           ,(lambda (port) (display (fixture-pkg.json) port)))
          ("/general/M/MyPackage/Package.toml" 200
           ,(lambda (port) (display (pk 'd (general-Package.toml)) port))))
      (juliahub->guix-package "MyPackage")))


However, for that I'll need the http server to be able to respond with a
         (content-type . (application/x-git-upload-pack-advertisement))
header to git. But in guile's web server implementation, this is not
possible because of sanitize-response's charset addition, which is not
configurable. 

That's outside my field, how can we progress further ? We do indeed need
such a server to properly test juliahub since we go get the tag from the
actual repo (this is justified in the patch series).

_____________________________________________________________________________
;;; Git Forge = Git HTTP Server with Dump transfer protocol and repositories

(define (call-with-temporary-git-repositories names+directives proc)
  "Call PROC with populated git temporary directories as per NAMES+DIRECTIVES;
close the directories and delete them when leaving the dynamic extent of this
call."
  (call-with-temporary-directory
   (lambda (directory)
     (for-each
      (match-lambda
        ((name . directives)
         (populate-git-repository
          (string-append directory "/" name ".git") directives)))
      names+directives)
     (proc directory))))

(define %git-forge-port
  ;; TCP port to use for the dumb git server.
  ;; If 0, the OS will automatically choose
  ;; a port.
  (make-parameter 0))

(define (binary-file-dump file)
  "Return a procedure that dumps binary FILE to the given port."
  (lambda (output)
    (call-with-input-file file
      (lambda (input)
        (put-bytevector output (get-bytevector-all input)))
      #:binary #t)))

(define (serialize-git-ref ref oid)
  (format #f "~a     ~a\n" oid ref))

(define (refs->alist repo refs)
  (let ((repository (repository-open repo)))
    (map
     (lambda (ref)
       (cons ref (oid->string (reference-name->oid repository ref))))
     refs)))

(define* (call-with-git-forge repositories+directives thunk)
  "Call THUNK with a running GIT test forge, i.e. an HTTP server implementing
the git dumb protocol (see
https://git-scm.com/book/en/v2/Git-Internals-Transfer-Protocols) running.
This server behaves like a GIT forge with the repositories constructed from
REPOSITORIES+DIRECTIVES.  Each element of REPOSITORIES+DIRECTIVES must be a
tuple containing a repository name and a list of DIRECTIVES.

%git-forge-port will be set to the port listened at
The port listened at will be set for the dynamic extent of THUNK."
  (call-with-temporary-git-repositories
   repositories+directives
   (lambda (dir-with-repos)
     (define responses+data
       (let ((repos (scandir dir-with-repos
                             (lambda (name)
                               (not (member name '("." "..")))))))
         (append-map
          (lambda (relative-repo)
            (let* ((name (string-drop-right relative-repo (string-length ".git")))
                   (repo (string-append dir-with-repos "/" relative-repo)))
              `((,(string-append "/" name ".git/info/refs")
                 200
                 ((content-type . (application/x-git-upload-pack-advertisement)))
                 ,((@ (gnu services configuration) generic-serialize-alist)
                   string-append
                   serialize-git-ref
                   (refs->alist repo (remote-refs repo))))
                (,(string-append "/" name ".git/HEAD")
                 200
                 "ref: refs/heads/master")
                ,@(map
                   (lambda (object)
                     `(,(string-append "/" name ".git/objects/"
                                       (string-take-right object 41))
                       200
                       ,(binary-file-dump
                         (string-append repo "/.git/objects/" object))))
                   (find-files (string-append repo "/.git/objects")))
                (,(string-append "/" name ".git/objects/info/http-alternates")
                 200
                 "")
                (,(string-append "/" name ".git/objects/info/packs")
                 200 ""))))
          repos)))

     (parameterize ((%http-server-port (%git-forge-port)))
       (call-with-http-server (pk 'responses+data responses+data) thunk)))))

(define-syntax with-git-forge
  (syntax-rules ()
    ((_ repositories+directives body ...)
     (call-with-git-forge repositories+directives (lambda () body ...)))))
__________________________________________________________________________________

-------------------- End of forwarded message --------------------

-- 
Best regards,
Nicolas Graves