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.
 
 
 
 
 
 

486 lines
17 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2014 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-26)
  37. #:use-module (srfi srfi-37)
  38. #:use-module (ice-9 match)
  39. #:export (guix-system
  40. read-operating-system))
  41. ;;;
  42. ;;; Operating system declaration.
  43. ;;;
  44. (define %user-module
  45. ;; Module in which the machine description file is loaded.
  46. (let ((module (make-fresh-user-module)))
  47. (for-each (lambda (iface)
  48. (module-use! module (resolve-interface iface)))
  49. '((gnu system)
  50. (gnu services)
  51. (gnu system shadow)))
  52. module))
  53. (define (read-operating-system file)
  54. "Read the operating-system declaration from FILE and return it."
  55. ;; TODO: Factorize.
  56. (catch #t
  57. (lambda ()
  58. ;; Avoid ABI incompatibility with the <operating-system> record.
  59. (set! %fresh-auto-compile #t)
  60. (save-module-excursion
  61. (lambda ()
  62. (set-current-module %user-module)
  63. (primitive-load file))))
  64. (lambda args
  65. (match args
  66. (('system-error . _)
  67. (let ((err (system-error-errno args)))
  68. (leave (_ "failed to open operating system file '~a': ~a~%")
  69. file (strerror err))))
  70. (('syntax-error proc message properties form . rest)
  71. (let ((loc (source-properties->location properties)))
  72. (leave (_ "~a: ~a~%")
  73. (location->string loc) message)))
  74. (_
  75. (leave (_ "failed to load operating system file '~a': ~s~%")
  76. file args))))))
  77. ;;;
  78. ;;; Installation.
  79. ;;;
  80. ;; TODO: Factorize.
  81. (define references*
  82. (store-lift references))
  83. (define topologically-sorted*
  84. (store-lift topologically-sorted))
  85. (define show-what-to-build*
  86. (store-lift show-what-to-build))
  87. (define* (copy-item item target
  88. #:key (log-port (current-error-port)))
  89. "Copy ITEM to the store under root directory TARGET and register it."
  90. (mlet* %store-monad ((refs (references* item)))
  91. (let ((dest (string-append target item))
  92. (state (string-append target "/var/guix")))
  93. (format log-port "copying '~a'...~%" item)
  94. (copy-recursively item dest
  95. #:log (%make-void-port "w"))
  96. ;; Register ITEM; as a side-effect, it resets timestamps, etc.
  97. ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
  98. ;; reproducing the user's current settings; see
  99. ;; <http://bugs.gnu.org/18049>.
  100. (unless (register-path item
  101. #:prefix target
  102. #:state-directory state
  103. #:references refs)
  104. (leave (_ "failed to register '~a' under '~a'~%")
  105. item target))
  106. (return #t))))
  107. (define* (copy-closure item target
  108. #:key (log-port (current-error-port)))
  109. "Copy ITEM and all its dependencies to the store under root directory
  110. TARGET, and register them."
  111. (mlet* %store-monad ((refs (references* item))
  112. (to-copy (topologically-sorted*
  113. (delete-duplicates (cons item refs)
  114. string=?))))
  115. (sequence %store-monad
  116. (map (cut copy-item <> target #:log-port log-port)
  117. to-copy))))
  118. (define* (install os-drv target
  119. #:key (log-port (current-output-port))
  120. grub? grub.cfg device)
  121. "Copy the output of OS-DRV and its dependencies to directory TARGET. TARGET
  122. must be an absolute directory name since that's what 'guix-register' expects.
  123. When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
  124. (define (maybe-copy to-copy)
  125. (with-monad %store-monad
  126. (if (string=? target "/")
  127. (begin
  128. (warning (_ "initializing the current root file system~%"))
  129. (return #t))
  130. (begin
  131. ;; Make sure the target store exists.
  132. (mkdir-p (string-append target (%store-prefix)))
  133. ;; Copy items to the new store.
  134. (copy-closure to-copy target #:log-port log-port)))))
  135. (mlet* %store-monad ((os-dir -> (derivation->output-path os-drv))
  136. (% (maybe-copy os-dir)))
  137. ;; Create a bunch of additional files.
  138. (format log-port "populating '~a'...~%" target)
  139. (populate-root-file-system os-dir target)
  140. (when grub?
  141. (unless (false-if-exception (install-grub grub.cfg device target))
  142. (leave (_ "failed to install GRUB on device '~a'~%") device)))
  143. (return #t)))
  144. ;;;
  145. ;;; Reconfiguration.
  146. ;;;
  147. (define %system-profile
  148. ;; The system profile.
  149. (string-append %state-directory "/profiles/system"))
  150. (define-syntax-rule (save-environment-excursion body ...)
  151. "Save the current environment variables, run BODY..., and restore them."
  152. (let ((env (environ)))
  153. (dynamic-wind
  154. (const #t)
  155. (lambda ()
  156. body ...)
  157. (lambda ()
  158. (environ env)))))
  159. (define* (switch-to-system os
  160. #:optional (profile %system-profile))
  161. "Make a new generation of PROFILE pointing to the directory of OS, switch to
  162. it atomically, and then run OS's activation script."
  163. (mlet* %store-monad ((drv (operating-system-derivation os))
  164. (script (operating-system-activation-script os)))
  165. (let* ((system (derivation->output-path drv))
  166. (number (+ 1 (generation-number profile)))
  167. (generation (generation-file-name profile number)))
  168. (symlink system generation)
  169. (switch-symlinks profile generation)
  170. (format #t (_ "activating system...~%"))
  171. ;; The activation script may change $PATH, among others, so protect
  172. ;; against that.
  173. (return (save-environment-excursion
  174. ;; Tell 'activate-current-system' what the new system is.
  175. (setenv "GUIX_NEW_SYSTEM" system)
  176. (primitive-load (derivation->output-path script))))
  177. ;; TODO: Run 'deco reload ...'.
  178. )))
  179. (define-syntax-rule (unless-file-not-found exp)
  180. (catch 'system-error
  181. (lambda ()
  182. exp)
  183. (lambda args
  184. (if (= ENOENT (system-error-errno args))
  185. #f
  186. (apply throw args)))))
  187. (define* (previous-grub-entries #:optional (profile %system-profile))
  188. "Return a list of 'menu-entry' for the generations of PROFILE."
  189. (define (system->grub-entry system)
  190. (unless-file-not-found
  191. (call-with-input-file (string-append system "/parameters")
  192. (lambda (port)
  193. (match (read port)
  194. (('boot-parameters ('version 0)
  195. ('label label) ('root-device root)
  196. ('kernel linux)
  197. _ ...)
  198. (menu-entry
  199. (label label)
  200. (linux linux)
  201. (linux-arguments
  202. (list (string-append "--root=" root)
  203. #~(string-append "--system=" #$system)
  204. #~(string-append "--load=" #$system "/boot")))
  205. (initrd #~(string-append #$system "/initrd"))))
  206. (_ ;unsupported format
  207. (warning (_ "unrecognized boot parameters for '~a'~%")
  208. system)
  209. #f))))))
  210. (let ((systems (map (cut generation-file-name profile <>)
  211. (generation-numbers profile))))
  212. (filter-map system->grub-entry systems)))
  213. ;;;
  214. ;;; Action.
  215. ;;;
  216. (define* (system-derivation-for-action os action
  217. #:key image-size)
  218. "Return as a monadic value the derivation for OS according to ACTION."
  219. (case action
  220. ((build init reconfigure)
  221. (operating-system-derivation os))
  222. ((vm-image)
  223. (system-qemu-image os #:disk-image-size image-size))
  224. ((vm)
  225. (system-qemu-image/shared-store-script os))
  226. ((disk-image)
  227. (system-disk-image os #:disk-image-size image-size))))
  228. (define (grub.cfg os)
  229. "Return the GRUB configuration file for OS."
  230. (operating-system-grub.cfg os (previous-grub-entries)))
  231. (define* (maybe-build drvs
  232. #:key dry-run? use-substitutes?)
  233. "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
  234. true."
  235. (with-monad %store-monad
  236. (>>= (show-what-to-build* drvs
  237. #:dry-run? dry-run?
  238. #:use-substitutes? use-substitutes?)
  239. (lambda (_)
  240. (if dry-run?
  241. (return #f)
  242. (built-derivations drvs))))))
  243. (define* (perform-action action os
  244. #:key grub? dry-run?
  245. use-substitutes? device target
  246. image-size)
  247. "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is
  248. the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
  249. is the size of the image to be built, for the 'vm-image' and 'disk-image'
  250. actions."
  251. (mlet* %store-monad
  252. ((sys (system-derivation-for-action os action
  253. #:image-size image-size))
  254. (grub (package->derivation grub))
  255. (grub.cfg (grub.cfg os))
  256. (drvs -> (if (and grub? (memq action '(init reconfigure)))
  257. (list sys grub grub.cfg)
  258. (list sys)))
  259. (% (maybe-build drvs #:dry-run? dry-run?
  260. #:use-substitutes? use-substitutes?)))
  261. (if dry-run?
  262. (return #f)
  263. (begin
  264. (for-each (cut format #t "~a~%" <>)
  265. (map derivation->output-path drvs))
  266. ;; Make sure GRUB is accessible.
  267. (when grub?
  268. (let ((prefix (derivation->output-path grub)))
  269. (setenv "PATH"
  270. (string-append prefix "/bin:" prefix "/sbin:"
  271. (getenv "PATH")))))
  272. (case action
  273. ((reconfigure)
  274. (mlet %store-monad ((% (switch-to-system os)))
  275. (when grub?
  276. (unless (false-if-exception
  277. (install-grub (derivation->output-path grub.cfg)
  278. device "/"))
  279. (leave (_ "failed to install GRUB on device '~a'~%")
  280. device)))
  281. (return #t)))
  282. ((init)
  283. (newline)
  284. (format #t (_ "initializing operating system under '~a'...~%")
  285. target)
  286. (install sys (canonicalize-path target)
  287. #:grub? grub?
  288. #:grub.cfg (derivation->output-path grub.cfg)
  289. #:device device))
  290. (else
  291. ;; All we had to do was to build SYS.
  292. (return (derivation->output-path sys))))))))
  293. ;;;
  294. ;;; Options.
  295. ;;;
  296. (define (show-help)
  297. (display (_ "Usage: guix system [OPTION] ACTION FILE
  298. Build the operating system declared in FILE according to ACTION.\n"))
  299. (newline)
  300. (display (_ "The valid values for ACTION are:\n"))
  301. (display (_ "\
  302. - 'reconfigure', switch to a new operating system configuration\n"))
  303. (display (_ "\
  304. - 'build', build the operating system without installing anything\n"))
  305. (display (_ "\
  306. - 'vm', build a virtual machine image that shares the host's store\n"))
  307. (display (_ "\
  308. - 'vm-image', build a freestanding virtual machine image\n"))
  309. (display (_ "\
  310. - 'disk-image', build a disk image, suitable for a USB stick\n"))
  311. (display (_ "\
  312. - 'init', initialize a root file system to run GNU.\n"))
  313. (show-build-options-help)
  314. (display (_ "
  315. --image-size=SIZE for 'vm-image', produce an image of SIZE"))
  316. (display (_ "
  317. --no-grub for 'init', do not install GRUB"))
  318. (newline)
  319. (display (_ "
  320. -h, --help display this help and exit"))
  321. (display (_ "
  322. -V, --version display version information and exit"))
  323. (newline)
  324. (show-bug-report-information))
  325. (define %options
  326. ;; Specifications of the command-line options.
  327. (cons* (option '(#\h "help") #f #f
  328. (lambda args
  329. (show-help)
  330. (exit 0)))
  331. (option '(#\V "version") #f #f
  332. (lambda args
  333. (show-version-and-exit "guix system")))
  334. (option '("image-size") #t #f
  335. (lambda (opt name arg result)
  336. (alist-cons 'image-size (size->number arg)
  337. result)))
  338. (option '("no-grub") #f #f
  339. (lambda (opt name arg result)
  340. (alist-delete 'install-grub? result)))
  341. (option '(#\n "dry-run") #f #f
  342. (lambda (opt name arg result)
  343. (alist-cons 'dry-run? #t result)))
  344. (option '(#\s "system") #t #f
  345. (lambda (opt name arg result)
  346. (alist-cons 'system arg
  347. (alist-delete 'system result eq?))))
  348. %standard-build-options))
  349. (define %default-options
  350. ;; Alist of default option values.
  351. `((system . ,(%current-system))
  352. (substitutes? . #t)
  353. (build-hook? . #t)
  354. (max-silent-time . 3600)
  355. (verbosity . 0)
  356. (image-size . ,(* 900 (expt 2 20)))
  357. (install-grub? . #t)))
  358. ;;;
  359. ;;; Entry point.
  360. ;;;
  361. (define (guix-system . args)
  362. (define (parse-options)
  363. ;; Return the alist of option values.
  364. (args-fold* args %options
  365. (lambda (opt name arg result)
  366. (leave (_ "~A: unrecognized option~%") name))
  367. (lambda (arg result)
  368. (if (assoc-ref result 'action)
  369. (alist-cons 'argument arg result)
  370. (let ((action (string->symbol arg)))
  371. (case action
  372. ((build vm vm-image disk-image reconfigure init)
  373. (alist-cons 'action action result))
  374. (else (leave (_ "~a: unknown action~%")
  375. action))))))
  376. %default-options))
  377. (define (match-pair car)
  378. ;; Return a procedure that matches a pair with CAR.
  379. (match-lambda
  380. ((head . tail)
  381. (and (eq? car head) tail))
  382. (_ #f)))
  383. (define (option-arguments opts)
  384. ;; Extract the plain arguments from OPTS.
  385. (let* ((args (reverse (filter-map (match-pair 'argument) opts)))
  386. (count (length args))
  387. (action (assoc-ref opts 'action)))
  388. (define (fail)
  389. (leave (_ "wrong number of arguments for action '~a'~%")
  390. action))
  391. (case action
  392. ((build vm vm-image disk-image reconfigure)
  393. (unless (= count 1)
  394. (fail)))
  395. ((init)
  396. (unless (= count 2)
  397. (fail))))
  398. args))
  399. (with-error-handling
  400. (let* ((opts (parse-options))
  401. (args (option-arguments opts))
  402. (file (first args))
  403. (action (assoc-ref opts 'action))
  404. (system (assoc-ref opts 'system))
  405. (os (if file
  406. (read-operating-system file)
  407. (leave (_ "no configuration file specified~%"))))
  408. (dry? (assoc-ref opts 'dry-run?))
  409. (grub? (assoc-ref opts 'install-grub?))
  410. (target (match args
  411. ((first second) second)
  412. (_ #f)))
  413. (device (and grub?
  414. (grub-configuration-device
  415. (operating-system-bootloader os))))
  416. (store (open-connection)))
  417. (set-build-options-from-command-line store opts)
  418. (run-with-store store
  419. (perform-action action os
  420. #:dry-run? dry?
  421. #:use-substitutes? (assoc-ref opts 'substitutes?)
  422. #:image-size (assoc-ref opts 'image-size)
  423. #:grub? grub?
  424. #:target target #:device device)
  425. #:system system))))
  426. ;;; system.scm ends here