1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2019 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).
29 \"visits_url\": \"/visits/42\",
31 \"url\": \"http://example.org/guix.git\" }")
33 (define %directory-entries
34 "[ { \"name\": \"one\",
35 \"type\": \"regular\",
39 \"type\": \"regular\",
43 (define-syntax-rule (with-json-result str exp ...)
44 (with-http-server `((200 ,str))
45 (parameterize ((%swh-base-url (%local-url)))
50 (test-equal "lookup-origin"
51 (list 42 "git" "http://example.org/guix.git")
52 (with-json-result %origin
53 (let ((origin (lookup-origin "http://example.org/guix.git")))
54 (list (origin-id origin)
56 (origin-url origin)))))
58 (test-equal "lookup-origin, not found"
60 (with-http-server `((404 "Nope."))
61 (parameterize ((%swh-base-url (%local-url)))
62 (lookup-origin "http://example.org/whatever"))))
64 (test-equal "lookup-directory"
65 '(("one" 123) ("two" 456))
66 (with-json-result %directory-entries
68 (list (directory-entry-name entry)
69 (directory-entry-length entry)))
70 (lookup-directory "123"))))
72 (test-equal "rate limit reached"
74 (let ((too-many (build-response
76 #:reason-phrase "Too many requests"
78 ;; Pretend we've reached the limit and it'll be reset in
80 #:headers '((x-ratelimit-remaining . "0")
81 (x-ratelimit-reset . "3000000000")))))
82 (with-http-server `((,too-many "Too bad."))
83 (parameterize ((%swh-base-url (%local-url)))
86 (lookup-origin "http://example.org/guix.git"))
87 (lambda (key url method response)
88 ;; Ensure the reset time was recorded.
89 (@@ (guix swh) %general-rate-limit-reset-time)))))))
91 (test-assert "%allow-request? and request-rate-limit-reached?"
92 ;; Here we test two things: that the rate limit set above is in effect and
93 ;; that %ALLOW-REQUEST? is called, and that 'request-rate-limit-reached?'
95 (let* ((key (gensym "skip-request"))
96 (skip-if-limit-reached
98 (or (not (request-rate-limit-reached? url method))
100 (parameterize ((%allow-request? skip-if-limit-reached))
103 (lookup-origin "http://example.org/guix.git")
110 ;; eval: (put 'with-json-result 'scheme-indent-function 1)
111 ;; eval: (put 'with-http-server 'scheme-indent-function 1)