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.
 
 
 
 
 
 

221 lines
8.6 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 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 (gnu build install)
  19. #:use-module (guix build utils)
  20. #:use-module (guix build store-copy)
  21. #:use-module (srfi srfi-26)
  22. #:use-module (ice-9 match)
  23. #:export (install-grub
  24. populate-root-file-system
  25. reset-timestamps
  26. register-closure
  27. populate-single-profile-directory))
  28. ;;; Commentary:
  29. ;;;
  30. ;;; This module supports the installation of the GNU system on a hard disk.
  31. ;;; It is meant to be used both in a build environment (in derivations that
  32. ;;; build VM images), and on the bare metal (when really installing the
  33. ;;; system.)
  34. ;;;
  35. ;;; Code:
  36. (define* (install-grub grub.cfg device mount-point)
  37. "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
  38. MOUNT-POINT.
  39. Note that the caller must make sure that GRUB.CFG is registered as a GC root
  40. so that the fonts, background images, etc. referred to by GRUB.CFG are not
  41. GC'd."
  42. (let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
  43. (pivot (string-append target ".new")))
  44. (mkdir-p (dirname target))
  45. ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
  46. ;; work when /boot is on a separate partition. Do that atomically.
  47. (copy-file grub.cfg pivot)
  48. (rename-file pivot target)
  49. (unless (zero? (system* "grub-install" "--no-floppy"
  50. "--boot-directory"
  51. (string-append mount-point "/boot")
  52. device))
  53. (error "failed to install GRUB"))))
  54. (define (evaluate-populate-directive directive target)
  55. "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
  56. directory TARGET."
  57. (let loop ((directive directive))
  58. (catch 'system-error
  59. (lambda ()
  60. (match directive
  61. (('directory name)
  62. (mkdir-p (string-append target name)))
  63. (('directory name uid gid)
  64. (let ((dir (string-append target name)))
  65. (mkdir-p dir)
  66. (chown dir uid gid)))
  67. (('directory name uid gid mode)
  68. (loop `(directory ,name ,uid ,gid))
  69. (chmod (string-append target name) mode))
  70. ((new '-> old)
  71. (let try ()
  72. (catch 'system-error
  73. (lambda ()
  74. (symlink old (string-append target new)))
  75. (lambda args
  76. ;; When doing 'guix system init' on the current '/', some
  77. ;; symlinks may already exists. Override them.
  78. (if (= EEXIST (system-error-errno args))
  79. (begin
  80. (delete-file (string-append target new))
  81. (try))
  82. (apply throw args))))))))
  83. (lambda args
  84. ;; Usually we can only get here when installing to an existing root,
  85. ;; as with 'guix system init foo.scm /'.
  86. (format (current-error-port)
  87. "error: failed to evaluate directive: ~s~%"
  88. directive)
  89. (apply throw args)))))
  90. (define (directives store)
  91. "Return a list of directives to populate the root file system that will host
  92. STORE."
  93. `(;; Note: the store's GID is fixed precisely so we can set it here rather
  94. ;; than at activation time.
  95. (directory ,store 0 30000 #o1775)
  96. (directory "/etc")
  97. (directory "/var/log") ; for shepherd
  98. (directory "/var/guix/gcroots")
  99. (directory "/var/empty") ; for no-login accounts
  100. (directory "/var/db") ; for dhclient, etc.
  101. (directory "/var/run")
  102. (directory "/run")
  103. (directory "/mnt")
  104. (directory "/var/guix/profiles/per-user/root" 0 0)
  105. ;; Link to the initial system generation.
  106. ("/var/guix/profiles/system" -> "system-1-link")
  107. ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
  108. ("/var/guix/gcroots/current-system" -> "/run/current-system")
  109. (directory "/bin")
  110. (directory "/tmp" 0 0 #o1777) ; sticky bit
  111. (directory "/var/tmp" 0 0 #o1777)
  112. (directory "/var/lock" 0 0 #o1777)
  113. (directory "/root" 0 0) ; an exception
  114. (directory "/home" 0 0)))
  115. (define (populate-root-file-system system target)
  116. "Make the essential non-store files and directories on TARGET. This
  117. includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
  118. (for-each (cut evaluate-populate-directive <> target)
  119. (directives (%store-directory)))
  120. ;; Add system generation 1.
  121. (let ((generation-1 (string-append target
  122. "/var/guix/profiles/system-1-link")))
  123. (let try ()
  124. (catch 'system-error
  125. (lambda ()
  126. (symlink system generation-1))
  127. (lambda args
  128. ;; If GENERATION-1 already exists, overwrite it.
  129. (if (= EEXIST (system-error-errno args))
  130. (begin
  131. (delete-file generation-1)
  132. (try))
  133. (apply throw args)))))))
  134. (define (reset-timestamps directory)
  135. "Reset the timestamps of all the files under DIRECTORY, so that they appear
  136. as created and modified at the Epoch."
  137. (display "clearing file timestamps...\n")
  138. (for-each (lambda (file)
  139. (let ((s (lstat file)))
  140. ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
  141. ;; the timestamp of symlinks cannot be changed, and there are
  142. ;; symlinks here pointing to /gnu/store, which is the host,
  143. ;; read-only store.
  144. (unless (eq? (stat:type s) 'symlink)
  145. (utime file 0 0 0 0))))
  146. (find-files directory "")))
  147. (define* (register-closure store closure
  148. #:key (deduplicate? #t))
  149. "Register CLOSURE in STORE, where STORE is the directory name of the target
  150. store and CLOSURE is the name of a file containing a reference graph as used
  151. by 'guix-register'. As a side effect, this resets timestamps on store files
  152. and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the
  153. rest of STORE."
  154. (let ((status (apply system* "guix-register" "--prefix" store
  155. (append (if deduplicate? '() '("--no-deduplication"))
  156. (list closure)))))
  157. (unless (zero? status)
  158. (error "failed to register store items" closure))))
  159. (define* (populate-single-profile-directory directory
  160. #:key profile closure
  161. deduplicate?)
  162. "Populate DIRECTORY with a store containing PROFILE, whose closure is given
  163. in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
  164. is initialized to contain a single profile under /root pointing to PROFILE.
  165. DEDUPLICATE? determines whether to deduplicate files in the store.
  166. This is used to create the self-contained Guix tarball."
  167. (define (scope file)
  168. (string-append directory "/" file))
  169. (define %root-profile
  170. "/var/guix/profiles/per-user/root")
  171. (define (mkdir-p* dir)
  172. (mkdir-p (scope dir)))
  173. (define (symlink* old new)
  174. (symlink old (scope new)))
  175. ;; Populate the store.
  176. (populate-store (list closure) directory)
  177. (register-closure (canonicalize-path directory) closure
  178. #:deduplicate? deduplicate?)
  179. ;; XXX: 'guix-register' registers profiles as GC roots but the symlink
  180. ;; target uses $TMPDIR. Fix that.
  181. (delete-file (scope "/var/guix/gcroots/profiles"))
  182. (symlink* "/var/guix/profiles"
  183. "/var/guix/gcroots/profiles")
  184. ;; Make root's profile, which makes it a GC root.
  185. (mkdir-p* %root-profile)
  186. (symlink* profile
  187. (string-append %root-profile "/guix-profile-1-link"))
  188. (symlink* (string-append %root-profile "/guix-profile-1-link")
  189. (string-append %root-profile "/guix-profile"))
  190. (mkdir-p* "/root")
  191. (symlink* (string-append %root-profile "/guix-profile")
  192. "/root/.guix-profile"))
  193. ;;; install.scm ends here