Commit | Line | Data |
---|---|---|
f651b477 | 1 | ;;; GNU Guix --- Functional package management for GNU |
3df5acf3 | 2 | ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
7e81d699 | 3 | ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> |
f651b477 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix scripts pull) | |
21 | #:use-module (guix ui) | |
3bb168b0 | 22 | #:use-module (guix utils) |
88981dd3 | 23 | #:use-module (guix scripts) |
f651b477 LC |
24 | #:use-module (guix store) |
25 | #:use-module (guix config) | |
26 | #:use-module (guix packages) | |
27 | #:use-module (guix derivations) | |
78694457 | 28 | #:use-module (guix download) |
cb823dd2 LC |
29 | #:use-module (guix gexp) |
30 | #:use-module (guix monads) | |
f81ac34d LC |
31 | #:use-module ((guix build utils) |
32 | #:select (with-directory-excursion delete-file-recursively)) | |
7e81d699 MB |
33 | #:use-module ((guix build download) |
34 | #:select (%x509-certificate-directory)) | |
f651b477 | 35 | #:use-module (gnu packages base) |
bdb36958 | 36 | #:use-module (gnu packages guile) |
f651b477 LC |
37 | #:use-module ((gnu packages bootstrap) |
38 | #:select (%bootstrap-guile)) | |
7e81d699 | 39 | #:use-module ((gnu packages certs) #:select (le-certs)) |
f651b477 LC |
40 | #:use-module (gnu packages compression) |
41 | #:use-module (gnu packages gnupg) | |
42 | #:use-module (srfi srfi-1) | |
f81ac34d LC |
43 | #:use-module (srfi srfi-34) |
44 | #:use-module (srfi srfi-35) | |
f651b477 | 45 | #:use-module (srfi srfi-37) |
f81ac34d LC |
46 | #:use-module (ice-9 ftw) |
47 | #:use-module (ice-9 match) | |
f651b477 LC |
48 | #:export (guix-pull)) |
49 | ||
50 | (define %snapshot-url | |
fdfd3d5d | 51 | ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download" |
7e81d699 | 52 | "https://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz" |
f651b477 LC |
53 | ) |
54 | ||
f81ac34d LC |
55 | (define-syntax-rule (with-environment-variable variable value body ...) |
56 | (let ((original (getenv variable))) | |
57 | (dynamic-wind | |
58 | (lambda () | |
59 | (setenv variable value)) | |
60 | (lambda () | |
61 | body ...) | |
62 | (lambda () | |
63 | (setenv variable original))))) | |
f651b477 | 64 | |
f81ac34d LC |
65 | (define-syntax-rule (with-PATH value body ...) |
66 | (with-environment-variable "PATH" value body ...)) | |
f651b477 LC |
67 | |
68 | \f | |
69 | ;;; | |
70 | ;;; Command-line options. | |
71 | ;;; | |
72 | ||
73 | (define %default-options | |
74 | ;; Alist of default option values. | |
0ad7da1e | 75 | `((tarball-url . ,%snapshot-url))) |
f651b477 LC |
76 | |
77 | (define (show-help) | |
69daee23 | 78 | (display (G_ "Usage: guix pull [OPTION]... |
f651b477 | 79 | Download and deploy the latest version of Guix.\n")) |
69daee23 | 80 | (display (G_ " |
f651b477 | 81 | --verbose produce verbose output")) |
69daee23 | 82 | (display (G_ " |
0ad7da1e | 83 | --url=URL download the Guix tarball from URL")) |
69daee23 | 84 | (display (G_ " |
f651b477 LC |
85 | --bootstrap use the bootstrap Guile to build the new Guix")) |
86 | (newline) | |
69daee23 | 87 | (display (G_ " |
f651b477 | 88 | -h, --help display this help and exit")) |
69daee23 | 89 | (display (G_ " |
f651b477 LC |
90 | -V, --version display version information and exit")) |
91 | (newline) | |
92 | (show-bug-report-information)) | |
93 | ||
94 | (define %options | |
95 | ;; Specifications of the command-line options. | |
96 | (list (option '("verbose") #f #f | |
97 | (lambda (opt name arg result) | |
98 | (alist-cons 'verbose? #t result))) | |
0ad7da1e LC |
99 | (option '("url") #t #f |
100 | (lambda (opt name arg result) | |
101 | (alist-cons 'tarball-url arg | |
102 | (alist-delete 'tarball-url result)))) | |
f651b477 LC |
103 | (option '("bootstrap") #f #f |
104 | (lambda (opt name arg result) | |
105 | (alist-cons 'bootstrap? #t result))) | |
106 | ||
107 | (option '(#\h "help") #f #f | |
108 | (lambda args | |
109 | (show-help) | |
110 | (exit 0))) | |
111 | (option '(#\V "version") #f #f | |
112 | (lambda args | |
113 | (show-version-and-exit "guix pull"))))) | |
114 | ||
cb823dd2 LC |
115 | (define what-to-build |
116 | (store-lift show-what-to-build)) | |
117 | (define indirect-root-added | |
118 | (store-lift add-indirect-root)) | |
119 | ||
f81ac34d LC |
120 | (define (temporary-directory) |
121 | "Make a temporary directory and return its name." | |
122 | (let ((name (tmpnam))) | |
123 | (mkdir name) | |
124 | (chmod name #o700) | |
125 | name)) | |
126 | ||
127 | (define (first-directory directory) | |
128 | "Return a the name of the first file found under DIRECTORY." | |
129 | (match (scandir directory | |
130 | (lambda (name) | |
131 | (and (not (member name '("." ".."))) | |
132 | (file-is-directory? name)))) | |
133 | ((directory) | |
134 | directory) | |
135 | (x | |
136 | (raise (condition | |
137 | (&message | |
138 | (message "tarball did not produce a single source directory"))))))) | |
139 | ||
140 | (define (interned-then-deleted directory name) | |
141 | "Add DIRECTORY to the store under NAME, and delete it. Return the resulting | |
142 | store file name." | |
143 | (mlet %store-monad ((result (interned-file directory name | |
144 | #:recursive? #t))) | |
145 | (delete-file-recursively directory) | |
146 | (return result))) | |
147 | ||
148 | (define (unpack tarball) | |
149 | "Return the name of the directory where TARBALL has been unpacked." | |
150 | (mlet* %store-monad ((format -> (lift format %store-monad)) | |
151 | (tar (package->derivation tar)) | |
152 | (gzip (package->derivation gzip))) | |
153 | (mbegin %store-monad | |
154 | (what-to-build (list tar gzip)) | |
155 | (built-derivations (list tar gzip)) | |
69daee23 | 156 | (format #t (G_ "unpacking '~a'...~%") tarball) |
f81ac34d LC |
157 | |
158 | (let ((source (temporary-directory))) | |
159 | (with-directory-excursion source | |
160 | (with-PATH (string-append (derivation->output-path gzip) "/bin") | |
161 | (unless (zero? (system* (string-append (derivation->output-path tar) | |
162 | "/bin/tar") | |
163 | "xf" tarball)) | |
164 | (raise (condition | |
165 | (&message (message "failed to unpack source code")))))) | |
166 | ||
167 | (interned-then-deleted (string-append source "/" | |
168 | (first-directory source)) | |
169 | "guix-source")))))) | |
170 | ||
171 | (define %self-build-file | |
172 | ;; The file containing code to build Guix. This serves the same purpose as | |
173 | ;; a makefile, and, similarly, is intended to always keep this name. | |
174 | "build-aux/build-self.scm") | |
175 | ||
176 | (define* (build-from-source tarball #:key verbose?) | |
177 | "Return a derivation to build Guix from TARBALL, using the self-build script | |
178 | contained therein." | |
179 | ;; Running the self-build script makes it easier to update the build | |
180 | ;; procedure: the self-build script of the Guix-to-be-installed contains the | |
181 | ;; right dependencies, build procedure, etc., which the Guix-in-use may not | |
182 | ;; be know. | |
183 | (mlet* %store-monad ((source (unpack tarball)) | |
184 | (script -> (string-append source "/" | |
185 | %self-build-file)) | |
186 | (build -> (primitive-load script))) | |
187 | ;; BUILD must be a monadic procedure of at least one argument: the source | |
188 | ;; tree. | |
189 | (build source #:verbose? verbose?))) | |
190 | ||
cb823dd2 LC |
191 | (define* (build-and-install tarball config-dir |
192 | #:key verbose?) | |
193 | "Build the tool from TARBALL, and install it in CONFIG-DIR." | |
f81ac34d LC |
194 | (mlet* %store-monad ((source (build-from-source tarball |
195 | #:verbose? verbose?)) | |
cb823dd2 | 196 | (source-dir -> (derivation->output-path source)) |
3df5acf3 LC |
197 | (to-do? (what-to-build (list source))) |
198 | (built? (built-derivations (list source)))) | |
199 | ;; Always update the 'latest' symlink, regardless of whether SOURCE was | |
200 | ;; already built or not. | |
201 | (if built? | |
202 | (mlet* %store-monad | |
203 | ((latest -> (string-append config-dir "/latest")) | |
204 | (done (indirect-root-added latest))) | |
205 | (if (and (file-exists? latest) | |
206 | (string=? (readlink latest) source-dir)) | |
207 | (begin | |
69daee23 | 208 | (display (G_ "Guix already up to date\n")) |
3df5acf3 LC |
209 | (return #t)) |
210 | (begin | |
cb823dd2 LC |
211 | (switch-symlinks latest source-dir) |
212 | (format #t | |
69daee23 | 213 | (G_ "updated ~a successfully deployed under `~a'~%") |
cb823dd2 | 214 | %guix-package-name latest) |
3df5acf3 | 215 | (return #t)))) |
69daee23 | 216 | (leave (G_ "failed to update Guix, check the build log~%"))))) |
cb823dd2 | 217 | |
f651b477 LC |
218 | (define (guix-pull . args) |
219 | (define (parse-options) | |
220 | ;; Return the alist of option values. | |
a5975ced LC |
221 | (args-fold* args %options |
222 | (lambda (opt name arg result) | |
69daee23 | 223 | (leave (G_ "~A: unrecognized option~%") name)) |
a5975ced | 224 | (lambda (arg result) |
69daee23 | 225 | (leave (G_ "~A: unexpected argument~%") arg)) |
a5975ced | 226 | %default-options)) |
f651b477 | 227 | |
7e81d699 MB |
228 | (define (use-le-certs? url) |
229 | (string-prefix? "https://git.savannah.gnu.org/" url)) | |
230 | ||
231 | (define (fetch-tarball store url) | |
232 | (download-to-store store url "guix-latest.tar.gz")) | |
233 | ||
ef86c39f | 234 | (with-error-handling |
0ad7da1e LC |
235 | (let* ((opts (parse-options)) |
236 | (store (open-connection)) | |
237 | (url (assoc-ref opts 'tarball-url))) | |
7e81d699 MB |
238 | (let ((tarball |
239 | (if (use-le-certs? url) | |
240 | (let* ((drv (package-derivation store le-certs)) | |
241 | (certs (string-append (derivation->output-path drv) | |
242 | "/etc/ssl/certs"))) | |
243 | (build-derivations store (list drv)) | |
244 | (parameterize ((%x509-certificate-directory certs)) | |
245 | (fetch-tarball store url))) | |
246 | (fetch-tarball store url)))) | |
f651b477 | 247 | (unless tarball |
69daee23 | 248 | (leave (G_ "failed to download up-to-date source, exiting\n"))) |
f651b477 LC |
249 | (parameterize ((%guile-for-build |
250 | (package-derivation store | |
251 | (if (assoc-ref opts 'bootstrap?) | |
252 | %bootstrap-guile | |
b50c5b74 | 253 | (canonical-package guile-2.0))))) |
cb823dd2 LC |
254 | (run-with-store store |
255 | (build-and-install tarball (config-directory) | |
256 | #:verbose? (assoc-ref opts 'verbose?)))))))) | |
f81ac34d LC |
257 | |
258 | ;; Local Variables: | |
259 | ;; eval: (put 'with-PATH 'scheme-indent-function 1) | |
260 | ;; eval: (put 'with-temporary-directory 'scheme-indent-function 1) | |
261 | ;; End: | |
262 | ||
263 | ;;; pull.scm ends here |