Commit | Line | Data |
---|---|---|
96f1cbef | 1 | ;;; GNU Guix --- Functional package management for GNU |
5225732b | 2 | ;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
96f1cbef LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
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. | |
10 | ;;; | |
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. | |
15 | ;;; | |
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/>. | |
18 | ||
19 | (define-module (test-swh) | |
20 | #:use-module (guix swh) | |
21 | #:use-module (guix tests http) | |
ba1c1853 | 22 | #:use-module (web response) |
5225732b LC |
23 | #:use-module (srfi srfi-19) |
24 | #:use-module (srfi srfi-64) | |
25 | #:use-module (ice-9 match)) | |
96f1cbef LC |
26 | |
27 | ;; Test the JSON mapping machinery used in (guix swh). | |
28 | ||
29 | (define %origin | |
5225732b | 30 | "{ \"origin_visits_url\": \"/visits/42\", |
96f1cbef LC |
31 | \"type\": \"git\", |
32 | \"url\": \"http://example.org/guix.git\" }") | |
33 | ||
5225732b LC |
34 | (define %visits |
35 | ;; A single visit where 'snapshot_url' is null. | |
36 | ;; See <https://bugs.gnu.org/45615>. | |
37 | "[ { | |
38 | \"origin\": \"https://github.com/Genivia/ugrep\", | |
39 | \"visit\": 1, | |
40 | \"date\": \"2020-05-17T21:43:45.422977+00:00\", | |
41 | \"status\": \"ongoing\", | |
42 | \"snapshot\": null, | |
43 | \"metadata\": {}, | |
44 | \"type\": \"git\", | |
45 | \"origin_visit_url\": \"https://archive.softwareheritage.org/api/1/origin/https://github.com/Genivia/ugrep/visit/1/\", | |
46 | \"snapshot_url\": null | |
47 | } ]") | |
48 | ||
96f1cbef LC |
49 | (define %directory-entries |
50 | "[ { \"name\": \"one\", | |
51 | \"type\": \"regular\", | |
52 | \"length\": 123, | |
9608f400 | 53 | \"dir_id\": 1 }, |
96f1cbef LC |
54 | { \"name\": \"two\", |
55 | \"type\": \"regular\", | |
56 | \"length\": 456, | |
57 | \"dir_id\": 2 } ]") | |
58 | ||
59 | (define-syntax-rule (with-json-result str exp ...) | |
9323ab55 | 60 | (with-http-server `((200 ,str)) |
96f1cbef LC |
61 | (parameterize ((%swh-base-url (%local-url))) |
62 | exp ...))) | |
63 | ||
64 | (test-begin "swh") | |
65 | ||
66 | (test-equal "lookup-origin" | |
749b9582 | 67 | (list "git" "http://example.org/guix.git") |
96f1cbef LC |
68 | (with-json-result %origin |
69 | (let ((origin (lookup-origin "http://example.org/guix.git"))) | |
749b9582 | 70 | (list (origin-type origin) |
96f1cbef LC |
71 | (origin-url origin))))) |
72 | ||
73 | (test-equal "lookup-origin, not found" | |
74 | #f | |
9323ab55 | 75 | (with-http-server `((404 "Nope.")) |
96f1cbef LC |
76 | (parameterize ((%swh-base-url (%local-url))) |
77 | (lookup-origin "http://example.org/whatever")))) | |
78 | ||
5225732b LC |
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) | |
84 | (200 ,%visits)) | |
85 | (parameterize ((%swh-base-url (%local-url))) | |
86 | (let ((origin (lookup-origin "http://example.org/whatever"))) | |
87 | (match (origin-visits origin) | |
88 | ((visit) | |
89 | (list (visit-origin visit) | |
90 | (date->string (visit-date visit) "~4") | |
91 | (visit-snapshot-url visit)))))))) | |
92 | ||
96f1cbef LC |
93 | (test-equal "lookup-directory" |
94 | '(("one" 123) ("two" 456)) | |
95 | (with-json-result %directory-entries | |
96 | (map (lambda (entry) | |
97 | (list (directory-entry-name entry) | |
98 | (directory-entry-length entry))) | |
99 | (lookup-directory "123")))) | |
100 | ||
ba1c1853 LC |
101 | (test-equal "rate limit reached" |
102 | 3000000000 | |
103 | (let ((too-many (build-response | |
104 | #:code 429 | |
105 | #:reason-phrase "Too many requests" | |
106 | ||
107 | ;; Pretend we've reached the limit and it'll be reset in | |
108 | ;; June 2065. | |
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))) | |
113 | (catch 'swh-error | |
114 | (lambda () | |
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))))))) | |
119 | ||
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?' | |
123 | ;; returns true. | |
124 | (let* ((key (gensym "skip-request")) | |
125 | (skip-if-limit-reached | |
126 | (lambda (url method) | |
127 | (or (not (request-rate-limit-reached? url method)) | |
128 | (throw key #t))))) | |
129 | (parameterize ((%allow-request? skip-if-limit-reached)) | |
130 | (catch key | |
131 | (lambda () | |
132 | (lookup-origin "http://example.org/guix.git") | |
133 | #f) | |
134 | (const #t))))) | |
135 | ||
96f1cbef LC |
136 | (test-end "swh") |
137 | ||
138 | ;; Local Variables: | |
139 | ;; eval: (put 'with-json-result 'scheme-indent-function 1) | |
9323ab55 | 140 | ;; eval: (put 'with-http-server 'scheme-indent-function 1) |
96f1cbef LC |
141 | ;; End: |
142 |