;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 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.
;;;
#: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))
;;; 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.
-
-Note that the caller must make sure that GRUB.CFG is registered as a GC root
-so that the fonts, background images, etc. referred to by GRUB.CFG are not
-GC'd."
- (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, because symlinks won't
+ ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
;; work when /boot is on a separate partition. Do that atomically.
- (copy-file grub.cfg 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"))))
+ (copy-file bootcfg pivot)
+ (rename-file pivot target)))
-(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))
(catch 'system-error
(lambda ()
(('directory name uid gid)
(let ((dir (string-append target name)))
(mkdir-p dir)
- (chown dir uid gid)))
+ ;; 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
(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")
(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.
- (false-if-exception (delete-file "/var/guix/profiles/system-1-link"))
- (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)
+ #: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.
-This is used to create the self-contained Guix tarball."
+
+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 %root-profile
- "/var/guix/profiles/per-user/root")
-
(define (mkdir-p* dir)
(mkdir-p (scope dir)))
;; Populate the store.
(populate-store (list closure) directory)
- (register-closure (canonicalize-path directory) closure)
-
- ;; XXX: 'guix-register' registers profiles as GC roots but the symlink
- ;; target uses $TMPDIR. Fix that.
- (delete-file (scope "/var/guix/gcroots/profiles"))
- (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 "/guix-profile-1-link"))
- (symlink* (string-append %root-profile "/guix-profile-1-link")
- (string-append %root-profile "/guix-profile"))
- (mkdir-p* "/root")
- (symlink* (string-append %root-profile "/guix-profile")
- "/root/.guix-profile"))
+ (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)))
;;; install.scm ends here