;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build install)
+ #:use-module (guix build syscalls)
#:use-module (guix build utils)
+ #:use-module (guix build store-copy)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
- #:export (install-grub
+ #:export (install-boot-config
+ evaluate-populate-directive
populate-root-file-system
- reset-timestamps
- register-closure))
+ install-database-and-gc-roots
+ populate-single-profile-directory
+ mount-cow-store
+ unmount-cow-store))
;;; Commentary:
;;;
;;;
;;; Code:
-(define* (install-grub grub.cfg device mount-point)
- "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
-MOUNT-POINT."
- (let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
+(define (install-boot-config bootcfg bootcfg-location mount-point)
+ "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT. Note
+that the caller must make sure that BOOTCFG is registered as a GC root so
+that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
+ (let* ((target (string-append mount-point bootcfg-location))
(pivot (string-append target ".new")))
(mkdir-p (dirname target))
- ;; Copy GRUB.CFG instead of just symlinking it since it's not a GC root.
- ;; Do that atomically.
- (copy-file grub.cfg pivot)
- (rename-file pivot target)
+ ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
+ ;; work when /boot is on a separate partition. Do that atomically.
+ (copy-file bootcfg pivot)
+ (rename-file pivot target)))
- (unless (zero? (system* "grub-install" "--no-floppy"
- "--boot-directory"
- (string-append mount-point "/boot")
- device))
- (error "failed to install GRUB"))))
-
-(define (evaluate-populate-directive directive target)
+(define* (evaluate-populate-directive directive target
+ #:key
+ (default-gid 0)
+ (default-uid 0))
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
-directory TARGET."
+directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
+the context of the caller. If the directive matches those defaults then,
+'chown' won't be run."
(let loop ((directive directive))
- (match directive
- (('directory name)
- (mkdir-p (string-append target name)))
- (('directory name uid gid)
- (let ((dir (string-append target name)))
- (mkdir-p dir)
- (chown dir uid gid)))
- (('directory name uid gid mode)
- (loop `(directory ,name ,uid ,gid))
- (chmod (string-append target name) mode))
- ((new '-> old)
- (symlink old (string-append target new))))))
+ (catch 'system-error
+ (lambda ()
+ (match directive
+ (('directory name)
+ (mkdir-p (string-append target name)))
+ (('directory name uid gid)
+ (let ((dir (string-append target name)))
+ (mkdir-p dir)
+ ;; If called from a context without "root" permissions, "chown"
+ ;; to root will fail. In that case, do not try to run "chown"
+ ;; and assume that the file will be chowned elsewhere (when
+ ;; interned in the store for instance).
+ (or (and (= uid default-uid) (= gid default-gid))
+ (chown dir uid gid))))
+ (('directory name uid gid mode)
+ (loop `(directory ,name ,uid ,gid))
+ (chmod (string-append target name) mode))
+ (('file name)
+ (call-with-output-file (string-append target name)
+ (const #t)))
+ (('file name (? string? content))
+ (call-with-output-file (string-append target name)
+ (lambda (port)
+ (display content port))))
+ ((new '-> old)
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ (symlink old (string-append target new)))
+ (lambda args
+ ;; When doing 'guix system init' on the current '/', some
+ ;; symlinks may already exists. Override them.
+ (if (= EEXIST (system-error-errno args))
+ (begin
+ (delete-file (string-append target new))
+ (try))
+ (apply throw args))))))))
+ (lambda args
+ ;; Usually we can only get here when installing to an existing root,
+ ;; as with 'guix system init foo.scm /'.
+ (format (current-error-port)
+ "error: failed to evaluate directive: ~s~%"
+ directive)
+ (apply throw args)))))
(define (directives store)
"Return a list of directives to populate the root file system that will host
STORE."
- `(;; Note: the store's GID is fixed precisely so we can set it here rather
- ;; than at activation time.
- (directory ,store 0 30000 #o1775)
+ `((directory ,store 0 0 #o1775)
(directory "/etc")
- (directory "/var/log") ; for dmd
+ (directory "/var/log") ; for shepherd
(directory "/var/guix/gcroots")
(directory "/var/empty") ; for no-login accounts
(directory "/var/db") ; for dhclient, etc.
("/var/guix/gcroots/booted-system" -> "/run/booted-system")
("/var/guix/gcroots/current-system" -> "/run/current-system")
+ ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
(directory "/bin")
- ("/bin/sh" -> "/run/current-system/profile/bin/bash")
(directory "/tmp" 0 0 #o1777) ; sticky bit
+ (directory "/var/tmp" 0 0 #o1777)
+ (directory "/var/lock" 0 0 #o1777)
- (directory "/root" 0 0) ; an exception
(directory "/home" 0 0)))
-(define (populate-root-file-system system target)
+(define* (populate-root-file-system system target
+ #:key (extras '()))
"Make the essential non-store files and directories on TARGET. This
-includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
+includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
+EXTRAS is a list of directives appended to the built-in directives to populate
+TARGET."
(for-each (cut evaluate-populate-directive <> target)
- (directives (%store-directory)))
+ (append (directives (%store-directory)) extras))
;; Add system generation 1.
- (symlink system
- (string-append target "/var/guix/profiles/system-1-link")))
-
-(define (reset-timestamps directory)
- "Reset the timestamps of all the files under DIRECTORY, so that they appear
-as created and modified at the Epoch."
- (display "clearing file timestamps...\n")
- (for-each (lambda (file)
- (let ((s (lstat file)))
- ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
- ;; the timestamp of symlinks cannot be changed, and there are
- ;; symlinks here pointing to /gnu/store, which is the host,
- ;; read-only store.
- (unless (eq? (stat:type s) 'symlink)
- (utime file 0 0 0 0))))
- (find-files directory "")))
-
-(define (register-closure store closure)
- "Register CLOSURE in STORE, where STORE is the directory name of the target
-store and CLOSURE is the name of a file containing a reference graph as used
-by 'guix-register'. As a side effect, this resets timestamps on store files."
- (let ((status (system* "guix-register" "--prefix" store
- closure)))
- (unless (zero? status)
- (error "failed to register store items" closure))))
+ (let ((generation-1 (string-append target
+ "/var/guix/profiles/system-1-link")))
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ (symlink system generation-1))
+ (lambda args
+ ;; If GENERATION-1 already exists, overwrite it.
+ (if (= EEXIST (system-error-errno args))
+ (begin
+ (delete-file generation-1)
+ (try))
+ (apply throw args)))))))
+
+(define %root-profile
+ "/var/guix/profiles/per-user/root")
+
+(define* (install-database-and-gc-roots root database profile
+ #:key (profile-name "guix-profile"))
+ "Install DATABASE, the store database, under directory ROOT. Create
+PROFILE-NAME and have it link to PROFILE, a store item."
+ (define (scope file)
+ (string-append root "/" file))
+
+ (define (mkdir-p* dir)
+ (mkdir-p (scope dir)))
+
+ (define (symlink* old new)
+ (symlink old (scope new)))
+
+ (install-file database (scope "/var/guix/db/"))
+ (chmod (scope "/var/guix/db/db.sqlite") #o644)
+ (mkdir-p* "/var/guix/profiles")
+ (mkdir-p* "/var/guix/gcroots")
+ (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")
+
+ ;; Make root's profile, which makes it a GC root.
+ (mkdir-p* %root-profile)
+ (symlink* profile
+ (string-append %root-profile "/" profile-name "-1-link"))
+ (symlink* (string-append profile-name "-1-link")
+ (string-append %root-profile "/" profile-name)))
+
+(define* (populate-single-profile-directory directory
+ #:key profile closure
+ (profile-name "guix-profile")
+ database)
+ "Populate DIRECTORY with a store containing PROFILE, whose closure is given
+in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
+is initialized to contain a single profile under /root pointing to PROFILE.
+
+When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
+DIRECTORY/var/guix/gcroots and friends.
+
+PROFILE-NAME is the name of the profile being created under
+/var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
+
+This is used to create the self-contained tarballs with 'guix pack'."
+ (define (scope file)
+ (string-append directory "/" file))
+
+ (define (mkdir-p* dir)
+ (mkdir-p (scope dir)))
+
+ (define (symlink* old new)
+ (symlink old (scope new)))
+
+ ;; Populate the store.
+ (populate-store (list closure) directory)
+
+ (when database
+ (install-database-and-gc-roots directory database profile
+ #:profile-name profile-name))
+
+ (match profile-name
+ ("guix-profile"
+ (mkdir-p* "/root")
+ (symlink* (string-append %root-profile "/guix-profile")
+ "/root/.guix-profile"))
+ ("current-guix"
+ (mkdir-p* "/root/.config/guix")
+ (symlink* (string-append %root-profile "/current-guix")
+ "/root/.config/guix/current"))
+ (_
+ #t)))
+
+(define (mount-cow-store target backing-directory)
+ "Make the store copy-on-write, using TARGET as the backing store. This is
+useful when TARGET is on a hard disk, whereas the current store is on a RAM
+disk."
+ (define (set-store-permissions directory)
+ "Set the right perms on DIRECTORY to use it as the store."
+ (chown directory 0 30000) ;use the fixed 'guixbuild' GID
+ (chmod directory #o1775))
+
+ (let ((tmpdir (string-append target "/tmp")))
+ (mkdir-p tmpdir)
+ (mount tmpdir "/tmp" "none" MS_BIND))
+
+ (let* ((rw-dir (string-append target backing-directory))
+ (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
+ (mkdir-p rw-dir)
+ (mkdir-p work-dir)
+ (mkdir-p "/.rw-store")
+ (set-store-permissions rw-dir)
+ (set-store-permissions "/.rw-store")
+
+ ;; Mount the overlay, then atomically make it the store.
+ (mount "none" "/.rw-store" "overlay" 0
+ (string-append "lowerdir=" (%store-directory) ","
+ "upperdir=" rw-dir ","
+ "workdir=" work-dir))
+ (mount "/.rw-store" (%store-directory) "" MS_MOVE)
+ (rmdir "/.rw-store")))
+
+(define (unmount-cow-store target backing-directory)
+ "Unmount copy-on-write store."
+ (let ((tmp-dir "/remove"))
+ (mkdir-p tmp-dir)
+ (mount (%store-directory) tmp-dir "" MS_MOVE)
+ (umount tmp-dir)
+ (rmdir tmp-dir)
+ (delete-file-recursively
+ (string-append target backing-directory))))
;;; install.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff