diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/activation.scm | 66 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 39 |
2 files changed, 83 insertions, 22 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index b458aee4ae..2af1d44b5f 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -1,6 +1,11 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,7 +42,8 @@ activate-modprobe activate-firmware activate-ptrace-attach - activate-current-system)) + activate-current-system + mkdir-p/perms)) ;;; Commentary: ;;; @@ -55,12 +61,54 @@ (define (dot-or-dot-dot? file) (member file '("." ".."))) +;; Based upon mkdir-p from (guix build utils) +(define (verify-not-symbolic dir) + "Verify DIR or its ancestors aren't symbolic links." + (define absolute? + (string-prefix? "/" dir)) + + (define not-slash + (char-set-complement (char-set #\/))) + + (define (verify-component file) + (unless (eq? 'directory (stat:type (lstat file))) + (error "file name component is not a directory" dir))) + + (let loop ((components (string-tokenize dir not-slash)) + (root (if absolute? + "" + "."))) + (match components + ((head tail ...) + (let ((file (string-append root "/" head))) + (catch 'system-error + (lambda () + (verify-component file) + (loop tail file)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #t + (apply throw args)))))) + (() #t)))) + +;; TODO: the TOCTTOU race can be addressed once guile has bindings +;; for fstatat, openat and friends. +(define (mkdir-p/perms directory owner bits) + "Create the directory DIRECTORY and all its ancestors. +Verify no component of DIRECTORY is a symbolic link. +Warning: this is currently suspect to a TOCTTOU race!" + (verify-not-symbolic directory) + (mkdir-p directory) + (chown directory (passwd:uid owner) (passwd:gid owner)) + (chmod directory bits)) + (define* (copy-account-skeletons home #:key (directory %skeleton-directory) uid gid) "Copy the account skeletons from DIRECTORY to HOME. When UID is an integer, -make it the owner of all the files created; likewise for GID." +make it the owner of all the files created except the home directory; likewise +for GID." (define (set-owner file) (when (or uid gid) (chown file (or uid -1) (or gid -1)))) @@ -68,7 +116,6 @@ make it the owner of all the files created; likewise for GID." (let ((files (scandir directory (negate dot-or-dot-dot?) string<?))) (mkdir-p home) - (set-owner home) (for-each (lambda (file) (let ((target (string-append home "/" file))) (copy-recursively (string-append directory "/" file) @@ -168,10 +215,15 @@ they already exist." (uid (passwd:uid pw)) (gid (passwd:gid pw))) (mkdir-p home) - (chown home uid gid) (chmod home #o700) (copy-account-skeletons home - #:uid uid #:gid gid)))))) + #:uid uid #:gid gid) + + ;; It is important 'chown' be called after + ;; 'copy-account-skeletons'. Otherwise, a malicious user with + ;; good timing could create a symlink in HOME that would be + ;; dereferenced by 'copy-account-skeletons'. + (chown home uid gid)))))) (for-each ensure-user-home users)) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index ddf6117b67..304805db62 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, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net> @@ -909,12 +909,21 @@ corresponds to the symbols listed in FLAGS." (if options (string-append "," options) ""))))) - (let ((type (file-system-type fs)) - (options (file-system-options fs)) - (source (canonicalize-device-spec (file-system-device fs))) - (mount-point (string-append root "/" - (file-system-mount-point fs))) - (flags (mount-flags->bit-mask (file-system-flags fs)))) + (let* ((type (file-system-type fs)) + (source (canonicalize-device-spec (file-system-device fs))) + (target (string-append root "/" + (file-system-mount-point fs))) + (flags (logior (mount-flags->bit-mask (file-system-flags fs)) + + ;; For bind mounts, preserve the original flags such + ;; as MS_NOSUID, etc. Failing to do that, the + ;; MS_REMOUNT call below fails with EPERM. + ;; See <https://bugs.gnu.org/46292> + (if (memq 'bind-mount (file-system-flags fs)) + (statfs-flags->mount-flags + (file-system-mount-flags (statfs source))) + 0))) + (options (file-system-options fs))) (when (file-system-check? fs) (check-file-system source type)) @@ -925,24 +934,24 @@ corresponds to the symbols listed in FLAGS." ;; needed. (if (and (= MS_BIND (logand flags MS_BIND)) (not (file-is-directory? source))) - (unless (file-exists? mount-point) - (mkdir-p (dirname mount-point)) - (call-with-output-file mount-point (const #t))) - (mkdir-p mount-point)) + (unless (file-exists? target) + (mkdir-p (dirname target)) + (call-with-output-file target (const #t))) + (mkdir-p target)) (cond ((string-prefix? "nfs" type) - (mount-nfs source mount-point type flags options)) + (mount-nfs source target type flags options)) (else - (mount source mount-point type flags options))) + (mount source target type flags options))) ;; 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))) - (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) - (mount source mount-point type flags #f)))) + (let ((flags (logior MS_REMOUNT flags))) + (mount source target type flags options)))) (lambda args (or (file-system-mount-may-fail? fs) (apply throw args)))))) |