aboutsummaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
authorEfraim Flashner <efraim@flashner.co.il>2021-03-24 15:28:33 +0200
committerEfraim Flashner <efraim@flashner.co.il>2021-03-24 20:50:44 +0200
commit2aab587f842908a886e3bd08b028885dddd650e0 (patch)
tree87c0723a9ae2c69ab6920d90b6e87ad8510492fe /gnu/build
parent5664bcdcb0e4c10dfe48dd5e4730fc3c746a21e2 (diff)
parent65c46e79e0495fe4d32f6f2725d7233fff10fd70 (diff)
downloadguix-2aab587f842908a886e3bd08b028885dddd650e0.tar
guix-2aab587f842908a886e3bd08b028885dddd650e0.tar.gz
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/activation.scm53
-rw-r--r--gnu/build/file-systems.scm10
2 files changed, 52 insertions, 11 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index b458aee4ae..6cb6f8819b 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,6 +61,47 @@
(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)
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index aca4aad848..304805db62 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -920,14 +920,8 @@ corresponds to the symbols listed in FLAGS."
;; MS_REMOUNT call below fails with EPERM.
;; See <https://bugs.gnu.org/46292>
(if (memq 'bind-mount (file-system-flags fs))
- (or (and=> (find (let ((devno (stat:dev
- (lstat source))))
- (lambda (mount)
- (= (mount-device-number mount)
- devno)))
- (mounts))
- mount-flags)
- 0)
+ (statfs-flags->mount-flags
+ (file-system-mount-flags (statfs source)))
0)))
(options (file-system-options fs)))
(when (file-system-check? fs)