01/02: Properly deal with build directories containing '~'.

[guix-commits]

civodul pushed a commit to branch version-1.2.0
in repository guix.

commit 977eb5d023cfdf8e336f1896480eea9cef5c04e9
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Nov 16 11:03:19 2020 +0100

    Properly deal with build directories containing '~'.
    
    Fixes <https://bugs.gnu.org/44626>.
    Reported by Vagrant Cascadian <vagrant@debian.org>.
    
    * tests/build-utils.scm ("wrap-script, simple case"): Pass
    SCRIPT-CONTENTS to 'display' rather than 'format'.
    * gnu/services/base.scm (file-system->shepherd-service-name)
    [valid-characters, mount-point]: New variables.
    Filter out invalid store file name characters from the mount point of
    FILE-SYSTEM.
---
 gnu/services/base.scm | 15 +++++++++++++--
 tests/build-utils.scm |  4 ++--
 2 files changed, 15 insertions(+), 4 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 499e50b..712b3a0 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -285,8 +285,19 @@ This service must be the root of the service dependency 
graph so that its
 (define (file-system->shepherd-service-name file-system)
   "Return the symbol that denotes the service mounting and unmounting
 FILE-SYSTEM."
-  (symbol-append 'file-system-
-                 (string->symbol (file-system-mount-point file-system))))
+  (define valid-characters
+    ;; Valid store characters; see 'checkStoreName' in the daemon.
+    (string->char-set
+     "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))
+
+  (define mount-point
+    (string-map (lambda (chr)
+                  (if (char-set-contains? valid-characters chr)
+                      chr
+                      #\-))
+                (file-system-mount-point file-system)))
+
+  (symbol-append 'file-system- (string->symbol mount-point)))
 
 (define (mapped-device->shepherd-service-name md)
   "Return the symbol that denotes the shepherd service of MD, a 
<mapped-device>."
diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index 47a57a9..654b480 100644
--- a/tests/build-utils.scm
+++ b/tests/build-utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -174,7 +174,7 @@ echo hello world"))
        (let ((script-file-name (string-append directory "/foo")))
          (call-with-output-file script-file-name
            (lambda (port)
-             (format port script-contents)))
+             (display script-contents port)))
          (chmod script-file-name #o777)
          (wrap-script script-file-name
                       `("GUIX_FOO" prefix ("/some/path"