[bug#62202] [PATCH v4 6/6] tests: juliahub: Add unit tests for (guix import juliahub).

[Nicolas Graves]

On 2024-04-09 09:29, Nicolas Graves wrote:

> On 2024-04-01 22:50, Ludovic Courtès wrote:
>
>> Hi,
>>
>> As part of this v4, I would recommend merging patches 2, 3, and 6, such
>> that there’s a single self-contained patch adding ‘guix import
>> juliahub’.  (That’s what we usually do and I find it clearer because we
>> immediately see what goes together.)
>>
>> Nicolas Graves <ngraves@ngraves.fr> skribis:
>>
>>> * tests/juliahub.scm : Add unit tests juliahub-redirect,
>>> julia-general-registry-parsing, juliahub-fetch.
>>
>> Just “New file.”
>>
>> Some of the other files lack a commit log; we can add it for you, but
>> it’d be great if you could do it upfront.
>>
>>> ---
>>>  tests/juliahub.scm | 185 +++++++++++++++++++++++++++++++++++++++++++++
>>
>> Please add it to ‘Makefile.am’.
>>
>> [...]
>>
>>> +(define (mock-http-fetch testcase)
>>> +  (lambda (url . rest)
>>> +    (let ((body (assoc-ref testcase url)))
>>> +      (if body
>>> +          (open-input-string body)
>>> +          (error "mocked http-fetch Unexpected URL: " url)))))
>>> +
>>> +(define (mock-http-get testcase)
>>> +  (lambda (url . rest)
>>> +    (let ((body (assoc-ref testcase url))
>>> +          (response-header
>>> +             (build-response
>>> +                #:version '(1 . 1)
>>
>> 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 ...)))))
__________________________________________________________________________________

>>
>>> +(test-equal "juliahub-fetch"
>>> +  #t
>>> +  (mock ((web client) http-get
>>> +         (mock-http-get fixtures-juliahub-check-test))
>>> +        (mock ((guix http-client) http-fetch
>>> +               (mock-http-fetch fixtures-juliahub-check-test))
>>> +              (mock ((guix import utils) git->origin mock-git->origin)
>>> +                    ((@@ (guix import juliahub) juliahub-package?)
>>> +                     ((@@ (guix import juliahub) juliahub-fetch) 
>>> "MyPackage"))))))
>>
>> Checking for ‘juliahub-package?’ doesn’t tell us much; what about
>> checking the whole package, similar to what is done in other importer
>> tests?
>>
>> Thanks,
>> Ludo’.

-- 
Best regards,
Nicolas Graves