From 4aea90b1876179aab8d603a42533a6bdf97ccd3c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 15 Jan 2020 18:35:14 +0100
Subject: 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'.
---
 guix/import/cpan.scm | 12 ++++++--
 tests/cpan.scm       | 81 ++++++++++++++++++++++------------------------------
 2 files changed, 43 insertions(+), 50 deletions(-)

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index 4320f94c98..7a97c7f8e8 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -61,7 +61,9 @@
             cpan-fetch
             cpan->guix-package
             metacpan-url->mirror-url
-            %cpan-updater))
+            %cpan-updater
+
+            %metacpan-base-url))
 
 ;;; Commentary:
 ;;;
@@ -70,6 +72,10 @@
 ;;;
 ;;; 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 @@
 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 @@ or #f on failure.  MODULE should be the distribution name, such as
 \"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)
diff --git a/tests/cpan.scm b/tests/cpan.scm
index 043d401032..b4db9e60e4 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -22,9 +22,10 @@
   #: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-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"
-- 
cgit 1.4.1