| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
| 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) |
| 22 | #:use-module (web response) |
| 23 | #:use-module (srfi srfi-64)) |
| 24 | |
| 25 | ;; Test the JSON mapping machinery used in (guix swh). |
| 26 | |
| 27 | (define %origin |
| 28 | "{ \"visits_url\": \"/visits/42\", |
| 29 | \"type\": \"git\", |
| 30 | \"url\": \"http://example.org/guix.git\" }") |
| 31 | |
| 32 | (define %directory-entries |
| 33 | "[ { \"name\": \"one\", |
| 34 | \"type\": \"regular\", |
| 35 | \"length\": 123, |
| 36 | \"dir_id\": 1 }, |
| 37 | { \"name\": \"two\", |
| 38 | \"type\": \"regular\", |
| 39 | \"length\": 456, |
| 40 | \"dir_id\": 2 } ]") |
| 41 | |
| 42 | (define-syntax-rule (with-json-result str exp ...) |
| 43 | (with-http-server `((200 ,str)) |
| 44 | (parameterize ((%swh-base-url (%local-url))) |
| 45 | exp ...))) |
| 46 | |
| 47 | (test-begin "swh") |
| 48 | |
| 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))))) |
| 55 | |
| 56 | (test-equal "lookup-origin, not found" |
| 57 | #f |
| 58 | (with-http-server `((404 "Nope.")) |
| 59 | (parameterize ((%swh-base-url (%local-url))) |
| 60 | (lookup-origin "http://example.org/whatever")))) |
| 61 | |
| 62 | (test-equal "lookup-directory" |
| 63 | '(("one" 123) ("two" 456)) |
| 64 | (with-json-result %directory-entries |
| 65 | (map (lambda (entry) |
| 66 | (list (directory-entry-name entry) |
| 67 | (directory-entry-length entry))) |
| 68 | (lookup-directory "123")))) |
| 69 | |
| 70 | (test-equal "rate limit reached" |
| 71 | 3000000000 |
| 72 | (let ((too-many (build-response |
| 73 | #:code 429 |
| 74 | #:reason-phrase "Too many requests" |
| 75 | |
| 76 | ;; Pretend we've reached the limit and it'll be reset in |
| 77 | ;; June 2065. |
| 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))) |
| 82 | (catch 'swh-error |
| 83 | (lambda () |
| 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))))))) |
| 88 | |
| 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?' |
| 92 | ;; returns true. |
| 93 | (let* ((key (gensym "skip-request")) |
| 94 | (skip-if-limit-reached |
| 95 | (lambda (url method) |
| 96 | (or (not (request-rate-limit-reached? url method)) |
| 97 | (throw key #t))))) |
| 98 | (parameterize ((%allow-request? skip-if-limit-reached)) |
| 99 | (catch key |
| 100 | (lambda () |
| 101 | (lookup-origin "http://example.org/guix.git") |
| 102 | #f) |
| 103 | (const #t))))) |
| 104 | |
| 105 | (test-end "swh") |
| 106 | |
| 107 | ;; Local Variables: |
| 108 | ;; eval: (put 'with-json-result 'scheme-indent-function 1) |
| 109 | ;; eval: (put 'with-http-server 'scheme-indent-function 1) |
| 110 | ;; End: |
| 111 | |