diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/activation.scm | 95 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 17 | ||||
| -rw-r--r-- | gnu/build/install.scm | 47 |
3 files changed, 147 insertions, 12 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index 909e971833..352e736050 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -30,6 +30,7 @@ activate-/bin/sh activate-modprobe activate-firmware + activate-ptrace-attach activate-current-system)) ;;; Commentary: @@ -40,6 +41,24 @@ ;;; ;;; Code: +(define (enumerate thunk) + "Return the list of values returned by THUNK until it returned #f." + (let loop ((entry (thunk)) + (result '())) + (if (not entry) + (reverse result) + (loop (thunk) (cons entry result))))) + +(define (current-users) + "Return the passwd entries for all the currently defined user accounts." + (setpw) + (enumerate getpwent)) + +(define (current-groups) + "Return the group entries for all the currently defined user groups." + (setgr) + (enumerate getgrent)) + (define* (add-group name #:key gid password system? (log-port (current-error-port))) "Add NAME as a user group, with the given numeric GID if specified." @@ -59,6 +78,11 @@ (define (dot-or-dot-dot? file) (member file '("." ".."))) +(define (make-file-writable file) + "Make FILE writable for its owner.." + (let ((stat (lstat file))) ;XXX: symlinks + (chmod file (logior #o600 (stat:perms stat))))) + (define* (copy-account-skeletons home #:optional (directory %skeleton-directory)) "Copy the account skeletons from DIRECTORY to HOME." @@ -66,8 +90,21 @@ string<?))) (mkdir-p home) (for-each (lambda (file) - (copy-file (string-append directory "/" file) - (string-append home "/" file))) + (let ((target (string-append home "/" file))) + (copy-file (string-append directory "/" file) target) + (make-file-writable target))) + files))) + +(define* (make-skeletons-writable home + #:optional (directory %skeleton-directory)) + "Make sure that the files that have been copied from DIRECTORY to HOME are +owner-writable in HOME." + (let ((files (scandir directory (negate dot-or-dot-dot?) + string<?))) + (for-each (lambda (file) + (let ((target (string-append home "/" file))) + (when (file-exists? target) + (make-file-writable target)))) files))) (define* (add-user name group @@ -109,7 +146,14 @@ properties. Return #t on success." ,@(if password `("-p" ,password) '()) ,@(if system? '("--system") '()) ,name))) - (zero? (apply system* "useradd" args))))) + (and (zero? (apply system* "useradd" args)) + (begin + ;; Since /etc/skel is a link to a directory in the store where + ;; all files have the writable bit cleared, and since 'useradd' + ;; preserves permissions when it copies them, explicitly make + ;; them writable. + (make-skeletons-writable home) + #t))))) (define* (modify-user name group #:key uid comment home shell password system? @@ -128,6 +172,17 @@ properties. Return #t on success." ,name))) (zero? (apply system* "usermod" args)))) +(define* (delete-user name #:key (log-port (current-error-port))) + "Remove user account NAME. Return #t on success. This may fail if NAME is +logged in." + (format log-port "deleting user '~a'...~%" name) + (zero? (system* "userdel" name))) + +(define* (delete-group name #:key (log-port (current-error-port))) + "Remove group NAME. Return #t on success." + (format log-port "deleting group '~a'...~%" name) + (zero? (system* "groupdel" name))) + (define* (ensure-user name group #:key uid comment home shell password system? (supplementary-groups '()) @@ -186,8 +241,22 @@ numeric gid or #f." #:system? system?)))) groups) - ;; Finally create the other user accounts. - (for-each activate-user users)) + ;; Create the other user accounts. + (for-each activate-user users) + + ;; Finally, delete extra user accounts and groups. + (for-each delete-user + (lset-difference string=? + (map passwd:name (current-users)) + (match users + (((names . _) ...) + names)))) + (for-each delete-group + (lset-difference string=? + (map group:name (current-groups)) + (match groups + (((names . _) ...) + names))))) (define (activate-etc etc) "Install ETC, a directory in the store, as the source of static files for @@ -292,6 +361,20 @@ by itself, without having to resort to a \"user helper\"." (lambda (port) (display directory port)))) +(define (activate-ptrace-attach) + "Allow users to PTRACE_ATTACH their own processes. + +This works around a regression introduced in the default \"security\" policy +found in Linux 3.4 onward that prevents users from attaching to their own +processes--see Yama.txt in the Linux source tree for the rationale. This +sounds like an unacceptable restriction for little or no security +improvement." + (let ((file "/proc/sys/kernel/yama/ptrace_scope")) + (when (file-exists? file) + (call-with-output-file file + (lambda (port) + (display 0 port)))))) + (define %current-system ;; The system that is current (a symlink.) This is not necessarily the same diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 38e4851515..dc99d60d3d 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,6 +55,7 @@ (define MS_NOSUID 2) (define MS_NODEV 4) (define MS_NOEXEC 8) +(define MS_REMOUNT 32) (define MS_BIND 4096) (define MS_MOVE 8192) @@ -280,13 +281,21 @@ run a file system check." (match spec ((source title mount-point type (flags ...) options check?) (let ((source (canonicalize-device-spec source title)) - (mount-point (string-append root "/" mount-point))) + (mount-point (string-append root "/" mount-point)) + (flags (mount-flags->bit-mask flags))) (when check? (check-file-system source type)) (mkdir-p mount-point) - (mount source mount-point type (mount-flags->bit-mask flags) + (mount source mount-point type flags (if options (string->pointer options) - %null-pointer)))))) + %null-pointer)) + + ;; For read-only bind mounts, an extra remount is needed, as per + ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (mount source mount-point type (logior MS_BIND MS_REMOUNT MS_RDONLY) + %null-pointer)))))) ;;; file-systems.scm ends here diff --git a/gnu/build/install.scm b/gnu/build/install.scm index aa901f6971..76536daf49 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,12 +18,14 @@ (define-module (gnu build install) #:use-module (guix build utils) + #:use-module (guix build store-copy) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (install-grub populate-root-file-system reset-timestamps - register-closure)) + register-closure + populate-single-profile-directory)) ;;; Commentary: ;;; @@ -118,6 +120,8 @@ STORE." (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))) @@ -156,4 +160,43 @@ by 'guix-register'. As a side effect, this resets timestamps on store files." (unless (zero? status) (error "failed to register store items" closure)))) +(define* (populate-single-profile-directory directory + #:key profile closure) + "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." + (define (scope file) + (string-append directory "/" file)) + + (define %root-profile + "/var/guix/profiles/per-user/root") + + (define (mkdir-p* dir) + (mkdir-p (scope dir))) + + (define (symlink* old new) + (symlink old (scope new))) + + ;; 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")) + ;;; install.scm ends here |