projects/guix·blob java-team · refs

235 lines · 8.3 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019-2021, 2024 Ludovic Courtès <[email protected]>
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 base32)
22 #:use-module (guix tests http)
23 #:use-module (web response)
24 #:use-module (srfi srfi-19)
25 #:use-module (srfi srfi-64)
26 #:use-module (ice-9 match))
27
28;; Test the JSON mapping machinery used in (guix swh).
29
30(define %origin
31 "{ \"origin_visits_url\": \"/visits/42\",
32 \"type\": \"git\",
33 \"url\": \"http://example.org/guix.git\" }")
34
35(define %visits
36 ;; A single visit where 'snapshot_url' is null.
37 ;; See <https://bugs.gnu.org/45615>.
38 "[ {
39 \"origin\": \"https://github.com/Genivia/ugrep\",
40 \"visit\": 1,
41 \"date\": \"2020-05-17T21:43:45.422977+00:00\",
42 \"status\": \"ongoing\",
43 \"snapshot\": null,
44 \"metadata\": {},
45 \"type\": \"git\",
46 \"origin_visit_url\": \"https://archive.softwareheritage.org/api/1/origin/https://github.com/Genivia/ugrep/visit/1/\",
47 \"snapshot_url\": null
48 } ]")
49
50(define %directory-entries
51 "[ { \"name\": \"one\",
52 \"type\": \"regular\",
53 \"length\": 123,
54 \"dir_id\": 1 },
55 { \"name\": \"two\",
56 \"type\": \"regular\",
57 \"length\": 456,
58 \"dir_id\": 2 } ]")
59
60(define %external-id
61 "{ \"extid_type\": \"nar-sha256\",
62 \"extid\":
63\"0b56ba94c2b83b8f74e3772887c1109135802eb3e8962b628377987fe97e1e63\",
64 \"version\": 0,
65 \"target\": \"swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153\",
66 \"target_url\":
67\"https://archive.softwareheritage.org/swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153\"
68 }")
69
70(define-syntax-rule (with-json-result str exp ...)
71 (with-http-server `((200 ,str))
72 (parameterize ((%swh-base-url (%local-url)))
73 exp ...)))
74
75(test-begin "swh")
76
77(test-equal "lookup-origin"
78 (list "git" "http://example.org/guix.git")
79 (with-json-result %origin
80 (let ((origin (lookup-origin "http://example.org/guix.git")))
81 (list (origin-type origin)
82 (origin-url origin)))))
83
84(test-equal "lookup-origin, not found"
85 #f
86 (with-http-server `((404 "Nope."))
87 (parameterize ((%swh-base-url (%local-url)))
88 (lookup-origin "http://example.org/whatever"))))
89
90(test-equal "origin-visit, no snapshots"
91 '("https://github.com/Genivia/ugrep"
92 "2020-05-17T21:43:45Z"
93 #f) ;see <https://bugs.gnu.org/45615>
94 (with-http-server `((200 ,%origin)
95 (200 ,%visits))
96 (parameterize ((%swh-base-url (%local-url)))
97 (let ((origin (lookup-origin "http://example.org/whatever")))
98 (match (origin-visits origin)
99 ((visit)
100 (list (visit-origin visit)
101 (date->string (visit-date visit) "~4")
102 (visit-snapshot-url visit))))))))
103
104(test-equal "lookup-directory"
105 '(("one" 123) ("two" 456))
106 (with-json-result %directory-entries
107 (map (lambda (entry)
108 (list (directory-entry-name entry)
109 (directory-entry-length entry)))
110 (lookup-directory "123"))))
111
112(test-equal "lookup-origin-revision"
113 '("cd86c72084993d9ef26fc9e24b73cea612b8c97b"
114 "d173c707ee88e3c89401ad77fafa65fcd9e9f5be")
115 (let ()
116 ;; Make sure that 'lookup-origin-revision' does the job, and in particular
117 ;; that it doesn't stop until it has found an actual revision:
118 ;; 'git-checkout visits point to directories instead of revisions.
119 ;; See <https://issues.guix.gnu.org/69070>.
120 (define visits
121 ;; Two visits of differing types: the first visit (type 'git-checkout')
122 ;; points to a directory, the second one (type 'git') points to a
123 ;; revision.
124 "[ {
125 \"origin\": \"https://example.org/repo.git\",
126 \"visit\": 1,
127 \"type\": \"git-checkout\",
128 \"date\": \"2020-05-17T21:43:45.422977+00:00\",
129 \"status\": \"full\",
130 \"metadata\": {},
131 \"type\": \"git-checkout\",
132 \"origin_visit_url\": \"/visit/42\",
133 \"snapshot_url\": \"/snapshot/1\"
134 }, {
135 \"origin\": \"https://example.org/repo.git\",
136 \"visit\": 2,
137 \"type\": \"git\",
138 \"date\": \"2020-05-17T21:43:49.422977+00:00\",
139 \"status\": \"full\",
140 \"metadata\": {},
141 \"type\": \"git\",
142 \"origin_visit_url\": \"/visit/41\",
143 \"snapshot_url\": \"/snapshot/2\"
144 } ]")
145 (define snapshot-for-git-checkout
146 "{ \"id\": 42,
147 \"branches\": { \"1.3.2\": {
148 \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\",
149 \"target_type\": \"directory\",
150 \"target_url\": \"/directory/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\"
151 }}
152 }")
153 (define snapshot-for-git
154 "{ \"id\": 42,
155 \"branches\": { \"1.3.2\": {
156 \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\",
157 \"target_type\": \"revision\",
158 \"target_url\": \"/revision/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\"
159 }}
160 }")
161 (define revision
162 "{ \"author\": {},
163 \"committer\": {},
164 \"committer_date\": \"2018-05-17T21:43:49.422977+00:00\",
165 \"date\": \"2018-05-17T21:43:49.422977+00:00\",
166 \"directory\": \"d173c707ee88e3c89401ad77fafa65fcd9e9f5be\",
167 \"directory_url\": \"/directory/d173c707ee88e3c89401ad77fafa65fcd9e9f5be\",
168 \"id\": \"cd86c72084993d9ef26fc9e24b73cea612b8c97b\",
169 \"merge\": false,
170 \"message\": \"Fix.\",
171 \"parents\": [],
172 \"type\": \"what type?\"
173 }")
174
175 (with-http-server `((200 ,%origin)
176 (200 ,visits)
177 (200 ,snapshot-for-git-checkout)
178 (200 ,snapshot-for-git)
179 (200 ,revision))
180 (parameterize ((%swh-base-url (%local-url)))
181 (let ((revision (lookup-origin-revision "https://example.org/repo.git"
182 "1.3.2")))
183 (list (revision-id revision)
184 (revision-directory revision)))))))
185
186(test-equal "lookup-directory-by-nar-hash"
187 "swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153"
188 (with-json-result %external-id
189 (lookup-directory-by-nar-hash
190 (nix-base32-string->bytevector
191 "0qqygvlpz63phdi2p5p8ncp80dci230qfa3pwds8yfxqqaablmhb")
192 'sha256)))
193
194(test-equal "rate limit reached"
195 3000000000
196 (let ((too-many (build-response
197 #:code 429
198 #:reason-phrase "Too many requests"
199
200 ;; Pretend we've reached the limit and it'll be reset in
201 ;; June 2065.
202 #:headers '((x-ratelimit-remaining . "0")
203 (x-ratelimit-reset . "3000000000")))))
204 (with-http-server `((,too-many "Too bad."))
205 (parameterize ((%swh-base-url (%local-url)))
206 (catch 'swh-error
207 (lambda ()
208 (lookup-origin "http://example.org/guix.git"))
209 (lambda (key url method response)
210 ;; Ensure the reset time was recorded.
211 (@@ (guix swh) %general-rate-limit-reset-time)))))))
212
213(test-assert "%allow-request? and request-rate-limit-reached?"
214 ;; Here we test two things: that the rate limit set above is in effect and
215 ;; that %ALLOW-REQUEST? is called, and that 'request-rate-limit-reached?'
216 ;; returns true.
217 (let* ((key (gensym "skip-request"))
218 (skip-if-limit-reached
219 (lambda (url method)
220 (or (not (request-rate-limit-reached? url method))
221 (throw key #t)))))
222 (parameterize ((%allow-request? skip-if-limit-reached))
223 (catch key
224 (lambda ()
225 (lookup-origin "http://example.org/guix.git")
226 #f)
227 (const #t)))))
228
229(test-end "swh")
230
231;; Local Variables:
232;; eval: (put 'with-json-result 'scheme-indent-function 1)
233;; eval: (put 'with-http-server 'scheme-indent-function 1)
234;; End:
235