install.scm 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 build syscalls)
  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. install-database-and-gc-roots
  29. populate-single-profile-directory
  30. mount-cow-store
  31. unmount-cow-store))
  32. ;;; Commentary:
  33. ;;;
  34. ;;; This module supports the installation of the GNU system on a hard disk.
  35. ;;; It is meant to be used both in a build environment (in derivations that
  36. ;;; build VM images), and on the bare metal (when really installing the
  37. ;;; system.)
  38. ;;;
  39. ;;; Code:
  40. (define (install-boot-config bootcfg bootcfg-location mount-point)
  41. "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT. Note
  42. that the caller must make sure that BOOTCFG is registered as a GC root so
  43. that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
  44. (let* ((target (string-append mount-point bootcfg-location))
  45. (pivot (string-append target ".new")))
  46. (mkdir-p (dirname target))
  47. ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
  48. ;; work when /boot is on a separate partition. Do that atomically.
  49. (copy-file bootcfg pivot)
  50. (rename-file pivot target)))
  51. (define* (evaluate-populate-directive directive target
  52. #:key
  53. (default-gid 0)
  54. (default-uid 0))
  55. "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
  56. directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
  57. the context of the caller. If the directive matches those defaults then,
  58. 'chown' won't be run."
  59. (let loop ((directive directive))
  60. (catch 'system-error
  61. (lambda ()
  62. (match directive
  63. (('directory name)
  64. (mkdir-p (string-append target name)))
  65. (('directory name uid gid)
  66. (let ((dir (string-append target name)))
  67. (mkdir-p dir)
  68. ;; If called from a context without "root" permissions, "chown"
  69. ;; to root will fail. In that case, do not try to run "chown"
  70. ;; and assume that the file will be chowned elsewhere (when
  71. ;; interned in the store for instance).
  72. (or (and (= uid default-uid) (= gid default-gid))
  73. (chown dir uid gid))))
  74. (('directory name uid gid mode)
  75. (loop `(directory ,name ,uid ,gid))
  76. (chmod (string-append target name) mode))
  77. (('file name)
  78. (call-with-output-file (string-append target name)
  79. (const #t)))
  80. (('file name (? string? content))
  81. (call-with-output-file (string-append target name)
  82. (lambda (port)
  83. (display content port))))
  84. ((new '-> old)
  85. (let try ()
  86. (catch 'system-error
  87. (lambda ()
  88. (symlink old (string-append target new)))
  89. (lambda args
  90. ;; When doing 'guix system init' on the current '/', some
  91. ;; symlinks may already exists. Override them.
  92. (if (= EEXIST (system-error-errno args))
  93. (begin
  94. (delete-file (string-append target new))
  95. (try))
  96. (apply throw args))))))))
  97. (lambda args
  98. ;; Usually we can only get here when installing to an existing root,
  99. ;; as with 'guix system init foo.scm /'.
  100. (format (current-error-port)
  101. "error: failed to evaluate directive: ~s~%"
  102. directive)
  103. (apply throw args)))))
  104. (define (directives store)
  105. "Return a list of directives to populate the root file system that will host
  106. STORE."
  107. `((directory ,store 0 0 #o1775)
  108. (directory "/etc")
  109. (directory "/var/log") ; for shepherd
  110. (directory "/var/guix/gcroots")
  111. (directory "/var/empty") ; for no-login accounts
  112. (directory "/var/db") ; for dhclient, etc.
  113. (directory "/var/run")
  114. (directory "/run")
  115. (directory "/mnt")
  116. (directory "/var/guix/profiles/per-user/root" 0 0)
  117. ;; Link to the initial system generation.
  118. ("/var/guix/profiles/system" -> "system-1-link")
  119. ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
  120. ("/var/guix/gcroots/current-system" -> "/run/current-system")
  121. ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
  122. (directory "/bin")
  123. (directory "/tmp" 0 0 #o1777) ; sticky bit
  124. (directory "/var/tmp" 0 0 #o1777)
  125. (directory "/var/lock" 0 0 #o1777)
  126. (directory "/home" 0 0)))
  127. (define* (populate-root-file-system system target
  128. #:key (extras '()))
  129. "Make the essential non-store files and directories on TARGET. This
  130. includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
  131. EXTRAS is a list of directives appended to the built-in directives to populate
  132. TARGET."
  133. (for-each (cut evaluate-populate-directive <> target)
  134. (append (directives (%store-directory)) extras))
  135. ;; Add system generation 1.
  136. (let ((generation-1 (string-append target
  137. "/var/guix/profiles/system-1-link")))
  138. (let try ()
  139. (catch 'system-error
  140. (lambda ()
  141. (symlink system generation-1))
  142. (lambda args
  143. ;; If GENERATION-1 already exists, overwrite it.
  144. (if (= EEXIST (system-error-errno args))
  145. (begin
  146. (delete-file generation-1)
  147. (try))
  148. (apply throw args)))))))
  149. (define %root-profile
  150. "/var/guix/profiles/per-user/root")
  151. (define* (install-database-and-gc-roots root database profile
  152. #:key (profile-name "guix-profile"))
  153. "Install DATABASE, the store database, under directory ROOT. Create
  154. PROFILE-NAME and have it link to PROFILE, a store item."
  155. (define (scope file)
  156. (string-append root "/" file))
  157. (define (mkdir-p* dir)
  158. (mkdir-p (scope dir)))
  159. (define (symlink* old new)
  160. (symlink old (scope new)))
  161. (install-file database (scope "/var/guix/db/"))
  162. (chmod (scope "/var/guix/db/db.sqlite") #o644)
  163. (mkdir-p* "/var/guix/profiles")
  164. (mkdir-p* "/var/guix/gcroots")
  165. (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")
  166. ;; Make root's profile, which makes it a GC root.
  167. (mkdir-p* %root-profile)
  168. (symlink* profile
  169. (string-append %root-profile "/" profile-name "-1-link"))
  170. (symlink* (string-append profile-name "-1-link")
  171. (string-append %root-profile "/" profile-name)))
  172. (define* (populate-single-profile-directory directory
  173. #:key profile closure
  174. (profile-name "guix-profile")
  175. database)
  176. "Populate DIRECTORY with a store containing PROFILE, whose closure is given
  177. in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
  178. is initialized to contain a single profile under /root pointing to PROFILE.
  179. When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
  180. DIRECTORY/var/guix/gcroots and friends.
  181. PROFILE-NAME is the name of the profile being created under
  182. /var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
  183. This is used to create the self-contained tarballs with 'guix pack'."
  184. (define (scope file)
  185. (string-append directory "/" file))
  186. (define (mkdir-p* dir)
  187. (mkdir-p (scope dir)))
  188. (define (symlink* old new)
  189. (symlink old (scope new)))
  190. ;; Populate the store.
  191. (populate-store (list closure) directory
  192. #:deduplicate? #f)
  193. (when database
  194. (install-database-and-gc-roots directory database profile
  195. #:profile-name profile-name))
  196. (match profile-name
  197. ("guix-profile"
  198. (mkdir-p* "/root")
  199. (symlink* (string-append %root-profile "/guix-profile")
  200. "/root/.guix-profile"))
  201. ("current-guix"
  202. (mkdir-p* "/root/.config/guix")
  203. (symlink* (string-append %root-profile "/current-guix")
  204. "/root/.config/guix/current"))
  205. (_
  206. #t)))
  207. (define (mount-cow-store target backing-directory)
  208. "Make the store copy-on-write, using TARGET as the backing store. This is
  209. useful when TARGET is on a hard disk, whereas the current store is on a RAM
  210. disk."
  211. (define (set-store-permissions directory)
  212. "Set the right perms on DIRECTORY to use it as the store."
  213. (chown directory 0 30000) ;use the fixed 'guixbuild' GID
  214. (chmod directory #o1775))
  215. (let ((tmpdir (string-append target "/tmp")))
  216. (mkdir-p tmpdir)
  217. (mount tmpdir "/tmp" "none" MS_BIND))
  218. (let* ((rw-dir (string-append target backing-directory))
  219. (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
  220. (mkdir-p rw-dir)
  221. (mkdir-p work-dir)
  222. (mkdir-p "/.rw-store")
  223. (set-store-permissions rw-dir)
  224. (set-store-permissions "/.rw-store")
  225. ;; Mount the overlay, then atomically make it the store.
  226. (mount "none" "/.rw-store" "overlay" 0
  227. (string-append "lowerdir=" (%store-directory) ","
  228. "upperdir=" rw-dir ","
  229. "workdir=" work-dir))
  230. (mount "/.rw-store" (%store-directory) "" MS_MOVE)
  231. (rmdir "/.rw-store")))
  232. (define (unmount-cow-store target backing-directory)
  233. "Unmount copy-on-write store."
  234. (let ((tmp-dir "/remove"))
  235. (mkdir-p tmp-dir)
  236. (mount (%store-directory) tmp-dir "" MS_MOVE)
  237. (umount tmp-dir)
  238. (rmdir tmp-dir)
  239. (delete-file-recursively
  240. (string-append target backing-directory))))
  241. ;;; install.scm ends here