1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2019, 2020, 2021 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-19)
24 #:use-module (srfi srfi-64)
25 #:use-module (ice-9 match))
27 ;; Test the JSON mapping machinery used in (guix swh).
30 "{ \"origin_visits_url\": \"/visits/42\",
32 \"url\": \"http://example.org/guix.git\" }")
35 ;; A single visit where 'snapshot_url' is null.
36 ;; See <https://bugs.gnu.org/45615>.
38 \"origin\": \"https://github.com/Genivia/ugrep\",
40 \"date\": \"2020-05-17T21:43:45.422977+00:00\",
41 \"status\": \"ongoing\",
45 \"origin_visit_url\": \"https://archive.softwareheritage.org/api/1/origin/https://github.com/Genivia/ugrep/visit/1/\",
46 \"snapshot_url\": null
49 (define %directory-entries
50 "[ { \"name\": \"one\",
51 \"type\": \"regular\",
55 \"type\": \"regular\",
59 (define-syntax-rule (with-json-result str exp ...)
60 (with-http-server `((200 ,str))
61 (parameterize ((%swh-base-url (%local-url)))
66 (test-equal "lookup-origin"
67 (list "git" "http://example.org/guix.git")
68 (with-json-result %origin
69 (let ((origin (lookup-origin "http://example.org/guix.git")))
70 (list (origin-type origin)
71 (origin-url origin)))))
73 (test-equal "lookup-origin, not found"
75 (with-http-server `((404 "Nope."))
76 (parameterize ((%swh-base-url (%local-url)))
77 (lookup-origin "http://example.org/whatever"))))
79 (test-equal "origin-visit, no snapshots"
80 '("https://github.com/Genivia/ugrep"
81 "2020-05-17T21:43:45Z"
82 #f) ;see <https://bugs.gnu.org/45615>
83 (with-http-server `((200 ,%origin)
85 (parameterize ((%swh-base-url (%local-url)))
86 (let ((origin (lookup-origin "http://example.org/whatever")))
87 (match (origin-visits origin)
89 (list (visit-origin visit)
90 (date->string (visit-date visit) "~4")
91 (visit-snapshot-url visit))))))))
93 (test-equal "lookup-directory"
94 '(("one" 123) ("two" 456))
95 (with-json-result %directory-entries
97 (list (directory-entry-name entry)
98 (directory-entry-length entry)))
99 (lookup-directory "123"))))
101 (test-equal "rate limit reached"
103 (let ((too-many (build-response
105 #:reason-phrase "Too many requests"
107 ;; Pretend we've reached the limit and it'll be reset in
109 #:headers '((x-ratelimit-remaining . "0")
110 (x-ratelimit-reset . "3000000000")))))
111 (with-http-server `((,too-many "Too bad."))
112 (parameterize ((%swh-base-url (%local-url)))
115 (lookup-origin "http://example.org/guix.git"))
116 (lambda (key url method response)
117 ;; Ensure the reset time was recorded.
118 (@@ (guix swh) %general-rate-limit-reset-time)))))))
120 (test-assert "%allow-request? and request-rate-limit-reached?"
121 ;; Here we test two things: that the rate limit set above is in effect and
122 ;; that %ALLOW-REQUEST? is called, and that 'request-rate-limit-reached?'
124 (let* ((key (gensym "skip-request"))
125 (skip-if-limit-reached
127 (or (not (request-rate-limit-reached? url method))
129 (parameterize ((%allow-request? skip-if-limit-reached))
132 (lookup-origin "http://example.org/guix.git")
139 ;; eval: (put 'with-json-result 'scheme-indent-function 1)
140 ;; eval: (put 'with-http-server 'scheme-indent-function 1)