You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

662 lines
25 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2014, 2015 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. (define-module (guix scripts system)
  19. #:use-module (guix config)
  20. #:use-module (guix ui)
  21. #:use-module (guix store)
  22. #:use-module (guix gexp)
  23. #:use-module (guix derivations)
  24. #:use-module (guix packages)
  25. #:use-module (guix utils)
  26. #:use-module (guix monads)
  27. #:use-module (guix profiles)
  28. #:use-module (guix scripts)
  29. #:use-module (guix scripts build)
  30. #:use-module (guix scripts graph)
  31. #:use-module (guix build utils)
  32. #:use-module (gnu build install)
  33. #:use-module (gnu system)
  34. #:use-module (gnu system file-systems)
  35. #:use-module (gnu system vm)
  36. #:use-module (gnu system grub)
  37. #:use-module (gnu services)
  38. #:use-module (gnu services dmd)
  39. #:use-module (gnu packages grub)
  40. #:use-module (srfi srfi-1)
  41. #:use-module (srfi srfi-19)
  42. #:use-module (srfi srfi-26)
  43. #:use-module (srfi srfi-37)
  44. #:use-module (ice-9 match)
  45. #:export (guix-system
  46. read-operating-system))
  47. ;;;
  48. ;;; Operating system declaration.
  49. ;;;
  50. (define %user-module
  51. ;; Module in which the machine description file is loaded.
  52. (make-user-module '((gnu system)
  53. (gnu services)
  54. (gnu system shadow))))
  55. (define (read-operating-system file)
  56. "Read the operating-system declaration from FILE and return it."
  57. (load* file %user-module))
  58. ;;;
  59. ;;; Installation.
  60. ;;;
  61. ;; TODO: Factorize.
  62. (define references*
  63. (store-lift references))
  64. (define topologically-sorted*
  65. (store-lift topologically-sorted))
  66. (define* (copy-item item target
  67. #:key (log-port (current-error-port)))
  68. "Copy ITEM to the store under root directory TARGET and register it."
  69. (mlet* %store-monad ((refs (references* item)))
  70. (let ((dest (string-append target item))
  71. (state (string-append target "/var/guix")))
  72. (format log-port "copying '~a'...~%" item)
  73. ;; Remove DEST if it exists to make sure that (1) we do not fail badly
  74. ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
  75. ;; (2) we end up with the right contents.
  76. (when (file-exists? dest)
  77. (delete-file-recursively dest))
  78. (copy-recursively item dest
  79. #:log (%make-void-port "w"))
  80. ;; Register ITEM; as a side-effect, it resets timestamps, etc.
  81. ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
  82. ;; reproducing the user's current settings; see
  83. ;; <http://bugs.gnu.org/18049>.
  84. (unless (register-path item
  85. #:prefix target
  86. #:state-directory state
  87. #:references refs)
  88. (leave (_ "failed to register '~a' under '~a'~%")
  89. item target))
  90. (return #t))))
  91. (define* (copy-closure item target
  92. #:key (log-port (current-error-port)))
  93. "Copy ITEM and all its dependencies to the store under root directory
  94. TARGET, and register them."
  95. (mlet* %store-monad ((refs (references* item))
  96. (to-copy (topologically-sorted*
  97. (delete-duplicates (cons item refs)
  98. string=?))))
  99. (sequence %store-monad
  100. (map (cut copy-item <> target #:log-port log-port)
  101. to-copy))))
  102. (define (install-grub* grub.cfg device target)
  103. "This is a variant of 'install-grub' with error handling, lifted in
  104. %STORE-MONAD"
  105. (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg"))
  106. (temp-gc-root (string-append gc-root ".new"))
  107. (delete-file (lift1 delete-file %store-monad))
  108. (make-symlink (lift2 switch-symlinks %store-monad))
  109. (rename (lift2 rename-file %store-monad)))
  110. (mbegin %store-monad
  111. ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when
  112. ;; 'install-grub' completes (being a bit paranoid.)
  113. (make-symlink temp-gc-root grub.cfg)
  114. (munless (false-if-exception (install-grub grub.cfg device target))
  115. (delete-file temp-gc-root)
  116. (leave (_ "failed to install GRUB on device '~a'~%") device))
  117. ;; Register GRUB.CFG as a GC root so that its dependencies (background
  118. ;; image, font, etc.) are not reclaimed.
  119. (rename temp-gc-root gc-root))))
  120. (define* (install os-drv target
  121. #:key (log-port (current-output-port))
  122. grub? grub.cfg device)
  123. "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to
  124. directory TARGET. TARGET must be an absolute directory name since that's what
  125. 'guix-register' expects.
  126. When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
  127. (define (maybe-copy to-copy)
  128. (with-monad %store-monad
  129. (if (string=? target "/")
  130. (begin
  131. (warning (_ "initializing the current root file system~%"))
  132. (return #t))
  133. (begin
  134. ;; Make sure the target store exists.
  135. (mkdir-p (string-append target (%store-prefix)))
  136. ;; Copy items to the new store.
  137. (copy-closure to-copy target #:log-port log-port)))))
  138. ;; Make sure TARGET is root-owned when running as root, but still allow
  139. ;; non-root uses (useful for testing.) See
  140. ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>.
  141. (if (zero? (geteuid))
  142. (chown target 0 0)
  143. (warning (_ "not running as 'root', so \
  144. the ownership of '~a' may be incorrect!~%")
  145. target))
  146. (chmod target #o755)
  147. (let ((os-dir (derivation->output-path os-drv))
  148. (format (lift format %store-monad))
  149. (populate (lift2 populate-root-file-system %store-monad)))
  150. (mbegin %store-monad
  151. ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's
  152. ;; background image and so on.
  153. (maybe-copy grub.cfg)
  154. ;; Create a bunch of additional files.
  155. (format log-port "populating '~a'...~%" target)
  156. (populate os-dir target)
  157. (mwhen grub?
  158. (install-grub* grub.cfg device target)))))
  159. ;;;
  160. ;;; Reconfiguration.
  161. ;;;
  162. (define %system-profile
  163. ;; The system profile.
  164. (string-append %state-directory "/profiles/system"))
  165. (define-syntax-rule (save-environment-excursion body ...)
  166. "Save the current environment variables, run BODY..., and restore them."
  167. (let ((env (environ)))
  168. (dynamic-wind
  169. (const #t)
  170. (lambda ()
  171. body ...)
  172. (lambda ()
  173. (environ env)))))
  174. (define* (switch-to-system os
  175. #:optional (profile %system-profile))
  176. "Make a new generation of PROFILE pointing to the directory of OS, switch to
  177. it atomically, and then run OS's activation script."
  178. (mlet* %store-monad ((drv (operating-system-derivation os))
  179. (script (operating-system-activation-script os)))
  180. (let* ((system (derivation->output-path drv))
  181. (number (+ 1 (generation-number profile)))
  182. (generation (generation-file-name profile number)))
  183. (symlink system generation)
  184. (switch-symlinks profile generation)
  185. (format #t (_ "activating system...~%"))
  186. ;; The activation script may change $PATH, among others, so protect
  187. ;; against that.
  188. (return (save-environment-excursion
  189. ;; Tell 'activate-current-system' what the new system is.
  190. (setenv "GUIX_NEW_SYSTEM" system)
  191. (primitive-load (derivation->output-path script))))
  192. ;; TODO: Run 'deco reload ...'.
  193. )))
  194. (define-syntax-rule (unless-file-not-found exp)
  195. (catch 'system-error
  196. (lambda ()
  197. exp)
  198. (lambda args
  199. (if (= ENOENT (system-error-errno args))
  200. #f
  201. (apply throw args)))))
  202. (define (seconds->string seconds)
  203. "Return a string representing the date for SECONDS."
  204. (let ((time (make-time time-utc 0 seconds)))
  205. (date->string (time-utc->date time)
  206. "~Y-~m-~d ~H:~M")))
  207. (define* (previous-grub-entries #:optional (profile %system-profile))
  208. "Return a list of 'menu-entry' for the generations of PROFILE."
  209. (define (system->grub-entry system number time)
  210. (unless-file-not-found
  211. (call-with-input-file (string-append system "/parameters")
  212. (lambda (port)
  213. (match (read port)
  214. (('boot-parameters ('version 0)
  215. ('label label) ('root-device root)
  216. ('kernel linux)
  217. rest ...)
  218. (menu-entry
  219. (label (string-append label " (#"
  220. (number->string number) ", "
  221. (seconds->string time) ")"))
  222. (linux linux)
  223. (linux-arguments
  224. (cons* (string-append "--root=" root)
  225. #~(string-append "--system=" #$system)
  226. #~(string-append "--load=" #$system "/boot")
  227. (match (assq 'kernel-arguments rest)
  228. ((_ args) args)
  229. (#f '())))) ;old format
  230. (initrd #~(string-append #$system "/initrd"))))
  231. (_ ;unsupported format
  232. (warning (_ "unrecognized boot parameters for '~a'~%")
  233. system)
  234. #f))))))
  235. (let* ((numbers (generation-numbers profile))
  236. (systems (map (cut generation-file-name profile <>)
  237. numbers))
  238. (times (map (lambda (system)
  239. (unless-file-not-found
  240. (stat:mtime (lstat system))))
  241. systems)))
  242. (filter-map system->grub-entry systems numbers times)))
  243. ;;;
  244. ;;; Graphs.
  245. ;;;
  246. (define (service-node-label service)
  247. "Return a label to represent SERVICE."
  248. (let ((type (service-kind service))
  249. (value (service-parameters service)))
  250. (string-append (symbol->string (service-type-name type))
  251. (cond ((or (number? value) (symbol? value))
  252. (string-append " " (object->string value)))
  253. ((string? value)
  254. (string-append " " value))
  255. ((file-system? value)
  256. (string-append " " (file-system-mount-point value)))
  257. (else
  258. "")))))
  259. (define (service-node-type services)
  260. "Return a node type for SERVICES. Since <service> instances are not
  261. self-contained (they express dependencies on service types, not on services),
  262. we have to create the 'edges' procedure dynamically as a function of the full
  263. list of services."
  264. (node-type
  265. (name "service")
  266. (description "the DAG of services")
  267. (identifier (lift1 object-address %store-monad))
  268. (label service-node-label)
  269. (edges (lift1 (service-back-edges services) %store-monad))))
  270. (define (dmd-service-node-label service)
  271. "Return a label for a node representing a <dmd-service>."
  272. (string-join (map symbol->string (dmd-service-provision service))))
  273. (define (dmd-service-node-type services)
  274. "Return a node type for SERVICES, a list of <dmd-service>."
  275. (node-type
  276. (name "dmd-service")
  277. (description "the dependency graph of dmd services")
  278. (identifier (lift1 dmd-service-node-label %store-monad))
  279. (label dmd-service-node-label)
  280. (edges (lift1 (dmd-service-back-edges services) %store-monad))))
  281. ;;;
  282. ;;; Action.
  283. ;;;
  284. (define* (system-derivation-for-action os action
  285. #:key image-size full-boot? mappings)
  286. "Return as a monadic value the derivation for OS according to ACTION."
  287. (case action
  288. ((build init reconfigure)
  289. (operating-system-derivation os))
  290. ((vm-image)
  291. (system-qemu-image os #:disk-image-size image-size))
  292. ((vm)
  293. (system-qemu-image/shared-store-script os
  294. #:full-boot? full-boot?
  295. #:disk-image-size image-size
  296. #:mappings mappings))
  297. ((disk-image)
  298. (system-disk-image os #:disk-image-size image-size))))
  299. (define* (perform-action action os
  300. #:key grub? dry-run? derivations-only?
  301. use-substitutes? device target
  302. image-size full-boot?
  303. (mappings '()))
  304. "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is
  305. the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
  306. is the size of the image to be built, for the 'vm-image' and 'disk-image'
  307. actions. FULL-BOOT? is used for the 'vm' action; it determines whether to
  308. boot directly to the kernel or to the bootloader.
  309. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
  310. building anything."
  311. (define println
  312. (cut format #t "~a~%" <>))
  313. (mlet* %store-monad
  314. ((sys (system-derivation-for-action os action
  315. #:image-size image-size
  316. #:full-boot? full-boot?
  317. #:mappings mappings))
  318. (grub (package->derivation grub))
  319. (grub.cfg (operating-system-grub.cfg os
  320. (if (eq? 'init action)
  321. '()
  322. (previous-grub-entries))))
  323. (drvs -> (if (and grub? (memq action '(init reconfigure)))
  324. (list sys grub grub.cfg)
  325. (list sys)))
  326. (% (if derivations-only?
  327. (return (for-each (compose println derivation-file-name)
  328. drvs))
  329. (maybe-build drvs #:dry-run? dry-run?
  330. #:use-substitutes? use-substitutes?))))
  331. (if (or dry-run? derivations-only?)
  332. (return #f)
  333. (begin
  334. (for-each (compose println derivation->output-path)
  335. drvs)
  336. ;; Make sure GRUB is accessible.
  337. (when grub?
  338. (let ((prefix (derivation->output-path grub)))
  339. (setenv "PATH"
  340. (string-append prefix "/bin:" prefix "/sbin:"
  341. (getenv "PATH")))))
  342. (case action
  343. ((reconfigure)
  344. (mbegin %store-monad
  345. (switch-to-system os)
  346. (mwhen grub?
  347. (install-grub* (derivation->output-path grub.cfg)
  348. device "/"))))
  349. ((init)
  350. (newline)
  351. (format #t (_ "initializing operating system under '~a'...~%")
  352. target)
  353. (install sys (canonicalize-path target)
  354. #:grub? grub?
  355. #:grub.cfg (derivation->output-path grub.cfg)
  356. #:device device))
  357. (else
  358. ;; All we had to do was to build SYS.
  359. (return (derivation->output-path sys))))))))
  360. (define (export-extension-graph os port)
  361. "Export the service extension graph of OS to PORT."
  362. (let* ((services (operating-system-services os))
  363. (boot (find (lambda (service)
  364. (eq? (service-kind service) boot-service-type))
  365. services)))
  366. (export-graph (list boot) (current-output-port)
  367. #:node-type (service-node-type services)
  368. #:reverse-edges? #t)))
  369. (define (export-dmd-graph os port)
  370. "Export the graph of dmd services of OS to PORT."
  371. (let* ((services (operating-system-services os))
  372. (pid1 (fold-services services
  373. #:target-type dmd-root-service-type))
  374. (dmds (service-parameters pid1)) ;the list of <dmd-service>
  375. (sinks (filter (lambda (service)
  376. (null? (dmd-service-requirement service)))
  377. dmds)))
  378. (export-graph sinks (current-output-port)
  379. #:node-type (dmd-service-node-type dmds)
  380. #:reverse-edges? #t)))
  381. ;;;
  382. ;;; Options.
  383. ;;;
  384. (define (show-help)
  385. (display (_ "Usage: guix system [OPTION] ACTION FILE
  386. Build the operating system declared in FILE according to ACTION.\n"))
  387. (newline)
  388. (display (_ "The valid values for ACTION are:\n"))
  389. (newline)
  390. (display (_ "\
  391. reconfigure switch to a new operating system configuration\n"))
  392. (display (_ "\
  393. build build the operating system without installing anything\n"))
  394. (display (_ "\
  395. vm build a virtual machine image that shares the host's store\n"))
  396. (display (_ "\
  397. vm-image build a freestanding virtual machine image\n"))
  398. (display (_ "\
  399. disk-image build a disk image, suitable for a USB stick\n"))
  400. (display (_ "\
  401. init initialize a root file system to run GNU\n"))
  402. (display (_ "\
  403. extension-graph emit the service extension graph in Dot format\n"))
  404. (display (_ "\
  405. dmd-graph emit the graph of dmd services in Dot format\n"))
  406. (show-build-options-help)
  407. (display (_ "
  408. -d, --derivation return the derivation of the given system"))
  409. (display (_ "
  410. --on-error=STRATEGY
  411. apply STRATEGY when an error occurs while reading FILE"))
  412. (display (_ "
  413. --image-size=SIZE for 'vm-image', produce an image of SIZE"))
  414. (display (_ "
  415. --no-grub for 'init', do not install GRUB"))
  416. (display (_ "
  417. --share=SPEC for 'vm', share host file system according to SPEC"))
  418. (display (_ "
  419. --expose=SPEC for 'vm', expose host file system according to SPEC"))
  420. (display (_ "
  421. --full-boot for 'vm', make a full boot sequence"))
  422. (newline)
  423. (display (_ "
  424. -h, --help display this help and exit"))
  425. (display (_ "
  426. -V, --version display version information and exit"))
  427. (newline)
  428. (show-bug-report-information))
  429. (define (specification->file-system-mapping spec writable?)
  430. "Read the SPEC and return the corresponding <file-system-mapping>."
  431. (let ((index (string-index spec #\=)))
  432. (if index
  433. (file-system-mapping
  434. (source (substring spec 0 index))
  435. (target (substring spec (+ 1 index)))
  436. (writable? writable?))
  437. (file-system-mapping
  438. (source spec)
  439. (target spec)
  440. (writable? writable?)))))
  441. (define %options
  442. ;; Specifications of the command-line options.
  443. (cons* (option '(#\h "help") #f #f
  444. (lambda args
  445. (show-help)
  446. (exit 0)))
  447. (option '(#\V "version") #f #f
  448. (lambda args
  449. (show-version-and-exit "guix system")))
  450. (option '(#\d "derivation") #f #f
  451. (lambda (opt name arg result)
  452. (alist-cons 'derivations-only? #t result)))
  453. (option '("on-error") #t #f
  454. (lambda (opt name arg result)
  455. (alist-cons 'on-error (string->symbol arg)
  456. result)))
  457. (option '("image-size") #t #f
  458. (lambda (opt name arg result)
  459. (alist-cons 'image-size (size->number arg)
  460. result)))
  461. (option '("no-grub") #f #f
  462. (lambda (opt name arg result)
  463. (alist-cons 'install-grub? #f result)))
  464. (option '("full-boot") #f #f
  465. (lambda (opt name arg result)
  466. (alist-cons 'full-boot? #t result)))
  467. (option '("share") #t #f
  468. (lambda (opt name arg result)
  469. (alist-cons 'file-system-mapping
  470. (specification->file-system-mapping arg #t)
  471. result)))
  472. (option '("expose") #t #f
  473. (lambda (opt name arg result)
  474. (alist-cons 'file-system-mapping
  475. (specification->file-system-mapping arg #f)
  476. result)))
  477. (option '(#\n "dry-run") #f #f
  478. (lambda (opt name arg result)
  479. (alist-cons 'dry-run? #t result)))
  480. (option '(#\s "system") #t #f
  481. (lambda (opt name arg result)
  482. (alist-cons 'system arg
  483. (alist-delete 'system result eq?))))
  484. %standard-build-options))
  485. (define %default-options
  486. ;; Alist of default option values.
  487. `((system . ,(%current-system))
  488. (substitutes? . #t)
  489. (build-hook? . #t)
  490. (max-silent-time . 3600)
  491. (verbosity . 0)
  492. (image-size . ,(* 900 (expt 2 20)))
  493. (install-grub? . #t)))
  494. ;;;
  495. ;;; Entry point.
  496. ;;;
  497. (define (guix-system . args)
  498. (define (parse-sub-command arg result)
  499. ;; Parse sub-command ARG and augment RESULT accordingly.
  500. (if (assoc-ref result 'action)
  501. (alist-cons 'argument arg result)
  502. (let ((action (string->symbol arg)))
  503. (case action
  504. ((build vm vm-image disk-image reconfigure init
  505. extension-graph dmd-graph)
  506. (alist-cons 'action action result))
  507. (else (leave (_ "~a: unknown action~%") action))))))
  508. (define (match-pair car)
  509. ;; Return a procedure that matches a pair with CAR.
  510. (match-lambda
  511. ((head . tail)
  512. (and (eq? car head) tail))
  513. (_ #f)))
  514. (define (option-arguments opts)
  515. ;; Extract the plain arguments from OPTS.
  516. (let* ((args (reverse (filter-map (match-pair 'argument) opts)))
  517. (count (length args))
  518. (action (assoc-ref opts 'action)))
  519. (define (fail)
  520. (leave (_ "wrong number of arguments for action '~a'~%")
  521. action))
  522. (unless action
  523. (format (current-error-port)
  524. (_ "guix system: missing command name~%"))
  525. (format (current-error-port)
  526. (_ "Try 'guix system --help' for more information.~%"))
  527. (exit 1))
  528. (case action
  529. ((build vm vm-image disk-image reconfigure)
  530. (unless (= count 1)
  531. (fail)))
  532. ((init)
  533. (unless (= count 2)
  534. (fail))))
  535. args))
  536. (with-error-handling
  537. (let* ((opts (parse-command-line args %options
  538. (list %default-options)
  539. #:argument-handler
  540. parse-sub-command))
  541. (args (option-arguments opts))
  542. (file (first args))
  543. (action (assoc-ref opts 'action))
  544. (system (assoc-ref opts 'system))
  545. (os (if file
  546. (load* file %user-module
  547. #:on-error (assoc-ref opts 'on-error))
  548. (leave (_ "no configuration file specified~%"))))
  549. (dry? (assoc-ref opts 'dry-run?))
  550. (grub? (assoc-ref opts 'install-grub?))
  551. (target (match args
  552. ((first second) second)
  553. (_ #f)))
  554. (device (and grub?
  555. (grub-configuration-device
  556. (operating-system-bootloader os))))
  557. (store (open-connection)))
  558. (set-build-options-from-command-line store opts)
  559. (run-with-store store
  560. (mbegin %store-monad
  561. (set-guile-for-build (default-guile))
  562. (case action
  563. ((extension-graph)
  564. (export-extension-graph os (current-output-port)))
  565. ((dmd-graph)
  566. (export-dmd-graph os (current-output-port)))
  567. (else
  568. (perform-action action os
  569. #:dry-run? dry?
  570. #:derivations-only? (assoc-ref opts
  571. 'derivations-only?)
  572. #:use-substitutes? (assoc-ref opts 'substitutes?)
  573. #:image-size (assoc-ref opts 'image-size)
  574. #:full-boot? (assoc-ref opts 'full-boot?)
  575. #:mappings (filter-map (match-lambda
  576. (('file-system-mapping . m)
  577. m)
  578. (_ #f))
  579. opts)
  580. #:grub? grub?
  581. #:target target #:device device))))
  582. #:system system))))
  583. ;;; system.scm ends here