;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 store database)
+ #:use-module (guix build syscalls)
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (srfi srfi-26)
#:export (install-boot-config
evaluate-populate-directive
populate-root-file-system
- register-closure
- populate-single-profile-directory))
+ install-database-and-gc-roots
+ populate-single-profile-directory
+ mount-cow-store
+ unmount-cow-store))
;;; Commentary:
;;;
(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 shepherd
(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.
(let ((generation-1 (string-append target
(try))
(apply throw args)))))))
-(define* (register-closure prefix closure
- #:key
- (deduplicate? #t) (reset-timestamps? #t)
- (schema (sql-schema)))
- "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
-target store and CLOSURE is the name of a file containing a reference graph as
-produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
-true, reset timestamps on store files and, if DEDUPLICATE? is true,
-deduplicates files common to CLOSURE and the rest of PREFIX."
- (let ((items (call-with-input-file closure read-reference-graph)))
- (register-items items
- #:prefix prefix
- #:deduplicate? deduplicate?
- #:reset-timestamps? reset-timestamps?
- #:registration-time %epoch
- #:schema schema)))
+(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")
- deduplicate?
- register? schema)
+ 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 REGISTER? is true, initialize DIRECTORY/var/guix/db to reflect the
-contents of the store; DEDUPLICATE? determines whether to deduplicate files in
-the store.
+
+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\".
(define (scope file)
(string-append directory "/" file))
- (define %root-profile
- "/var/guix/profiles/per-user/root")
-
(define (mkdir-p* dir)
(mkdir-p (scope dir)))
(symlink old (scope new)))
;; Populate the store.
- (populate-store (list closure) directory)
-
- (when register?
- (register-closure (canonicalize-path directory) closure
- #:deduplicate? deduplicate?
- #:schema schema)
-
- (mkdir-p* "/var/guix/profiles")
- (mkdir-p* "/var/guix/gcroots")
- (symlink* "/var/guix/profiles"
- "/var/guix/gcroots/profiles"))
+ (populate-store (list closure) directory
+ #:deduplicate? #f)
- ;; 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))
+ (when database
+ (install-database-and-gc-roots directory database profile
+ #:profile-name profile-name))
(match profile-name
("guix-profile"
(_
#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