Mirror of GNU Guix
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.

546 lines
20 KiB

monads: Move '%store-monad' and related procedures where they belong. This turns (guix monads) into a generic module for monads, and moves the store monad and related monadic procedures in their corresponding module. * guix/monads.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file, package-file, package->derivation, package->cross-derivation, origin->derivation, imported-modules, compiled, modules, built-derivations, run-with-store): Move to... * guix/store.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file): ... here. (%guile-for-build): New variable. (run-with-store): Moved from monads.scm. Remove default value for #:guile-for-build. * guix/packages.scm (default-guile): Export. (set-guile-for-build): New procedure. (package-file, package->derivation, package->cross-derivation, origin->derivation): Moved from monads.scm. * guix/derivations.scm (%guile-for-build): Remove. (imported-modules): Rename to... (%imported-modules): ... this. (compiled-modules): Rename to... (%compiled-modules): ... this. (built-derivations, imported-modules, compiled-modules): New procedures. * gnu/services/avahi.scm, gnu/services/base.scm, gnu/services/dbus.scm, gnu/services/dmd.scm, gnu/services/networking.scm, gnu/services/ssh.scm, gnu/services/xorg.scm, gnu/system/install.scm, gnu/system/linux-initrd.scm, gnu/system/shadow.scm, guix/download.scm, guix/gexp.scm, guix/git-download.scm, guix/profiles.scm, guix/svn-download.scm, tests/monads.scm: Adjust imports accordingly. * guix/monad-repl.scm (default-guile-derivation): New procedure. (store-monad-language, run-in-store): Use it. * build-aux/hydra/gnu-system.scm (qemu-jobs): Add explicit 'set-guile-for-build' call. * guix/scripts/archive.scm (derivation-from-expression): Likewise. * guix/scripts/build.scm (options/resolve-packages): Likewise. * guix/scripts/environment.scm (guix-environment): Likewise. * guix/scripts/system.scm (guix-system): Likewise. * doc/guix.texi (The Store Monad): Adjust module names accordingly.
7 years ago
monads: Move '%store-monad' and related procedures where they belong. This turns (guix monads) into a generic module for monads, and moves the store monad and related monadic procedures in their corresponding module. * guix/monads.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file, package-file, package->derivation, package->cross-derivation, origin->derivation, imported-modules, compiled, modules, built-derivations, run-with-store): Move to... * guix/store.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file): ... here. (%guile-for-build): New variable. (run-with-store): Moved from monads.scm. Remove default value for #:guile-for-build. * guix/packages.scm (default-guile): Export. (set-guile-for-build): New procedure. (package-file, package->derivation, package->cross-derivation, origin->derivation): Moved from monads.scm. * guix/derivations.scm (%guile-for-build): Remove. (imported-modules): Rename to... (%imported-modules): ... this. (compiled-modules): Rename to... (%compiled-modules): ... this. (built-derivations, imported-modules, compiled-modules): New procedures. * gnu/services/avahi.scm, gnu/services/base.scm, gnu/services/dbus.scm, gnu/services/dmd.scm, gnu/services/networking.scm, gnu/services/ssh.scm, gnu/services/xorg.scm, gnu/system/install.scm, gnu/system/linux-initrd.scm, gnu/system/shadow.scm, guix/download.scm, guix/gexp.scm, guix/git-download.scm, guix/profiles.scm, guix/svn-download.scm, tests/monads.scm: Adjust imports accordingly. * guix/monad-repl.scm (default-guile-derivation): New procedure. (store-monad-language, run-in-store): Use it. * build-aux/hydra/gnu-system.scm (qemu-jobs): Add explicit 'set-guile-for-build' call. * guix/scripts/archive.scm (derivation-from-expression): Likewise. * guix/scripts/build.scm (options/resolve-packages): Likewise. * guix/scripts/environment.scm (guix-environment): Likewise. * guix/scripts/system.scm (guix-system): Likewise. * doc/guix.texi (The Store Monad): Adjust module names accordingly.
7 years ago
  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 build)
  29. #:use-module (guix build utils)
  30. #:use-module (gnu build install)
  31. #:use-module (gnu system)
  32. #:use-module (gnu system vm)
  33. #:use-module (gnu system grub)
  34. #:use-module (gnu packages grub)
  35. #:use-module (srfi srfi-1)
  36. #:use-module (srfi srfi-19)
  37. #:use-module (srfi srfi-26)
  38. #:use-module (srfi srfi-37)
  39. #:use-module (ice-9 match)
  40. #:export (guix-system
  41. read-operating-system))
  42. ;;;
  43. ;;; Operating system declaration.
  44. ;;;
  45. (define %user-module
  46. ;; Module in which the machine description file is loaded.
  47. (make-user-module '((gnu system)
  48. (gnu services)
  49. (gnu system shadow))))
  50. (define (read-operating-system file)
  51. "Read the operating-system declaration from FILE and return it."
  52. (load* file %user-module))
  53. ;;;
  54. ;;; Installation.
  55. ;;;
  56. ;; TODO: Factorize.
  57. (define references*
  58. (store-lift references))
  59. (define topologically-sorted*
  60. (store-lift topologically-sorted))
  61. (define* (copy-item item target
  62. #:key (log-port (current-error-port)))
  63. "Copy ITEM to the store under root directory TARGET and register it."
  64. (mlet* %store-monad ((refs (references* item)))
  65. (let ((dest (string-append target item))
  66. (state (string-append target "/var/guix")))
  67. (format log-port "copying '~a'...~%" item)
  68. (copy-recursively item dest
  69. #:log (%make-void-port "w"))
  70. ;; Register ITEM; as a side-effect, it resets timestamps, etc.
  71. ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
  72. ;; reproducing the user's current settings; see
  73. ;; <http://bugs.gnu.org/18049>.
  74. (unless (register-path item
  75. #:prefix target
  76. #:state-directory state
  77. #:references refs)
  78. (leave (_ "failed to register '~a' under '~a'~%")
  79. item target))
  80. (return #t))))
  81. (define* (copy-closure item target
  82. #:key (log-port (current-error-port)))
  83. "Copy ITEM and all its dependencies to the store under root directory
  84. TARGET, and register them."
  85. (mlet* %store-monad ((refs (references* item))
  86. (to-copy (topologically-sorted*
  87. (delete-duplicates (cons item refs)
  88. string=?))))
  89. (sequence %store-monad
  90. (map (cut copy-item <> target #:log-port log-port)
  91. to-copy))))
  92. (define (install-grub* grub.cfg device target)
  93. "This is a variant of 'install-grub' with error handling, lifted in
  94. %STORE-MONAD"
  95. (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg"))
  96. (temp-gc-root (string-append gc-root ".new"))
  97. (delete-file (lift1 delete-file %store-monad))
  98. (make-symlink (lift2 switch-symlinks %store-monad))
  99. (rename (lift2 rename-file %store-monad)))
  100. (mbegin %store-monad
  101. ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when
  102. ;; 'install-grub' completes (being a bit paranoid.)
  103. (make-symlink temp-gc-root grub.cfg)
  104. (munless (false-if-exception (install-grub grub.cfg device target))
  105. (delete-file temp-gc-root)
  106. (leave (_ "failed to install GRUB on device '~a'~%") device))
  107. ;; Register GRUB.CFG as a GC root so that its dependencies (background
  108. ;; image, font, etc.) are not reclaimed.
  109. (rename temp-gc-root gc-root))))
  110. (define* (install os-drv target
  111. #:key (log-port (current-output-port))
  112. grub? grub.cfg device)
  113. "Copy the output of OS-DRV and its dependencies to directory TARGET. TARGET
  114. must be an absolute directory name since that's what 'guix-register' expects.
  115. When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
  116. (define (maybe-copy to-copy)
  117. (with-monad %store-monad
  118. (if (string=? target "/")
  119. (begin
  120. (warning (_ "initializing the current root file system~%"))
  121. (return #t))
  122. (begin
  123. ;; Make sure the target store exists.
  124. (mkdir-p (string-append target (%store-prefix)))
  125. ;; Copy items to the new store.
  126. (copy-closure to-copy target #:log-port log-port)))))
  127. ;; Make sure TARGET is root-owned when running as root, but still allow
  128. ;; non-root uses (useful for testing.) See
  129. ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>.
  130. (if (zero? (geteuid))
  131. (chown target 0 0)
  132. (warning (_ "not running as 'root', so \
  133. the ownership of '~a' may be incorrect!~%")
  134. target))
  135. (chmod target #o755)
  136. (let ((os-dir (derivation->output-path os-drv))
  137. (format (lift format %store-monad))
  138. (populate (lift2 populate-root-file-system %store-monad)))
  139. (mbegin %store-monad
  140. (maybe-copy os-dir)
  141. ;; Create a bunch of additional files.
  142. (format log-port "populating '~a'...~%" target)
  143. (populate os-dir target)
  144. (mwhen grub?
  145. (install-grub* grub.cfg device target)))))
  146. ;;;
  147. ;;; Reconfiguration.
  148. ;;;
  149. (define %system-profile
  150. ;; The system profile.
  151. (string-append %state-directory "/profiles/system"))
  152. (define-syntax-rule (save-environment-excursion body ...)
  153. "Save the current environment variables, run BODY..., and restore them."
  154. (let ((env (environ)))
  155. (dynamic-wind
  156. (const #t)
  157. (lambda ()
  158. body ...)
  159. (lambda ()
  160. (environ env)))))
  161. (define* (switch-to-system os
  162. #:optional (profile %system-profile))
  163. "Make a new generation of PROFILE pointing to the directory of OS, switch to
  164. it atomically, and then run OS's activation script."
  165. (mlet* %store-monad ((drv (operating-system-derivation os))
  166. (script (operating-system-activation-script os)))
  167. (let* ((system (derivation->output-path drv))
  168. (number (+ 1 (generation-number profile)))
  169. (generation (generation-file-name profile number)))
  170. (symlink system generation)
  171. (switch-symlinks profile generation)
  172. (format #t (_ "activating system...~%"))
  173. ;; The activation script may change $PATH, among others, so protect
  174. ;; against that.
  175. (return (save-environment-excursion
  176. ;; Tell 'activate-current-system' what the new system is.
  177. (setenv "GUIX_NEW_SYSTEM" system)
  178. (primitive-load (derivation->output-path script))))
  179. ;; TODO: Run 'deco reload ...'.
  180. )))
  181. (define-syntax-rule (unless-file-not-found exp)
  182. (catch 'system-error
  183. (lambda ()
  184. exp)
  185. (lambda args
  186. (if (= ENOENT (system-error-errno args))
  187. #f
  188. (apply throw args)))))
  189. (define (seconds->string seconds)
  190. "Return a string representing the date for SECONDS."
  191. (let ((time (make-time time-utc 0 seconds)))
  192. (date->string (time-utc->date time)
  193. "~Y-~m-~d ~H:~M")))
  194. (define* (previous-grub-entries #:optional (profile %system-profile))
  195. "Return a list of 'menu-entry' for the generations of PROFILE."
  196. (define (system->grub-entry system number time)
  197. (unless-file-not-found
  198. (call-with-input-file (string-append system "/parameters")
  199. (lambda (port)
  200. (match (read port)
  201. (('boot-parameters ('version 0)
  202. ('label label) ('root-device root)
  203. ('kernel linux)
  204. _ ...)
  205. (menu-entry
  206. (label (string-append label " (#"
  207. (number->string number) ", "
  208. (seconds->string time) ")"))
  209. (linux linux)
  210. (linux-arguments
  211. (list (string-append "--root=" root)
  212. #~(string-append "--system=" #$system)
  213. #~(string-append "--load=" #$system "/boot")))
  214. (initrd #~(string-append #$system "/initrd"))))
  215. (_ ;unsupported format
  216. (warning (_ "unrecognized boot parameters for '~a'~%")
  217. system)
  218. #f))))))
  219. (let* ((numbers (generation-numbers profile))
  220. (systems (map (cut generation-file-name profile <>)
  221. numbers))
  222. (times (map (lambda (system)
  223. (unless-file-not-found
  224. (stat:mtime (lstat system))))
  225. systems)))
  226. (filter-map system->grub-entry systems numbers times)))
  227. ;;;
  228. ;;; Action.
  229. ;;;
  230. (define* (system-derivation-for-action os action
  231. #:key image-size full-boot? mappings)
  232. "Return as a monadic value the derivation for OS according to ACTION."
  233. (case action
  234. ((build init reconfigure)
  235. (operating-system-derivation os))
  236. ((vm-image)
  237. (system-qemu-image os #:disk-image-size image-size))
  238. ((vm)
  239. (system-qemu-image/shared-store-script os
  240. #:full-boot? full-boot?
  241. #:disk-image-size image-size
  242. #:mappings mappings))
  243. ((disk-image)
  244. (system-disk-image os #:disk-image-size image-size))))
  245. (define* (maybe-build drvs
  246. #:key dry-run? use-substitutes?)
  247. "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
  248. true."
  249. (with-monad %store-monad
  250. (>>= (show-what-to-build* drvs
  251. #:dry-run? dry-run?
  252. #:use-substitutes? use-substitutes?)
  253. (lambda (_)
  254. (if dry-run?
  255. (return #f)
  256. (built-derivations drvs))))))
  257. (define* (perform-action action os
  258. #:key grub? dry-run?
  259. use-substitutes? device target
  260. image-size full-boot?
  261. (mappings '()))
  262. "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is
  263. the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
  264. is the size of the image to be built, for the 'vm-image' and 'disk-image'
  265. actions. FULL-BOOT? is used for the 'vm' action; it determines whether to
  266. boot directly to the kernel or to the bootloader."
  267. (mlet* %store-monad
  268. ((sys (system-derivation-for-action os action
  269. #:image-size image-size
  270. #:full-boot? full-boot?
  271. #:mappings mappings))
  272. (grub (package->derivation grub))
  273. (grub.cfg (operating-system-grub.cfg os
  274. (if (eq? 'init action)
  275. '()
  276. (previous-grub-entries))))
  277. (drvs -> (if (and grub? (memq action '(init reconfigure)))
  278. (list sys grub grub.cfg)
  279. (list sys)))
  280. (% (maybe-build drvs #:dry-run? dry-run?
  281. #:use-substitutes? use-substitutes?)))
  282. (if dry-run?
  283. (return #f)
  284. (begin
  285. (for-each (cut format #t "~a~%" <>)
  286. (map derivation->output-path drvs))
  287. ;; Make sure GRUB is accessible.
  288. (when grub?
  289. (let ((prefix (derivation->output-path grub)))
  290. (setenv "PATH"
  291. (string-append prefix "/bin:" prefix "/sbin:"
  292. (getenv "PATH")))))
  293. (case action
  294. ((reconfigure)
  295. (mbegin %store-monad
  296. (switch-to-system os)
  297. (mwhen grub?
  298. (install-grub* (derivation->output-path grub.cfg)
  299. device "/"))))
  300. ((init)
  301. (newline)
  302. (format #t (_ "initializing operating system under '~a'...~%")
  303. target)
  304. (install sys (canonicalize-path target)
  305. #:grub? grub?
  306. #:grub.cfg (derivation->output-path grub.cfg)
  307. #:device device))
  308. (else
  309. ;; All we had to do was to build SYS.
  310. (return (derivation->output-path sys))))))))
  311. ;;;
  312. ;;; Options.
  313. ;;;
  314. (define (show-help)
  315. (display (_ "Usage: guix system [OPTION] ACTION FILE
  316. Build the operating system declared in FILE according to ACTION.\n"))
  317. (newline)
  318. (display (_ "The valid values for ACTION are:\n"))
  319. (display (_ "\
  320. - 'reconfigure', switch to a new operating system configuration\n"))
  321. (display (_ "\
  322. - 'build', build the operating system without installing anything\n"))
  323. (display (_ "\
  324. - 'vm', build a virtual machine image that shares the host's store\n"))
  325. (display (_ "\
  326. - 'vm-image', build a freestanding virtual machine image\n"))
  327. (display (_ "\
  328. - 'disk-image', build a disk image, suitable for a USB stick\n"))
  329. (display (_ "\
  330. - 'init', initialize a root file system to run GNU.\n"))
  331. (show-build-options-help)
  332. (display (_ "
  333. --image-size=SIZE for 'vm-image', produce an image of SIZE"))
  334. (display (_ "
  335. --no-grub for 'init', do not install GRUB"))
  336. (display (_ "
  337. --share=SPEC for 'vm', share host file system according to SPEC"))
  338. (display (_ "
  339. --expose=SPEC for 'vm', expose host file system according to SPEC"))
  340. (display (_ "
  341. --full-boot for 'vm', make a full boot sequence"))
  342. (newline)
  343. (display (_ "
  344. -h, --help display this help and exit"))
  345. (display (_ "
  346. -V, --version display version information and exit"))
  347. (newline)
  348. (show-bug-report-information))
  349. (define (specification->file-system-mapping spec writable?)
  350. "Read the SPEC and return the corresponding <file-system-mapping>."
  351. (let ((index (string-index spec #\=)))
  352. (if index
  353. (file-system-mapping
  354. (source (substring spec 0 index))
  355. (target (substring spec (+ 1 index)))
  356. (writable? writable?))
  357. (file-system-mapping
  358. (source spec)
  359. (target spec)
  360. (writable? writable?)))))
  361. (define %options
  362. ;; Specifications of the command-line options.
  363. (cons* (option '(#\h "help") #f #f
  364. (lambda args
  365. (show-help)
  366. (exit 0)))
  367. (option '(#\V "version") #f #f
  368. (lambda args
  369. (show-version-and-exit "guix system")))
  370. (option '("image-size") #t #f
  371. (lambda (opt name arg result)
  372. (alist-cons 'image-size (size->number arg)
  373. result)))
  374. (option '("no-grub") #f #f
  375. (lambda (opt name arg result)
  376. (alist-cons 'install-grub? #f result)))
  377. (option '("full-boot") #f #f
  378. (lambda (opt name arg result)
  379. (alist-cons 'full-boot? #t result)))
  380. (option '("share") #t #f
  381. (lambda (opt name arg result)
  382. (alist-cons 'file-system-mapping
  383. (specification->file-system-mapping arg #t)
  384. result)))
  385. (option '("expose") #t #f
  386. (lambda (opt name arg result)
  387. (alist-cons 'file-system-mapping
  388. (specification->file-system-mapping arg #f)
  389. result)))
  390. (option '(#\n "dry-run") #f #f
  391. (lambda (opt name arg result)
  392. (alist-cons 'dry-run? #t result)))
  393. (option '(#\s "system") #t #f
  394. (lambda (opt name arg result)
  395. (alist-cons 'system arg
  396. (alist-delete 'system result eq?))))
  397. %standard-build-options))
  398. (define %default-options
  399. ;; Alist of default option values.
  400. `((system . ,(%current-system))
  401. (substitutes? . #t)
  402. (build-hook? . #t)
  403. (max-silent-time . 3600)
  404. (verbosity . 0)
  405. (image-size . ,(* 900 (expt 2 20)))
  406. (install-grub? . #t)))
  407. ;;;
  408. ;;; Entry point.
  409. ;;;
  410. (define (guix-system . args)
  411. (define (parse-sub-command arg result)
  412. ;; Parse sub-command ARG and augment RESULT accordingly.
  413. (if (assoc-ref result 'action)
  414. (alist-cons 'argument arg result)
  415. (let ((action (string->symbol arg)))
  416. (case action
  417. ((build vm vm-image disk-image reconfigure init)
  418. (alist-cons 'action action result))
  419. (else (leave (_ "~a: unknown action~%") action))))))
  420. (define (match-pair car)
  421. ;; Return a procedure that matches a pair with CAR.
  422. (match-lambda
  423. ((head . tail)
  424. (and (eq? car head) tail))
  425. (_ #f)))
  426. (define (option-arguments opts)
  427. ;; Extract the plain arguments from OPTS.
  428. (let* ((args (reverse (filter-map (match-pair 'argument) opts)))
  429. (count (length args))
  430. (action (assoc-ref opts 'action)))
  431. (define (fail)
  432. (leave (_ "wrong number of arguments for action '~a'~%")
  433. action))
  434. (case action
  435. ((build vm vm-image disk-image reconfigure)
  436. (unless (= count 1)
  437. (fail)))
  438. ((init)
  439. (unless (= count 2)
  440. (fail))))
  441. args))
  442. (with-error-handling
  443. (let* ((opts (parse-command-line args %options
  444. (list %default-options)
  445. #:argument-handler
  446. parse-sub-command))
  447. (args (option-arguments opts))
  448. (file (first args))
  449. (action (assoc-ref opts 'action))
  450. (system (assoc-ref opts 'system))
  451. (os (if file
  452. (read-operating-system file)
  453. (leave (_ "no configuration file specified~%"))))
  454. (dry? (assoc-ref opts 'dry-run?))
  455. (grub? (assoc-ref opts 'install-grub?))
  456. (target (match args
  457. ((first second) second)
  458. (_ #f)))
  459. (device (and grub?
  460. (grub-configuration-device
  461. (operating-system-bootloader os))))
  462. (store (open-connection)))
  463. (set-build-options-from-command-line store opts)
  464. (run-with-store store
  465. (mbegin %store-monad
  466. (set-guile-for-build (default-guile))
  467. (perform-action action os
  468. #:dry-run? dry?
  469. #:use-substitutes? (assoc-ref opts 'substitutes?)
  470. #:image-size (assoc-ref opts 'image-size)
  471. #:full-boot? (assoc-ref opts 'full-boot?)
  472. #:mappings (filter-map (match-lambda
  473. (('file-system-mapping . m)
  474. m)
  475. (_ #f))
  476. opts)
  477. #:grub? grub?
  478. #:target target #:device device))
  479. #:system system))))
  480. ;;; system.scm ends here