Commit | Line | Data |
---|---|---|
aff8ce7c DT |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2015 David Thompson <davet@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 | ||
c74f0cb2 LC |
19 | ;; Avoid interference. |
20 | (unsetenv "http_proxy") | |
21 | ||
aff8ce7c DT |
22 | (define-module (test-publish) |
23 | #:use-module (guix scripts publish) | |
24 | #:use-module (guix tests) | |
25 | #:use-module (guix config) | |
26 | #:use-module (guix utils) | |
27 | #:use-module (guix hash) | |
28 | #:use-module (guix store) | |
ff6638d1 LC |
29 | #:use-module (guix derivations) |
30 | #:use-module (guix gexp) | |
aff8ce7c DT |
31 | #:use-module (guix base32) |
32 | #:use-module (guix base64) | |
4a1fc562 | 33 | #:use-module ((guix records) #:select (recutils->alist)) |
aff8ce7c DT |
34 | #:use-module ((guix serialization) #:select (restore-file)) |
35 | #:use-module (guix pk-crypto) | |
4a1fc562 | 36 | #:use-module (guix zlib) |
93961f02 | 37 | #:use-module (web uri) |
aff8ce7c DT |
38 | #:use-module (web client) |
39 | #:use-module (web response) | |
40 | #:use-module (rnrs bytevectors) | |
4a1fc562 | 41 | #:use-module (ice-9 binary-ports) |
aff8ce7c DT |
42 | #:use-module (srfi srfi-1) |
43 | #:use-module (srfi srfi-26) | |
44 | #:use-module (srfi srfi-64) | |
93961f02 | 45 | #:use-module (ice-9 format) |
aff8ce7c DT |
46 | #:use-module (ice-9 match) |
47 | #:use-module (ice-9 rdelim)) | |
48 | ||
49 | (define %store | |
50 | (open-connection-for-tests)) | |
51 | ||
52 | (define %reference (add-text-to-store %store "ref" "foo")) | |
53 | ||
54 | (define %item (add-text-to-store %store "item" "bar" (list %reference))) | |
55 | ||
56 | (define (http-get-body uri) | |
57 | (call-with-values (lambda () (http-get uri)) | |
58 | (lambda (response body) body))) | |
59 | ||
4a1fc562 LC |
60 | (define (http-get-port uri) |
61 | (call-with-values (lambda () (http-get uri #:streaming? #t)) | |
62 | (lambda (response port) port))) | |
63 | ||
aff8ce7c DT |
64 | (define (publish-uri route) |
65 | (string-append "http://localhost:6789" route)) | |
66 | ||
67 | ;; Run a local publishing server in a separate thread. | |
68 | (call-with-new-thread | |
69 | (lambda () | |
4a1fc562 LC |
70 | (guix-publish "--port=6789" "-C0"))) ;attempt to avoid port collision |
71 | ||
72 | (define (wait-until-ready port) | |
73 | ;; Wait until the server is accepting connections. | |
74 | (let ((conn (socket PF_INET SOCK_STREAM 0))) | |
75 | (let loop () | |
76 | (unless (false-if-exception | |
77 | (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port)) | |
78 | (loop))))) | |
aff8ce7c | 79 | |
4a1fc562 LC |
80 | ;; Wait until the two servers are ready. |
81 | (wait-until-ready 6789) | |
aff8ce7c | 82 | |
c74f0cb2 | 83 | \f |
aff8ce7c DT |
84 | (test-begin "publish") |
85 | ||
86 | (test-equal "/nix-cache-info" | |
87 | (format #f "StoreDir: ~a\nWantMassQuery: 0\nPriority: 100\n" | |
88 | %store-directory) | |
89 | (http-get-body (publish-uri "/nix-cache-info"))) | |
90 | ||
91 | (test-equal "/*.narinfo" | |
92 | (let* ((info (query-path-info %store %item)) | |
93 | (unsigned-info | |
94 | (format #f | |
95 | "StorePath: ~a | |
96 | URL: nar/~a | |
97 | Compression: none | |
98 | NarHash: sha256:~a | |
99 | NarSize: ~d | |
100 | References: ~a~%" | |
101 | %item | |
102 | (basename %item) | |
9cced526 | 103 | (bytevector->nix-base32-string |
aff8ce7c DT |
104 | (path-info-hash info)) |
105 | (path-info-nar-size info) | |
106 | (basename (first (path-info-references info))))) | |
107 | (signature (base64-encode | |
108 | (string->utf8 | |
109 | (canonical-sexp->string | |
110 | ((@@ (guix scripts publish) signed-string) | |
111 | unsigned-info)))))) | |
112 | (format #f "~aSignature: 1;~a;~a~%" | |
113 | unsigned-info (gethostname) signature)) | |
114 | (utf8->string | |
115 | (http-get-body | |
116 | (publish-uri | |
117 | (string-append "/" (store-path-hash-part %item) ".narinfo"))))) | |
118 | ||
93961f02 LC |
119 | (test-equal "/*.narinfo with properly encoded '+' sign" |
120 | ;; See <http://bugs.gnu.org/21888>. | |
121 | (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!")) | |
122 | (info (query-path-info %store item)) | |
123 | (unsigned-info | |
124 | (format #f | |
125 | "StorePath: ~a | |
126 | URL: nar/~a | |
127 | Compression: none | |
128 | NarHash: sha256:~a | |
129 | NarSize: ~d | |
130 | References: ~%" | |
131 | item | |
132 | (uri-encode (basename item)) | |
133 | (bytevector->nix-base32-string | |
134 | (path-info-hash info)) | |
135 | (path-info-nar-size info))) | |
136 | (signature (base64-encode | |
137 | (string->utf8 | |
138 | (canonical-sexp->string | |
139 | ((@@ (guix scripts publish) signed-string) | |
140 | unsigned-info)))))) | |
141 | (format #f "~aSignature: 1;~a;~a~%" | |
142 | unsigned-info (gethostname) signature)) | |
143 | ||
144 | (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))) | |
145 | (utf8->string | |
146 | (http-get-body | |
147 | (publish-uri | |
148 | (string-append "/" (store-path-hash-part item) ".narinfo")))))) | |
149 | ||
aff8ce7c DT |
150 | (test-equal "/nar/*" |
151 | "bar" | |
152 | (call-with-temporary-output-file | |
153 | (lambda (temp port) | |
154 | (let ((nar (utf8->string | |
155 | (http-get-body | |
156 | (publish-uri | |
157 | (string-append "/nar/" (basename %item))))))) | |
158 | (call-with-input-string nar (cut restore-file <> temp))) | |
159 | (call-with-input-file temp read-string)))) | |
160 | ||
4a1fc562 LC |
161 | (unless (zlib-available?) |
162 | (test-skip 1)) | |
163 | (test-equal "/nar/gzip/*" | |
164 | "bar" | |
165 | (call-with-temporary-output-file | |
166 | (lambda (temp port) | |
167 | (let ((nar (http-get-port | |
168 | (publish-uri | |
169 | (string-append "/nar/gzip/" (basename %item)))))) | |
170 | (call-with-gzip-input-port nar | |
171 | (cut restore-file <> temp))) | |
172 | (call-with-input-file temp read-string)))) | |
173 | ||
174 | (unless (zlib-available?) | |
175 | (test-skip 1)) | |
176 | (test-equal "/*.narinfo with compression" | |
177 | `(("StorePath" . ,%item) | |
178 | ("URL" . ,(string-append "nar/gzip/" (basename %item))) | |
179 | ("Compression" . "gzip")) | |
180 | (let ((thread (call-with-new-thread | |
181 | (lambda () | |
182 | (guix-publish "--port=6799" "-C5"))))) | |
183 | (wait-until-ready 6799) | |
184 | (let* ((url (string-append "http://localhost:6799/" | |
185 | (store-path-hash-part %item) ".narinfo")) | |
186 | (body (http-get-port url))) | |
187 | (filter (lambda (item) | |
188 | (match item | |
189 | (("Compression" . _) #t) | |
190 | (("StorePath" . _) #t) | |
191 | (("URL" . _) #t) | |
192 | (_ #f))) | |
193 | (recutils->alist body))))) | |
194 | ||
93961f02 LC |
195 | (test-equal "/nar/ with properly encoded '+' sign" |
196 | "Congrats!" | |
197 | (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))) | |
198 | (call-with-temporary-output-file | |
199 | (lambda (temp port) | |
200 | (let ((nar (utf8->string | |
201 | (http-get-body | |
202 | (publish-uri | |
203 | (string-append "/nar/" (uri-encode (basename item)))))))) | |
204 | (call-with-input-string nar (cut restore-file <> temp))) | |
205 | (call-with-input-file temp read-string))))) | |
206 | ||
00435580 LC |
207 | (test-equal "/nar/invalid" |
208 | 404 | |
209 | (begin | |
210 | (call-with-output-file (string-append (%store-prefix) "/invalid") | |
211 | (lambda (port) | |
212 | (display "This file is not a valid store item." port))) | |
213 | (response-code (http-get (publish-uri (string-append "/nar/invalid")))))) | |
214 | ||
ff6638d1 LC |
215 | (test-equal "/file/NAME/sha256/HASH" |
216 | "Hello, Guix world!" | |
217 | (let* ((data "Hello, Guix world!") | |
218 | (hash (call-with-input-string data port-sha256)) | |
219 | (drv (run-with-store %store | |
220 | (gexp->derivation "the-file.txt" | |
221 | #~(call-with-output-file #$output | |
222 | (lambda (port) | |
223 | (display #$data port))) | |
224 | #:hash-algo 'sha256 | |
225 | #:hash hash))) | |
226 | (out (build-derivations %store (list drv)))) | |
227 | (utf8->string | |
228 | (http-get-body | |
229 | (publish-uri | |
230 | (string-append "/file/the-file.txt/sha256/" | |
231 | (bytevector->nix-base32-string hash))))))) | |
232 | ||
233 | (test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING" | |
234 | 404 | |
235 | (let ((uri (publish-uri | |
236 | "/file/the-file.txt/sha256/not-a-nix-base32-string"))) | |
237 | (response-code (http-get uri)))) | |
238 | ||
239 | (test-equal "/file/NAME/sha256/INVALID-HASH" | |
240 | 404 | |
241 | (let ((uri (publish-uri | |
242 | (string-append "/file/the-file.txt/sha256/" | |
243 | (bytevector->nix-base32-string | |
244 | (call-with-input-string "" port-sha256)))))) | |
245 | (response-code (http-get uri)))) | |
246 | ||
aff8ce7c | 247 | (test-end "publish") |