Commit | Line | Data |
---|---|---|
523e4896 | 1 | ;;; GNU Guix --- Functional package management for GNU |
240b57f0 | 2 | ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> |
b8300494 | 3 | ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> |
523e4896 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 system) | |
b25937e3 | 21 | #:use-module (guix config) |
523e4896 LC |
22 | #:use-module (guix ui) |
23 | #:use-module (guix store) | |
7573d30f | 24 | #:use-module (guix grafts) |
72b9d60d | 25 | #:use-module (guix gexp) |
523e4896 LC |
26 | #:use-module (guix derivations) |
27 | #:use-module (guix packages) | |
28 | #:use-module (guix utils) | |
29 | #:use-module (guix monads) | |
5b516ef3 | 30 | #:use-module (guix records) |
b25937e3 | 31 | #:use-module (guix profiles) |
88981dd3 | 32 | #:use-module (guix scripts) |
523e4896 | 33 | #:use-module (guix scripts build) |
8fb58371 | 34 | #:use-module (guix graph) |
d6c3267a | 35 | #:use-module (guix scripts graph) |
72b9d60d | 36 | #:use-module (guix build utils) |
548f7a8f | 37 | #:use-module (gnu build install) |
7889394e | 38 | #:use-module (gnu system) |
9110c2e9 | 39 | #:use-module (gnu system file-systems) |
1c8a81b1 | 40 | #:use-module (gnu system linux-container) |
523e4896 | 41 | #:use-module (gnu system vm) |
c79d54fe | 42 | #:use-module (gnu system grub) |
d6c3267a | 43 | #:use-module (gnu services) |
0190c1c0 | 44 | #:use-module (gnu services shepherd) |
240b57f0 | 45 | #:use-module (gnu services herd) |
c79d54fe | 46 | #:use-module (gnu packages grub) |
523e4896 | 47 | #:use-module (srfi srfi-1) |
240b57f0 | 48 | #:use-module (srfi srfi-11) |
906b1b09 | 49 | #:use-module (srfi srfi-19) |
72b9d60d | 50 | #:use-module (srfi srfi-26) |
65797bff LC |
51 | #:use-module (srfi srfi-34) |
52 | #:use-module (srfi srfi-35) | |
523e4896 LC |
53 | #:use-module (srfi srfi-37) |
54 | #:use-module (ice-9 match) | |
c52bf877 | 55 | #:use-module (rnrs bytevectors) |
731b9962 LC |
56 | #:export (guix-system |
57 | read-operating-system)) | |
523e4896 | 58 | |
8e42796b LC |
59 | \f |
60 | ;;; | |
61 | ;;; Operating system declaration. | |
62 | ;;; | |
63 | ||
523e4896 LC |
64 | (define %user-module |
65 | ;; Module in which the machine description file is loaded. | |
7ea1432e DT |
66 | (make-user-module '((gnu system) |
67 | (gnu services) | |
68 | (gnu system shadow)))) | |
523e4896 LC |
69 | |
70 | (define (read-operating-system file) | |
71 | "Read the operating-system declaration from FILE and return it." | |
7ea1432e | 72 | (load* file %user-module)) |
523e4896 | 73 | |
523e4896 | 74 | |
8e42796b LC |
75 | \f |
76 | ;;; | |
77 | ;;; Installation. | |
78 | ;;; | |
79 | ||
80 | ;; TODO: Factorize. | |
81 | (define references* | |
82 | (store-lift references)) | |
83 | (define topologically-sorted* | |
84 | (store-lift topologically-sorted)) | |
8e42796b LC |
85 | |
86 | ||
8334cf5b LC |
87 | (define* (copy-item item target |
88 | #:key (log-port (current-error-port))) | |
c56d19fb | 89 | "Copy ITEM to the store under root directory TARGET and register it." |
8e42796b | 90 | (mlet* %store-monad ((refs (references* item))) |
a52127c0 LC |
91 | (let ((dest (string-append target item)) |
92 | (state (string-append target "/var/guix"))) | |
8e42796b | 93 | (format log-port "copying '~a'...~%" item) |
78acff7c LC |
94 | |
95 | ;; Remove DEST if it exists to make sure that (1) we do not fail badly | |
96 | ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and | |
97 | ;; (2) we end up with the right contents. | |
98 | (when (file-exists? dest) | |
99 | (delete-file-recursively dest)) | |
100 | ||
8e42796b LC |
101 | (copy-recursively item dest |
102 | #:log (%make-void-port "w")) | |
103 | ||
104 | ;; Register ITEM; as a side-effect, it resets timestamps, etc. | |
a52127c0 LC |
105 | ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid |
106 | ;; reproducing the user's current settings; see | |
107 | ;; <http://bugs.gnu.org/18049>. | |
8e42796b LC |
108 | (unless (register-path item |
109 | #:prefix target | |
a52127c0 | 110 | #:state-directory state |
8e42796b LC |
111 | #:references refs) |
112 | (leave (_ "failed to register '~a' under '~a'~%") | |
113 | item target)) | |
114 | ||
115 | (return #t)))) | |
116 | ||
8334cf5b LC |
117 | (define* (copy-closure item target |
118 | #:key (log-port (current-error-port))) | |
119 | "Copy ITEM and all its dependencies to the store under root directory | |
120 | TARGET, and register them." | |
121 | (mlet* %store-monad ((refs (references* item)) | |
122 | (to-copy (topologically-sorted* | |
123 | (delete-duplicates (cons item refs) | |
124 | string=?)))) | |
125 | (sequence %store-monad | |
126 | (map (cut copy-item <> target #:log-port log-port) | |
127 | to-copy)))) | |
128 | ||
c3e79cde LC |
129 | (define (install-grub* grub.cfg device target) |
130 | "This is a variant of 'install-grub' with error handling, lifted in | |
131 | %STORE-MONAD" | |
16210486 LC |
132 | (let* ((gc-root (string-append target %gc-roots-directory |
133 | "/grub.cfg")) | |
6412e58a LC |
134 | (temp-gc-root (string-append gc-root ".new")) |
135 | (delete-file (lift1 delete-file %store-monad)) | |
136 | (make-symlink (lift2 switch-symlinks %store-monad)) | |
137 | (rename (lift2 rename-file %store-monad))) | |
39d1f82b | 138 | (mbegin %store-monad |
6412e58a LC |
139 | ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when |
140 | ;; 'install-grub' completes (being a bit paranoid.) | |
141 | (make-symlink temp-gc-root grub.cfg) | |
142 | ||
39d1f82b | 143 | (munless (false-if-exception (install-grub grub.cfg device target)) |
6412e58a | 144 | (delete-file temp-gc-root) |
39d1f82b LC |
145 | (leave (_ "failed to install GRUB on device '~a'~%") device)) |
146 | ||
147 | ;; Register GRUB.CFG as a GC root so that its dependencies (background | |
148 | ;; image, font, etc.) are not reclaimed. | |
6412e58a | 149 | (rename temp-gc-root gc-root)))) |
c3e79cde | 150 | |
8e42796b | 151 | (define* (install os-drv target |
c79d54fe LC |
152 | #:key (log-port (current-output-port)) |
153 | grub? grub.cfg device) | |
f245b03d LC |
154 | "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to |
155 | directory TARGET. TARGET must be an absolute directory name since that's what | |
156 | 'guix-register' expects. | |
c79d54fe LC |
157 | |
158 | When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." | |
8e42796b LC |
159 | (define (maybe-copy to-copy) |
160 | (with-monad %store-monad | |
161 | (if (string=? target "/") | |
162 | (begin | |
163 | (warning (_ "initializing the current root file system~%")) | |
164 | (return #t)) | |
165 | (begin | |
166 | ;; Make sure the target store exists. | |
167 | (mkdir-p (string-append target (%store-prefix))) | |
168 | ||
169 | ;; Copy items to the new store. | |
8334cf5b | 170 | (copy-closure to-copy target #:log-port log-port))))) |
8e42796b | 171 | |
4a35a866 LC |
172 | ;; Make sure TARGET is root-owned when running as root, but still allow |
173 | ;; non-root uses (useful for testing.) See | |
174 | ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>. | |
175 | (if (zero? (geteuid)) | |
176 | (chown target 0 0) | |
177 | (warning (_ "not running as 'root', so \ | |
178 | the ownership of '~a' may be incorrect!~%") | |
179 | target)) | |
180 | ||
181 | (chmod target #o755) | |
cc7fa592 | 182 | (let ((os-dir (derivation->output-path os-drv)) |
c9e46f1c LC |
183 | (format (lift format %store-monad)) |
184 | (populate (lift2 populate-root-file-system %store-monad))) | |
cc7fa592 LC |
185 | |
186 | (mbegin %store-monad | |
f245b03d LC |
187 | ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's |
188 | ;; background image and so on. | |
189 | (maybe-copy grub.cfg) | |
cc7fa592 LC |
190 | |
191 | ;; Create a bunch of additional files. | |
192 | (format log-port "populating '~a'...~%" target) | |
193 | (populate os-dir target) | |
194 | ||
c3e79cde LC |
195 | (mwhen grub? |
196 | (install-grub* grub.cfg device target))))) | |
72b9d60d | 197 | |
523e4896 | 198 | \f |
b25937e3 LC |
199 | ;;; |
200 | ;;; Reconfiguration. | |
201 | ;;; | |
202 | ||
203 | (define %system-profile | |
204 | ;; The system profile. | |
205 | (string-append %state-directory "/profiles/system")) | |
206 | ||
720ee245 LC |
207 | (define-syntax-rule (save-environment-excursion body ...) |
208 | "Save the current environment variables, run BODY..., and restore them." | |
209 | (let ((env (environ))) | |
210 | (dynamic-wind | |
211 | (const #t) | |
212 | (lambda () | |
213 | body ...) | |
214 | (lambda () | |
215 | (environ env))))) | |
216 | ||
cfd50320 LC |
217 | (define-syntax-rule (save-load-path-excursion body ...) |
218 | "Save the current values of '%load-path' and '%load-compiled-path', run | |
219 | BODY..., and restore them." | |
220 | (let ((path %load-path) | |
221 | (cpath %load-compiled-path)) | |
222 | (dynamic-wind | |
223 | (const #t) | |
224 | (lambda () | |
225 | body ...) | |
226 | (lambda () | |
227 | (set! %load-path path) | |
228 | (set! %load-compiled-path cpath))))) | |
229 | ||
1d6b7d58 LC |
230 | (define-syntax-rule (warn-on-system-error body ...) |
231 | (catch 'system-error | |
232 | (lambda () | |
233 | body ...) | |
234 | (lambda (key proc format-string format-args errno . rest) | |
235 | (warning (_ "while talking to shepherd: ~a~%") | |
236 | (apply format #f format-string format-args)) | |
237 | (with-monad %store-monad | |
238 | (return #f))))) | |
239 | ||
aa1e73a9 LC |
240 | (define-syntax-rule (with-shepherd-error-handling mbody ...) |
241 | "Catch and report Shepherd errors that arise when binding MBODY, a monadic | |
242 | expression in %STORE-MONAD." | |
243 | (lambda (store) | |
244 | (warn-on-system-error | |
245 | (guard (c ((shepherd-error? c) | |
9d1e56b7 | 246 | (values (report-shepherd-error c) store))) |
aa1e73a9 LC |
247 | (values (run-with-store store (begin mbody ...)) |
248 | store))))) | |
8bf92e39 LC |
249 | |
250 | (define (report-shepherd-error error) | |
251 | "Report ERROR, a '&shepherd-error' error condition object." | |
252 | (cond ((service-not-found-error? error) | |
253 | (report-error (_ "service '~a' could not be found~%") | |
254 | (service-not-found-error-service error))) | |
255 | ((action-not-found-error? error) | |
256 | (report-error (_ "service '~a' does not have an action '~a'~%") | |
257 | (action-not-found-error-service error) | |
258 | (action-not-found-error-action error))) | |
259 | ((action-exception-error? error) | |
260 | (report-error (_ "exception caught while executing '~a' \ | |
261 | on service '~a':~%") | |
262 | (action-exception-error-action error) | |
263 | (action-exception-error-service error)) | |
264 | (print-exception (current-error-port) #f | |
265 | (action-exception-error-key error) | |
266 | (action-exception-error-arguments error))) | |
267 | ((unknown-shepherd-error? error) | |
268 | (report-error (_ "something went wrong: ~s~%") | |
269 | (unknown-shepherd-error-sexp error))) | |
270 | ((shepherd-error? error) | |
271 | (report-error (_ "shepherd error~%"))) | |
272 | ((not error) ;not an error | |
273 | #t))) | |
274 | ||
275 | (define (call-with-service-upgrade-info new-services mproc) | |
276 | "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of | |
277 | names of services to load (upgrade), and the list of names of services to | |
278 | unload." | |
279 | (define (essential? service) | |
280 | (memq service '(root shepherd))) | |
281 | ||
282 | (define new-service-names | |
283 | (map (compose first shepherd-service-provision) | |
284 | new-services)) | |
285 | ||
183605c8 LC |
286 | (match (current-services) |
287 | ((services ...) | |
288 | (let* ((running (map (compose first live-service-provision) | |
289 | (filter live-service-running services))) | |
290 | (stopped (map (compose first live-service-provision) | |
291 | (remove live-service-running services))) | |
292 | (to-load | |
293 | ;; Only load services that are either new or currently stopped. | |
294 | (remove (lambda (service) | |
295 | (memq (first (shepherd-service-provision service)) | |
296 | running)) | |
297 | new-services)) | |
298 | (to-unload | |
299 | ;; Unload services that are (1) no longer required, or (2) are | |
300 | ;; in TO-LOAD. | |
301 | (remove essential? | |
302 | (append (remove (lambda (service) | |
303 | (memq service new-service-names)) | |
304 | (append running stopped)) | |
305 | (filter (lambda (service) | |
306 | (memq service stopped)) | |
307 | (map shepherd-service-canonical-name | |
308 | to-load)))))) | |
309 | (mproc to-load to-unload))) | |
310 | (#f | |
311 | (with-monad %store-monad | |
312 | (warning (_ "failed to obtain list of shepherd services~%")) | |
313 | (return #f))))) | |
8bf92e39 | 314 | |
240b57f0 LC |
315 | (define (upgrade-shepherd-services os) |
316 | "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new | |
317 | services specified in OS and not currently running. | |
318 | ||
319 | This is currently very conservative in that it does not stop or unload any | |
320 | running service. Unloading or stopping the wrong service ('udev', say) could | |
321 | bring the system down." | |
240b57f0 LC |
322 | (define new-services |
323 | (service-parameters | |
324 | (fold-services (operating-system-services os) | |
325 | #:target-type shepherd-root-service-type))) | |
326 | ||
8bf92e39 LC |
327 | ;; Arrange to simply emit a warning if the service upgrade fails. |
328 | (with-shepherd-error-handling | |
329 | (call-with-service-upgrade-info new-services | |
330 | (lambda (to-load to-unload) | |
331 | (for-each (lambda (unload) | |
332 | (info (_ "unloading service '~a'...~%") unload) | |
333 | (unload-service unload)) | |
334 | to-unload) | |
335 | ||
336 | (with-monad %store-monad | |
337 | (munless (null? to-load) | |
338 | (let ((to-load-names (map shepherd-service-canonical-name to-load)) | |
339 | (to-start (filter shepherd-service-auto-start? to-load))) | |
340 | (info (_ "loading new services:~{ ~a~}...~%") to-load-names) | |
341 | (mlet %store-monad ((files (mapm %store-monad shepherd-service-file | |
342 | to-load))) | |
343 | ;; Here we assume that FILES are exactly those that were computed | |
344 | ;; as part of the derivation that built OS, which is normally the | |
345 | ;; case. | |
346 | (load-services (map derivation->output-path files)) | |
347 | ||
348 | (for-each start-service | |
349 | (map shepherd-service-canonical-name to-start)) | |
350 | (return #t))))))))) | |
240b57f0 | 351 | |
8e42796b LC |
352 | (define* (switch-to-system os |
353 | #:optional (profile %system-profile)) | |
354 | "Make a new generation of PROFILE pointing to the directory of OS, switch to | |
355 | it atomically, and then run OS's activation script." | |
356 | (mlet* %store-monad ((drv (operating-system-derivation os)) | |
357 | (script (operating-system-activation-script os))) | |
358 | (let* ((system (derivation->output-path drv)) | |
359 | (number (+ 1 (generation-number profile))) | |
360 | (generation (generation-file-name profile number))) | |
361 | (symlink system generation) | |
362 | (switch-symlinks profile generation) | |
363 | ||
364 | (format #t (_ "activating system...~%")) | |
720ee245 LC |
365 | |
366 | ;; The activation script may change $PATH, among others, so protect | |
367 | ;; against that. | |
240b57f0 LC |
368 | (save-environment-excursion |
369 | ;; Tell 'activate-current-system' what the new system is. | |
370 | (setenv "GUIX_NEW_SYSTEM" system) | |
6d49355d | 371 | |
cfd50320 LC |
372 | ;; The activation script may modify '%load-path' & co., so protect |
373 | ;; against that. This is necessary to ensure that | |
374 | ;; 'upgrade-shepherd-services' gets to see the right modules when it | |
66a35ceb | 375 | ;; computes derivations with 'gexp->derivation'. |
cfd50320 LC |
376 | (save-load-path-excursion |
377 | (primitive-load (derivation->output-path script)))) | |
8e42796b | 378 | |
240b57f0 LC |
379 | ;; Finally, try to update system services. |
380 | (upgrade-shepherd-services os)))) | |
b25937e3 LC |
381 | |
382 | (define-syntax-rule (unless-file-not-found exp) | |
383 | (catch 'system-error | |
384 | (lambda () | |
385 | exp) | |
386 | (lambda args | |
387 | (if (= ENOENT (system-error-errno args)) | |
388 | #f | |
389 | (apply throw args))))) | |
390 | ||
906b1b09 LC |
391 | (define (seconds->string seconds) |
392 | "Return a string representing the date for SECONDS." | |
393 | (let ((time (make-time time-utc 0 seconds))) | |
394 | (date->string (time-utc->date time) | |
395 | "~Y-~m-~d ~H:~M"))) | |
396 | ||
b25937e3 LC |
397 | (define* (previous-grub-entries #:optional (profile %system-profile)) |
398 | "Return a list of 'menu-entry' for the generations of PROFILE." | |
906b1b09 | 399 | (define (system->grub-entry system number time) |
b25937e3 | 400 | (unless-file-not-found |
b8300494 AK |
401 | (let* ((file (string-append system "/parameters")) |
402 | (params (call-with-input-file file | |
403 | read-boot-parameters)) | |
404 | (label (boot-parameters-label params)) | |
405 | (root (boot-parameters-root-device params)) | |
c52bf877 MW |
406 | (root-device (if (bytevector? root) |
407 | (uuid->string root) | |
408 | root)) | |
b8300494 AK |
409 | (kernel (boot-parameters-kernel params)) |
410 | (kernel-arguments (boot-parameters-kernel-arguments params))) | |
411 | (menu-entry | |
412 | (label (string-append label " (#" | |
413 | (number->string number) ", " | |
414 | (seconds->string time) ")")) | |
415 | (linux kernel) | |
416 | (linux-arguments | |
c52bf877 | 417 | (cons* (string-append "--root=" root-device) |
b8300494 AK |
418 | #~(string-append "--system=" #$system) |
419 | #~(string-append "--load=" #$system "/boot") | |
420 | kernel-arguments)) | |
421 | (initrd #~(string-append #$system "/initrd")))))) | |
b25937e3 | 422 | |
906b1b09 LC |
423 | (let* ((numbers (generation-numbers profile)) |
424 | (systems (map (cut generation-file-name profile <>) | |
425 | numbers)) | |
426 | (times (map (lambda (system) | |
427 | (unless-file-not-found | |
428 | (stat:mtime (lstat system)))) | |
429 | systems))) | |
430 | (filter-map system->grub-entry systems numbers times))) | |
b25937e3 LC |
431 | |
432 | \f | |
d6c3267a | 433 | ;;; |
6f305ea5 | 434 | ;;; Graphs. |
d6c3267a LC |
435 | ;;; |
436 | ||
437 | (define (service-node-label service) | |
438 | "Return a label to represent SERVICE." | |
439 | (let ((type (service-kind service)) | |
440 | (value (service-parameters service))) | |
441 | (string-append (symbol->string (service-type-name type)) | |
442 | (cond ((or (number? value) (symbol? value)) | |
443 | (string-append " " (object->string value))) | |
444 | ((string? value) | |
445 | (string-append " " value)) | |
446 | ((file-system? value) | |
447 | (string-append " " (file-system-mount-point value))) | |
448 | (else | |
449 | ""))))) | |
450 | ||
451 | (define (service-node-type services) | |
452 | "Return a node type for SERVICES. Since <service> instances are not | |
453 | self-contained (they express dependencies on service types, not on services), | |
454 | we have to create the 'edges' procedure dynamically as a function of the full | |
455 | list of services." | |
456 | (node-type | |
457 | (name "service") | |
458 | (description "the DAG of services") | |
459 | (identifier (lift1 object-address %store-monad)) | |
460 | (label service-node-label) | |
461 | (edges (lift1 (service-back-edges services) %store-monad)))) | |
462 | ||
710fa231 | 463 | (define (shepherd-service-node-label service) |
d4053c71 AK |
464 | "Return a label for a node representing a <shepherd-service>." |
465 | (string-join (map symbol->string (shepherd-service-provision service)))) | |
6f305ea5 | 466 | |
710fa231 | 467 | (define (shepherd-service-node-type services) |
d4053c71 | 468 | "Return a node type for SERVICES, a list of <shepherd-service>." |
6f305ea5 | 469 | (node-type |
710fa231 AK |
470 | (name "shepherd-service") |
471 | (description "the dependency graph of shepherd services") | |
472 | (identifier (lift1 shepherd-service-node-label %store-monad)) | |
473 | (label shepherd-service-node-label) | |
d4053c71 | 474 | (edges (lift1 (shepherd-service-back-edges services) %store-monad)))) |
d6c3267a LC |
475 | |
476 | \f | |
65797bff LC |
477 | ;;; |
478 | ;;; Generations. | |
479 | ;;; | |
480 | ||
481 | (define* (display-system-generation number | |
482 | #:optional (profile %system-profile)) | |
483 | "Display a summary of system generation NUMBER in a human-readable format." | |
484 | (unless (zero? number) | |
c52bf877 MW |
485 | (let* ((generation (generation-file-name profile number)) |
486 | (param-file (string-append generation "/parameters")) | |
487 | (params (call-with-input-file param-file read-boot-parameters)) | |
488 | (label (boot-parameters-label params)) | |
489 | (root (boot-parameters-root-device params)) | |
490 | (root-device (if (bytevector? root) | |
491 | (uuid->string root) | |
492 | root)) | |
493 | (kernel (boot-parameters-kernel params))) | |
65797bff LC |
494 | (display-generation profile number) |
495 | (format #t (_ " file name: ~a~%") generation) | |
496 | (format #t (_ " canonical file name: ~a~%") (readlink* generation)) | |
b8300494 AK |
497 | ;; TRANSLATORS: Please preserve the two-space indentation. |
498 | (format #t (_ " label: ~a~%") label) | |
c52bf877 | 499 | (format #t (_ " root device: ~a~%") root-device) |
b8300494 | 500 | (format #t (_ " kernel: ~a~%") kernel)))) |
65797bff LC |
501 | |
502 | (define* (list-generations pattern #:optional (profile %system-profile)) | |
503 | "Display in a human-readable format all the system generations matching | |
504 | PATTERN, a string. When PATTERN is #f, display all the system generations." | |
505 | (cond ((not (file-exists? profile)) ; XXX: race condition | |
506 | (raise (condition (&profile-not-found-error | |
507 | (profile profile))))) | |
508 | ((string-null? pattern) | |
509 | (for-each display-system-generation (profile-generations profile))) | |
510 | ((matching-generations pattern profile) | |
511 | => | |
512 | (lambda (numbers) | |
513 | (if (null-list? numbers) | |
514 | (exit 1) | |
515 | (leave-on-EPIPE | |
516 | (for-each display-system-generation numbers))))) | |
517 | (else | |
518 | (leave (_ "invalid syntax: ~a~%") pattern)))) | |
519 | ||
520 | \f | |
8e42796b LC |
521 | ;;; |
522 | ;;; Action. | |
523 | ;;; | |
524 | ||
525 | (define* (system-derivation-for-action os action | |
0276f697 | 526 | #:key image-size full-boot? mappings) |
8e42796b LC |
527 | "Return as a monadic value the derivation for OS according to ACTION." |
528 | (case action | |
529 | ((build init reconfigure) | |
530 | (operating-system-derivation os)) | |
1c8a81b1 DT |
531 | ((container) |
532 | (container-script os #:mappings mappings)) | |
8e42796b LC |
533 | ((vm-image) |
534 | (system-qemu-image os #:disk-image-size image-size)) | |
535 | ((vm) | |
6aa260af LC |
536 | (system-qemu-image/shared-store-script os |
537 | #:full-boot? full-boot? | |
4c0416ae LC |
538 | #:disk-image-size |
539 | (if full-boot? | |
540 | image-size | |
541 | (* 30 (expt 2 20))) | |
0276f697 | 542 | #:mappings mappings)) |
8e42796b LC |
543 | ((disk-image) |
544 | (system-disk-image os #:disk-image-size image-size)))) | |
545 | ||
7f949db0 LC |
546 | (define (maybe-suggest-running-guix-pull) |
547 | "Suggest running 'guix pull' if this has never been done before." | |
548 | ;; The reason for this is that the 'guix' binding that we see here comes | |
549 | ;; from either ~/.config/latest or, if it's missing, from the | |
550 | ;; globally-installed Guix, which is necessarily older. See | |
551 | ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for | |
552 | ;; a discussion. | |
553 | (define latest | |
554 | (string-append (config-directory) "/latest")) | |
555 | ||
556 | (unless (file-exists? latest) | |
557 | (warning (_ "~a not found: 'guix pull' was never run~%") latest) | |
558 | (warning (_ "Consider running 'guix pull' before 'reconfigure'.~%")) | |
559 | (warning (_ "Failing to do that may downgrade your system!~%")))) | |
560 | ||
8e42796b | 561 | (define* (perform-action action os |
f3f427c2 | 562 | #:key grub? dry-run? derivations-only? |
8e42796b | 563 | use-substitutes? device target |
0276f697 LC |
564 | image-size full-boot? |
565 | (mappings '())) | |
8e42796b LC |
566 | "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is |
567 | the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE | |
568 | is the size of the image to be built, for the 'vm-image' and 'disk-image' | |
ab11f0be | 569 | actions. FULL-BOOT? is used for the 'vm' action; it determines whether to |
f3f427c2 LC |
570 | boot directly to the kernel or to the bootloader. |
571 | ||
572 | When DERIVATIONS-ONLY? is true, print the derivation file name(s) without | |
573 | building anything." | |
574 | (define println | |
575 | (cut format #t "~a~%" <>)) | |
576 | ||
7f949db0 LC |
577 | (when (eq? action 'reconfigure) |
578 | (maybe-suggest-running-guix-pull)) | |
579 | ||
8e42796b LC |
580 | (mlet* %store-monad |
581 | ((sys (system-derivation-for-action os action | |
ab11f0be | 582 | #:image-size image-size |
0276f697 LC |
583 | #:full-boot? full-boot? |
584 | #:mappings mappings)) | |
8e42796b | 585 | (grub (package->derivation grub)) |
1c8a81b1 DT |
586 | (grub.cfg (if (eq? 'container action) |
587 | (return #f) | |
588 | (operating-system-grub.cfg os | |
589 | (if (eq? 'init action) | |
590 | '() | |
591 | (previous-grub-entries))))) | |
a7043618 LC |
592 | |
593 | ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if | |
594 | ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC | |
595 | ;; root. See <http://bugs.gnu.org/21068>. | |
596 | (drvs -> (if (memq action '(init reconfigure)) | |
597 | (if grub? | |
598 | (list sys grub.cfg grub) | |
599 | (list sys grub.cfg)) | |
8e42796b | 600 | (list sys))) |
f3f427c2 LC |
601 | (% (if derivations-only? |
602 | (return (for-each (compose println derivation-file-name) | |
603 | drvs)) | |
604 | (maybe-build drvs #:dry-run? dry-run? | |
605 | #:use-substitutes? use-substitutes?)))) | |
8e42796b | 606 | |
f3f427c2 | 607 | (if (or dry-run? derivations-only?) |
8e42796b LC |
608 | (return #f) |
609 | (begin | |
f3f427c2 LC |
610 | (for-each (compose println derivation->output-path) |
611 | drvs) | |
8e42796b LC |
612 | |
613 | ;; Make sure GRUB is accessible. | |
614 | (when grub? | |
615 | (let ((prefix (derivation->output-path grub))) | |
616 | (setenv "PATH" | |
617 | (string-append prefix "/bin:" prefix "/sbin:" | |
618 | (getenv "PATH"))))) | |
619 | ||
620 | (case action | |
621 | ((reconfigure) | |
c3e79cde LC |
622 | (mbegin %store-monad |
623 | (switch-to-system os) | |
624 | (mwhen grub? | |
625 | (install-grub* (derivation->output-path grub.cfg) | |
626 | device "/")))) | |
8e42796b LC |
627 | ((init) |
628 | (newline) | |
629 | (format #t (_ "initializing operating system under '~a'...~%") | |
630 | target) | |
631 | (install sys (canonicalize-path target) | |
632 | #:grub? grub? | |
633 | #:grub.cfg (derivation->output-path grub.cfg) | |
634 | #:device device)) | |
635 | (else | |
636 | ;; All we had to do was to build SYS. | |
637 | (return (derivation->output-path sys)))))))) | |
638 | ||
d6c3267a LC |
639 | (define (export-extension-graph os port) |
640 | "Export the service extension graph of OS to PORT." | |
641 | (let* ((services (operating-system-services os)) | |
d62e201c LC |
642 | (system (find (lambda (service) |
643 | (eq? (service-kind service) system-service-type)) | |
d6c3267a | 644 | services))) |
d62e201c | 645 | (export-graph (list system) (current-output-port) |
d6c3267a LC |
646 | #:node-type (service-node-type services) |
647 | #:reverse-edges? #t))) | |
648 | ||
710fa231 | 649 | (define (export-shepherd-graph os port) |
d4053c71 AK |
650 | "Export the graph of shepherd services of OS to PORT." |
651 | (let* ((services (operating-system-services os)) | |
652 | (pid1 (fold-services services | |
653 | #:target-type shepherd-root-service-type)) | |
654 | (shepherds (service-parameters pid1)) ;list of <shepherd-service> | |
655 | (sinks (filter (lambda (service) | |
656 | (null? (shepherd-service-requirement service))) | |
657 | shepherds))) | |
6f305ea5 | 658 | (export-graph sinks (current-output-port) |
710fa231 | 659 | #:node-type (shepherd-service-node-type shepherds) |
6f305ea5 LC |
660 | #:reverse-edges? #t))) |
661 | ||
8e42796b | 662 | \f |
523e4896 LC |
663 | ;;; |
664 | ;;; Options. | |
665 | ;;; | |
666 | ||
667 | (define (show-help) | |
65797bff | 668 | (display (_ "Usage: guix system [OPTION] ACTION [FILE] |
523e4896 | 669 | Build the operating system declared in FILE according to ACTION.\n")) |
7889394e LC |
670 | (newline) |
671 | (display (_ "The valid values for ACTION are:\n")) | |
2a4e2e4b | 672 | (newline) |
7889394e | 673 | (display (_ "\ |
2a4e2e4b | 674 | reconfigure switch to a new operating system configuration\n")) |
65797bff LC |
675 | (display (_ "\ |
676 | list-generations list the system generations\n")) | |
b25937e3 | 677 | (display (_ "\ |
2a4e2e4b | 678 | build build the operating system without installing anything\n")) |
1c8a81b1 | 679 | (display (_ "\ |
fbd213a8 | 680 | container build a container that shares the host's store\n")) |
7889394e | 681 | (display (_ "\ |
2a4e2e4b | 682 | vm build a virtual machine image that shares the host's store\n")) |
7889394e | 683 | (display (_ "\ |
2a4e2e4b | 684 | vm-image build a freestanding virtual machine image\n")) |
72b9d60d | 685 | (display (_ "\ |
2a4e2e4b | 686 | disk-image build a disk image, suitable for a USB stick\n")) |
fb729425 | 687 | (display (_ "\ |
d6c3267a LC |
688 | init initialize a root file system to run GNU\n")) |
689 | (display (_ "\ | |
690 | extension-graph emit the service extension graph in Dot format\n")) | |
6f305ea5 | 691 | (display (_ "\ |
710fa231 | 692 | shepherd-graph emit the graph of shepherd services in Dot format\n")) |
7889394e | 693 | |
523e4896 | 694 | (show-build-options-help) |
f3f427c2 LC |
695 | (display (_ " |
696 | -d, --derivation return the derivation of the given system")) | |
db030303 LC |
697 | (display (_ " |
698 | --on-error=STRATEGY | |
699 | apply STRATEGY when an error occurs while reading FILE")) | |
2e7b5cea LC |
700 | (display (_ " |
701 | --image-size=SIZE for 'vm-image', produce an image of SIZE")) | |
c79d54fe LC |
702 | (display (_ " |
703 | --no-grub for 'init', do not install GRUB")) | |
0276f697 LC |
704 | (display (_ " |
705 | --share=SPEC for 'vm', share host file system according to SPEC")) | |
706 | (display (_ " | |
707 | --expose=SPEC for 'vm', expose host file system according to SPEC")) | |
ab11f0be LC |
708 | (display (_ " |
709 | --full-boot for 'vm', make a full boot sequence")) | |
523e4896 LC |
710 | (newline) |
711 | (display (_ " | |
712 | -h, --help display this help and exit")) | |
713 | (display (_ " | |
714 | -V, --version display version information and exit")) | |
715 | (newline) | |
716 | (show-bug-report-information)) | |
717 | ||
718 | (define %options | |
719 | ;; Specifications of the command-line options. | |
720 | (cons* (option '(#\h "help") #f #f | |
721 | (lambda args | |
722 | (show-help) | |
723 | (exit 0))) | |
724 | (option '(#\V "version") #f #f | |
725 | (lambda args | |
726 | (show-version-and-exit "guix system"))) | |
f3f427c2 LC |
727 | (option '(#\d "derivation") #f #f |
728 | (lambda (opt name arg result) | |
729 | (alist-cons 'derivations-only? #t result))) | |
db030303 LC |
730 | (option '("on-error") #t #f |
731 | (lambda (opt name arg result) | |
732 | (alist-cons 'on-error (string->symbol arg) | |
733 | result))) | |
2e7b5cea LC |
734 | (option '("image-size") #t #f |
735 | (lambda (opt name arg result) | |
736 | (alist-cons 'image-size (size->number arg) | |
737 | result))) | |
c79d54fe LC |
738 | (option '("no-grub") #f #f |
739 | (lambda (opt name arg result) | |
6e1a7d17 | 740 | (alist-cons 'install-grub? #f result))) |
ab11f0be LC |
741 | (option '("full-boot") #f #f |
742 | (lambda (opt name arg result) | |
743 | (alist-cons 'full-boot? #t result))) | |
0276f697 LC |
744 | |
745 | (option '("share") #t #f | |
746 | (lambda (opt name arg result) | |
747 | (alist-cons 'file-system-mapping | |
748 | (specification->file-system-mapping arg #t) | |
749 | result))) | |
750 | (option '("expose") #t #f | |
751 | (lambda (opt name arg result) | |
752 | (alist-cons 'file-system-mapping | |
753 | (specification->file-system-mapping arg #f) | |
754 | result))) | |
755 | ||
523e4896 LC |
756 | (option '(#\n "dry-run") #f #f |
757 | (lambda (opt name arg result) | |
fd59105c | 758 | (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) |
df2ce343 LC |
759 | (option '(#\s "system") #t #f |
760 | (lambda (opt name arg result) | |
761 | (alist-cons 'system arg | |
762 | (alist-delete 'system result eq?)))) | |
523e4896 LC |
763 | %standard-build-options)) |
764 | ||
765 | (define %default-options | |
766 | ;; Alist of default option values. | |
767 | `((system . ,(%current-system)) | |
768 | (substitutes? . #t) | |
7573d30f | 769 | (graft? . #t) |
523e4896 LC |
770 | (build-hook? . #t) |
771 | (max-silent-time . 3600) | |
2e7b5cea | 772 | (verbosity . 0) |
c79d54fe LC |
773 | (image-size . ,(* 900 (expt 2 20))) |
774 | (install-grub? . #t))) | |
523e4896 LC |
775 | |
776 | \f | |
777 | ;;; | |
778 | ;;; Entry point. | |
779 | ;;; | |
780 | ||
deaab8e3 | 781 | (define (process-action action args opts) |
65797bff LC |
782 | "Process ACTION, a sub-command, with the arguments are listed in ARGS. |
783 | ACTION must be one of the sub-commands that takes an operating system | |
784 | declaration as an argument (a file name.) OPTS is the raw alist of options | |
785 | resulting from command-line parsing." | |
deaab8e3 LC |
786 | (let* ((file (match args |
787 | (() #f) | |
788 | ((x . _) x))) | |
789 | (system (assoc-ref opts 'system)) | |
790 | (os (if file | |
791 | (load* file %user-module | |
792 | #:on-error (assoc-ref opts 'on-error)) | |
793 | (leave (_ "no configuration file specified~%")))) | |
794 | ||
795 | (dry? (assoc-ref opts 'dry-run?)) | |
796 | (grub? (assoc-ref opts 'install-grub?)) | |
797 | (target (match args | |
798 | ((first second) second) | |
799 | (_ #f))) | |
800 | (device (and grub? | |
801 | (grub-configuration-device | |
802 | (operating-system-bootloader os))))) | |
803 | ||
804 | (with-store store | |
805 | (set-build-options-from-command-line store opts) | |
806 | ||
807 | (run-with-store store | |
808 | (mbegin %store-monad | |
809 | (set-guile-for-build (default-guile)) | |
810 | (case action | |
811 | ((extension-graph) | |
812 | (export-extension-graph os (current-output-port))) | |
710fa231 AK |
813 | ((shepherd-graph) |
814 | (export-shepherd-graph os (current-output-port))) | |
deaab8e3 LC |
815 | (else |
816 | (perform-action action os | |
817 | #:dry-run? dry? | |
818 | #:derivations-only? (assoc-ref opts | |
819 | 'derivations-only?) | |
820 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
821 | #:image-size (assoc-ref opts 'image-size) | |
822 | #:full-boot? (assoc-ref opts 'full-boot?) | |
823 | #:mappings (filter-map (match-lambda | |
824 | (('file-system-mapping . m) | |
825 | m) | |
826 | (_ #f)) | |
827 | opts) | |
828 | #:grub? grub? | |
829 | #:target target #:device device)))) | |
830 | #:system system)))) | |
831 | ||
65797bff LC |
832 | (define (process-command command args opts) |
833 | "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its | |
834 | argument list and OPTS is the option alist." | |
835 | (case command | |
836 | ((list-generations) | |
837 | ;; List generations. No need to connect to the daemon, etc. | |
838 | (let ((pattern (match args | |
839 | (() "") | |
840 | ((pattern) pattern) | |
841 | (x (leave (_ "wrong number of arguments~%")))))) | |
842 | (list-generations pattern))) | |
843 | (else | |
844 | (process-action command args opts)))) | |
845 | ||
523e4896 | 846 | (define (guix-system . args) |
b3f21389 LC |
847 | (define (parse-sub-command arg result) |
848 | ;; Parse sub-command ARG and augment RESULT accordingly. | |
849 | (if (assoc-ref result 'action) | |
850 | (alist-cons 'argument arg result) | |
851 | (let ((action (string->symbol arg))) | |
852 | (case action | |
1c8a81b1 | 853 | ((build container vm vm-image disk-image reconfigure init |
710fa231 | 854 | extension-graph shepherd-graph list-generations) |
b3f21389 LC |
855 | (alist-cons 'action action result)) |
856 | (else (leave (_ "~a: unknown action~%") action)))))) | |
523e4896 | 857 | |
72b9d60d LC |
858 | (define (match-pair car) |
859 | ;; Return a procedure that matches a pair with CAR. | |
860 | (match-lambda | |
d6c3267a LC |
861 | ((head . tail) |
862 | (and (eq? car head) tail)) | |
863 | (_ #f))) | |
72b9d60d LC |
864 | |
865 | (define (option-arguments opts) | |
866 | ;; Extract the plain arguments from OPTS. | |
867 | (let* ((args (reverse (filter-map (match-pair 'argument) opts))) | |
868 | (count (length args)) | |
869 | (action (assoc-ref opts 'action))) | |
870 | (define (fail) | |
871 | (leave (_ "wrong number of arguments for action '~a'~%") | |
872 | action)) | |
873 | ||
d89e0990 LC |
874 | (unless action |
875 | (format (current-error-port) | |
876 | (_ "guix system: missing command name~%")) | |
877 | (format (current-error-port) | |
878 | (_ "Try 'guix system --help' for more information.~%")) | |
879 | (exit 1)) | |
880 | ||
72b9d60d | 881 | (case action |
1c8a81b1 | 882 | ((build container vm vm-image disk-image reconfigure) |
72b9d60d LC |
883 | (unless (= count 1) |
884 | (fail))) | |
885 | ((init) | |
886 | (unless (= count 2) | |
887 | (fail)))) | |
888 | args)) | |
889 | ||
523e4896 | 890 | (with-error-handling |
b3f21389 LC |
891 | (let* ((opts (parse-command-line args %options |
892 | (list %default-options) | |
893 | #:argument-handler | |
894 | parse-sub-command)) | |
c79d54fe | 895 | (args (option-arguments opts)) |
deaab8e3 | 896 | (command (assoc-ref opts 'action))) |
7573d30f LC |
897 | (parameterize ((%graft? (assoc-ref opts 'graft?))) |
898 | (process-command command args opts))))) | |
b25937e3 | 899 | |
8bf92e39 LC |
900 | ;;; Local Variables: |
901 | ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) | |
902 | ;;; End: | |
903 | ||
b25937e3 | 904 | ;;; system.scm ends here |