Commit | Line | Data |
---|---|---|
37ce440d | 1 | ;;; GNU Guix --- Functional package management for GNU |
d283bb96 | 2 | ;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
37ce440d 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 (guix build download-nar) | |
20 | #:use-module (guix build download) | |
21 | #:use-module (guix build utils) | |
8d49c80b | 22 | #:use-module ((guix serialization) #:hide (dump-port*)) |
e9f8a7e2 | 23 | #:autoload (zlib) (call-with-gzip-input-port) |
37ce440d LC |
24 | #:use-module (guix progress) |
25 | #:use-module (web uri) | |
26 | #:use-module (srfi srfi-11) | |
27 | #:use-module (srfi srfi-26) | |
28 | #:use-module (ice-9 format) | |
29 | #:use-module (ice-9 match) | |
30 | #:export (download-nar)) | |
31 | ||
32 | ;;; Commentary: | |
33 | ;;; | |
34 | ;;; Download a normalized archive or "nar", similar to what 'guix substitute' | |
35 | ;;; does. The intent here is to use substitute servers as content-addressed | |
36 | ;;; mirrors of VCS checkouts. This is mostly useful for users who have | |
37 | ;;; disabled substitutes. | |
38 | ;;; | |
39 | ;;; Code: | |
40 | ||
41 | (define (urls-for-item item) | |
42 | "Return the fallback nar URL for ITEM--e.g., | |
43 | \"/gnu/store/cabbag3…-foo-1.2-checkout\"." | |
44 | ;; Here we hard-code nar URLs without checking narinfos. That's probably OK | |
d283bb96 | 45 | ;; though. Use berlin.guix.gnu.org instead of its ci.guix.gnu.org front end to |
87a90486 | 46 | ;; avoid sending these requests to CDN providers without user consent. |
37ce440d | 47 | ;; TODO: Use HTTPS? The downside is the extra dependency. |
d283bb96 | 48 | (let ((bases '("http://berlin.guix.gnu.org")) |
37ce440d LC |
49 | (item (basename item))) |
50 | (append (map (cut string-append <> "/nar/gzip/" item) bases) | |
51 | (map (cut string-append <> "/nar/" item) bases)))) | |
52 | ||
53 | (define (restore-gzipped-nar port item size) | |
54 | "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to | |
55 | ITEM." | |
56 | ;; Since PORT is typically a non-file port (for instance because 'http-get' | |
57 | ;; returns a delimited port), create a child process so we're back to a file | |
58 | ;; port that can be passed to 'call-with-gzip-input-port'. | |
59 | (match (pipe) | |
60 | ((input . output) | |
61 | (match (primitive-fork) | |
62 | (0 | |
63 | (dynamic-wind | |
64 | (const #t) | |
65 | (lambda () | |
66 | (close-port output) | |
67 | (close-port port) | |
68 | (catch #t | |
69 | (lambda () | |
70 | (call-with-gzip-input-port input | |
71 | (cut restore-file <> item))) | |
72 | (lambda (key . args) | |
73 | (print-exception (current-error-port) | |
74 | (stack-ref (make-stack #t) 1) | |
75 | key args) | |
76 | (primitive-exit 1)))) | |
77 | (lambda () | |
78 | (primitive-exit 0)))) | |
79 | (child | |
80 | (close-port input) | |
81 | (dump-port* port output | |
82 | #:reporter (progress-reporter/file item size | |
83 | #:abbreviation | |
84 | store-path-abbreviation)) | |
85 | (close-port output) | |
86 | (newline) | |
87 | (match (waitpid child) | |
88 | ((_ . status) | |
89 | (unless (zero? status) | |
90 | (error "nar decompression failed" status))))))))) | |
91 | ||
92 | (define (download-nar item) | |
93 | "Download and extract the normalized archive for ITEM. Return #t on | |
94 | success, #f otherwise." | |
95 | ;; Let progress reports go through. | |
76832d34 LC |
96 | (setvbuf (current-error-port) 'none) |
97 | (setvbuf (current-output-port) 'none) | |
37ce440d LC |
98 | |
99 | (let loop ((urls (urls-for-item item))) | |
100 | (match urls | |
101 | ((url rest ...) | |
102 | (format #t "Trying content-addressed mirror at ~a...~%" | |
103 | (uri-host (string->uri url))) | |
104 | (let-values (((port size) | |
105 | (catch #t | |
106 | (lambda () | |
107 | (http-fetch (string->uri url))) | |
108 | (lambda args | |
109 | (values #f #f))))) | |
110 | (if (not port) | |
111 | (loop rest) | |
112 | (begin | |
113 | (if size | |
114 | (format #t "Downloading from ~a (~,2h MiB)...~%" url | |
115 | (/ size (expt 2 20.))) | |
116 | (format #t "Downloading from ~a...~%" url)) | |
117 | (if (string-contains url "/gzip") | |
118 | (restore-gzipped-nar port item size) | |
119 | (begin | |
120 | ;; FIXME: Add progress report. | |
121 | (restore-file port item) | |
122 | (close-port port))) | |
123 | #t)))) | |
124 | (() | |
125 | #f)))) |