@@ -19,7 +19,6 @@
(define-module (guix import minetest)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
- #:use-module (ice-9 threads)
#:use-module (ice-9 hash-table)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
@@ -69,6 +68,10 @@
(define (delete-cr text)
(string-delete #\cr text))
+;; Mocked by tests.
+(define par-map (@ (ice-9 threads) par-map))
+(set! par-map par-map)
+
;;;
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +23,7 @@
#:use-module (guix import minetest)
#:use-module (guix import utils)
#:use-module (guix tests)
+ #:use-module (guix tests http)
#:use-module (guix packages)
#:use-module (guix git-download)
#:use-module ((gnu packages minetest)
@@ -30,6 +31,9 @@
#:use-module ((gnu packages base)
#:select (hello))
#:use-module (json)
+ #:use-module (web request)
+ #:use-module (web uri)
+ #:use-module (web client)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -152,7 +156,7 @@
(invalidate-memoization! minetest->guix-package)
(define (scm->json-port scm)
(open-input-string (scm->json-string scm)))
- (define (handle-package url requested-author requested-name . rest)
+ (define (handle-package subresource requested-author requested-name . rest)
(define relevant-argument-list
(any (lambda (argument-list)
(apply (lambda* (#:key (author "Author") (name "foo")
@@ -164,14 +168,15 @@
argument-lists))
(when (not relevant-argument-list)
(error "the package ~a/~a should be irrelevant, but ~a is fetched"
- requested-author requested-name url))
- (scm->json-port
- (apply (match rest
- (("") make-package-json)
- (("dependencies" "") make-dependencies-json)
- (("releases" "") make-releases-json)
- (_ (error "TODO ~a" rest)))
- relevant-argument-list)))
+ requested-author requested-name subresource))
+ (define json (apply
+ (match rest
+ (("") make-package-json)
+ (("dependencies" "") make-dependencies-json)
+ (("releases" "") make-releases-json)
+ (_ (error "TODO ~a" rest)))
+ relevant-argument-list))
+ (values '() (lambda (port) (scm->json json port))))
(define (handle-mod-search sort)
;; Produce search results, sorted by SORT in descending order.
(define arguments->key
@@ -191,29 +196,40 @@
("name" . ,name)
("type" . ,type))))
(define argument-list->json (cut apply arguments->json <>))
- (scm->json-port
- (list->vector (filter-map argument-list->json sorted-argument-lists))))
- (mock ((guix http-client) http-fetch
- (lambda* (url #:key headers)
- (unless (string-prefix? "mock://api/packages/" url)
- (error "the URL ~a should not be used" url))
- (define resource
- (substring url (string-length "mock://api/packages/")))
- (define components (string-split resource #\/))
- (match components
- ((author name . rest)
- (apply handle-package url author name rest))
- (((? (cut string-prefix? "?type=mod&q=" <>) query))
- (handle-mod-search
- (cond ((string-contains query "sort=score") "score")
- ((string-contains query "sort=downloads") "downloads")
- (#t (error "search query ~a has unknown sort key"
- query)))))
- (_
- (error "the URL ~a should have an author and name component"
- url)))))
- (parameterize ((%contentdb-api "mock://api/"))
- (thunk))))
+ (define json
+ (list->vector (filter-map argument-list->json sorted-argument-lists)))
+ (values '()
+ (lambda (port) (scm->json json port))))
+ (with-http-server*
+ (lambda (request _)
+ (unless (eq? 'GET (request-method request))
+ (error "wrong HTTP method"))
+ (define resource (uri-path (request-uri request)))
+ (unless (string-prefix? "/api/packages/" resource)
+ (error "the resource ~a should not be used" resource))
+ (define subresource
+ (substring resource (string-length "/api/packages/")))
+ (define components (string-split subresource #\/))
+ (match components
+ ((author name . rest)
+ (apply handle-package subresource author name rest))
+ (("")
+ (let ((query (uri-query (request-uri request))))
+ (handle-mod-search
+ (cond ((string-contains query "sort=score") "score")
+ ((string-contains query "sort=downloads") "downloads")
+ (#t (error "search query ~a has unknown sort key"
+ query))))))
+ (_
+ (error "the resource ~a should have an author and name component"
+ resource))))
+ (parameterize ((%contentdb-api
+ (format #f "http://localhost:~a/api/" (%http-server-port)))
+ (current-http-proxy #f))
+ ;; XXX: for some unknown reason, parallelism causes ECONNREFUSED in
+ ;; tests but not in the wild.
+ (mock ((guix import minetest) par-map map)
+ (thunk)))))
(define* (minetest->guix-package* #:key (author "Author") (name "foo")
(sort %default-sort-key)