1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (test-swh)
20 #:use-module (guix swh)
21 #:use-module (guix tests http)
22 #:use-module (web response)
23 #:use-module (srfi srfi-64))
25 ;; Test the JSON mapping machinery used in (guix swh).
28 "{ \"visits_url\": \"/visits/42\",
30 \"url\": \"http://example.org/guix.git\" }")
32 (define %directory-entries
33 "[ { \"name\": \"one\",
34 \"type\": \"regular\",
38 \"type\": \"regular\",
42 (define-syntax-rule (with-json-result str exp ...)
43 (with-http-server `((200 ,str))
44 (parameterize ((%swh-base-url (%local-url)))
49 (test-equal "lookup-origin"
50 (list "git" "http://example.org/guix.git")
51 (with-json-result %origin
52 (let ((origin (lookup-origin "http://example.org/guix.git")))
53 (list (origin-type origin)
54 (origin-url origin)))))
56 (test-equal "lookup-origin, not found"
58 (with-http-server `((404 "Nope."))
59 (parameterize ((%swh-base-url (%local-url)))
60 (lookup-origin "http://example.org/whatever"))))
62 (test-equal "lookup-directory"
63 '(("one" 123) ("two" 456))
64 (with-json-result %directory-entries
66 (list (directory-entry-name entry)
67 (directory-entry-length entry)))
68 (lookup-directory "123"))))
70 (test-equal "rate limit reached"
72 (let ((too-many (build-response
74 #:reason-phrase "Too many requests"
76 ;; Pretend we've reached the limit and it'll be reset in
78 #:headers '((x-ratelimit-remaining . "0")
79 (x-ratelimit-reset . "3000000000")))))
80 (with-http-server `((,too-many "Too bad."))
81 (parameterize ((%swh-base-url (%local-url)))
84 (lookup-origin "http://example.org/guix.git"))
85 (lambda (key url method response)
86 ;; Ensure the reset time was recorded.
87 (@@ (guix swh) %general-rate-limit-reset-time)))))))
89 (test-assert "%allow-request? and request-rate-limit-reached?"
90 ;; Here we test two things: that the rate limit set above is in effect and
91 ;; that %ALLOW-REQUEST? is called, and that 'request-rate-limit-reached?'
93 (let* ((key (gensym "skip-request"))
94 (skip-if-limit-reached
96 (or (not (request-rate-limit-reached? url method))
98 (parameterize ((%allow-request? skip-if-limit-reached))
101 (lookup-origin "http://example.org/guix.git")
108 ;; eval: (put 'with-json-result 'scheme-indent-function 1)
109 ;; eval: (put 'with-http-server 'scheme-indent-function 1)