mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
import: cpan: Rewrite tests to use an HTTP server instead of mocking.
* guix/import/cpan.scm (%metacpan-base-url): New variable.
(module->dist-name, cpan-fetch): Refer to it instead of the hard-coded URL.
* tests/cpan.scm ("cpan->guix-package"): Use 'with-http-server' instead
of 'mock'.
This commit is contained in:
Ludovic Courtès
parent
69f132554c
commit
4aea90b187
2 changed files with 43 additions and 50 deletions
|
|
@ -61,7 +61,9 @@ (define-module (guix import cpan)
|
|||
cpan-fetch
|
||||
cpan->guix-package
|
||||
metacpan-url->mirror-url
|
||||
%cpan-updater))
|
||||
%cpan-updater
|
||||
|
||||
%metacpan-base-url))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
|
@ -70,6 +72,10 @@ (define-module (guix import cpan)
|
|||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define %metacpan-base-url
|
||||
;; Base URL of the MetaCPAN API.
|
||||
(make-parameter "https://fastapi.metacpan.org/v1/"))
|
||||
|
||||
;; Dependency of a "release".
|
||||
(define-json-mapping <cpan-dependency> make-cpan-dependency cpan-dependency?
|
||||
json->cpan-dependency
|
||||
|
|
@ -149,7 +155,7 @@ (define (module->dist-name module)
|
|||
module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
|
||||
return \"Test-Simple\""
|
||||
(assoc-ref (json-fetch (string-append
|
||||
"https://fastapi.metacpan.org/v1/module/"
|
||||
(%metacpan-base-url) "/module/"
|
||||
module
|
||||
"?fields=distribution"))
|
||||
"distribution"))
|
||||
|
|
@ -176,7 +182,7 @@ (define (cpan-fetch name)
|
|||
\"Test-Script\" for the \"Test::Script\" module."
|
||||
;; This API always returns the latest release of the module.
|
||||
(json->cpan-release
|
||||
(json-fetch (string-append "https://fastapi.metacpan.org/v1/release/"
|
||||
(json-fetch (string-append (%metacpan-base-url) "/release/"
|
||||
name))))
|
||||
|
||||
(define (cpan-home name)
|
||||
|
|
|
|||
|
|
@ -22,9 +22,10 @@ (define-module (test-cpan)
|
|||
#:use-module (guix import cpan)
|
||||
#:use-module (guix base32)
|
||||
#:use-module (gcrypt hash)
|
||||
#:use-module (guix tests)
|
||||
#:use-module (guix tests http)
|
||||
#:use-module (guix grafts)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (web client)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
;; Globally disable grafts because they can trigger early builds.
|
||||
|
|
@ -57,56 +58,42 @@ (define test-json
|
|||
(define test-source
|
||||
"foobar")
|
||||
|
||||
;; Avoid collisions with other tests.
|
||||
(%http-server-port 10400)
|
||||
|
||||
(test-begin "cpan")
|
||||
|
||||
(test-assert "cpan->guix-package"
|
||||
;; Replace network resources with sample data.
|
||||
(mock ((guix build download) url-fetch
|
||||
(lambda* (url file-name
|
||||
#:key
|
||||
(mirrors '()) verify-certificate?)
|
||||
(with-output-to-file file-name
|
||||
(lambda ()
|
||||
(display
|
||||
(match url
|
||||
("http://example.com/Foo-Bar-0.1.tar.gz"
|
||||
test-source)
|
||||
(_ (error "Unexpected URL: " url))))))))
|
||||
(mock ((guix http-client) http-fetch
|
||||
(lambda (url . rest)
|
||||
(match url
|
||||
("https://fastapi.metacpan.org/v1/release/Foo-Bar"
|
||||
(values (open-input-string test-json)
|
||||
(string-length test-json)))
|
||||
("https://fastapi.metacpan.org/v1/module/Test::Script?fields=distribution"
|
||||
(let ((result "{ \"distribution\" : \"Test-Script\" }"))
|
||||
(values (open-input-string result)
|
||||
(string-length result))))
|
||||
(_ (error "Unexpected URL: " url)))))
|
||||
(match (cpan->guix-package "Foo::Bar")
|
||||
(('package
|
||||
('name "perl-foo-bar")
|
||||
('version "0.1")
|
||||
('source ('origin
|
||||
('method 'url-fetch)
|
||||
('uri ('string-append "http://example.com/Foo-Bar-"
|
||||
'version ".tar.gz"))
|
||||
('sha256
|
||||
('base32
|
||||
(? string? hash)))))
|
||||
('build-system 'perl-build-system)
|
||||
('propagated-inputs
|
||||
('quasiquote
|
||||
(("perl-test-script" ('unquote 'perl-test-script)))))
|
||||
('home-page "https://metacpan.org/release/Foo-Bar")
|
||||
('synopsis "Fizzle Fuzz")
|
||||
('description 'fill-in-yourself!)
|
||||
('license 'perl-license))
|
||||
(string=? (bytevector->nix-base32-string
|
||||
(call-with-input-string test-source port-sha256))
|
||||
hash))
|
||||
(x
|
||||
(pk 'fail x #f))))))
|
||||
(with-http-server `((200 ,test-json)
|
||||
(200 ,test-source)
|
||||
(200 "{ \"distribution\" : \"Test-Script\" }"))
|
||||
(parameterize ((%metacpan-base-url (%local-url))
|
||||
(current-http-proxy (%local-url)))
|
||||
(match (cpan->guix-package "Foo::Bar")
|
||||
(('package
|
||||
('name "perl-foo-bar")
|
||||
('version "0.1")
|
||||
('source ('origin
|
||||
('method 'url-fetch)
|
||||
('uri ('string-append "http://example.com/Foo-Bar-"
|
||||
'version ".tar.gz"))
|
||||
('sha256
|
||||
('base32
|
||||
(? string? hash)))))
|
||||
('build-system 'perl-build-system)
|
||||
('propagated-inputs
|
||||
('quasiquote
|
||||
(("perl-test-script" ('unquote 'perl-test-script)))))
|
||||
('home-page "https://metacpan.org/release/Foo-Bar")
|
||||
('synopsis "Fizzle Fuzz")
|
||||
('description 'fill-in-yourself!)
|
||||
('license 'perl-license))
|
||||
(string=? (bytevector->nix-base32-string
|
||||
(call-with-input-string test-source port-sha256))
|
||||
hash))
|
||||
(x
|
||||
(pk 'fail x #f))))))
|
||||
|
||||
(test-equal "metacpan-url->mirror-url, http"
|
||||
"mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
|
||||
|
|
|
|||
Loading…
Reference in a new issue