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.
 
 
 
 
 
 

210 lines
8.2 KiB

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