guix: serialization: validate directory entry names in fold-archive [security fix].

Also validate that they are in strictly ascending order, which also ensures
that there are no duplicate names.

When 'guix substitute' fetches a nar, it does so with a validly-signed hash
already known from the narinfo.  But it can't verify that the hash of the nar
it's currently fetching matches until the full nar is downloaded.  Until then,
'download-nar' will extract the nar into the specified destination using
'restore-path', which avoids having to keep a file of unbounded size in
memory.  Critically, this means that the input that 'restore-path' (and by
extension 'fold-archive') is processing is untrusted, since substitute server
TLS certificates aren't verified (the narinfo signatures are supposed to make
it unnecessary).

As such, the scope of harm that can be caused by a malicious nar being
processed by 'restore-file' needs to be minimized.

* guix/serialization.scm (valid-nar-file-name?): new procedure.
  (fold-archive): Use it to verify that directory entry names do not contain
  '/' or '\0', and they are not equal to ".", "..", or "".  Also verify that
  they are in strictly ascending order.
  (call-with-port*): new procedure.
  (dump-file): use O_EXCL and O_NOFOLLOW.  This precaution ensures that even
  if 'restore-file' is somehow tricked into writing to a symlink (not
  currently believed to be possible), it will result in an error.
* guix/store/deduplication.scm (call-with-fresh-output-file): new procedure.
  (dump-file/deduplicate): use it for similar reasons as 'dump-file'.
* tests/nar.scm (call-with-tree-port, port-bad-nar?): new procedures.
  ("write-file-tree + fold-archive, unsorted directory entries",
   "write-file-tree + fold-archive, duplicate directory entries",
   "write-file-tree + fold-archive, invalid directory entries"): new tests.
* tests/publish.scm (call-with-temporary-output-filename): new procedure.
  ("/nar/*", "/nar/gzip/*", "/nar/lzip/*", "/nar/zstd/*", "/nar/ with properly
  encoded '+' sign"): use it in these test cases so that the output filename
  doesn't name an already-existing file.

Change-Id: I41f248c13d7af787233afad5cae102056329a68b
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 101 insertions, 10 deletions

diff --git a/tests/nar.scm b/tests/nar.scm
index 98752f20884..b446ea3d923 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -35,6 +35,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
+  #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 regex)
   #:use-module ((ice-9 control) #:select (let/ec))
@@ -268,6 +269,84 @@
                    (open-bytevector-input-port (get-bytevector))
                    "R"))))
 
+(define (call-with-tree-port tree proc)
+      (let ((bv (call-with-output-bytevector
+                 (lambda (port)
+                   (apply write-file-tree "root" port tree)))))
+        (call-with-input-bytevector bv proc)))
+
+(define (port-bad-nar? port)
+  (guard (c ((nar-error? c)
+             (pk 'nar-error c)
+             #t))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (rm-rf %test-dir)
+        (mkdir %test-dir)
+        (restore-file port (string-append %test-dir "/foo")))
+      (lambda ()
+        (false-if-exception (rm-rf %test-dir))))))
+
+(test-assert "write-file-tree + fold-archive, unsorted directory entries"
+  (let* ((unsorted-tree (list #:file-type+size
+                              (match-lambda
+                                ("root" (values 'directory 0))
+                                ("root/c" (values 'regular 1))
+                                ("root/b" (values 'regular 1))
+                                ("root/a" (values 'regular 1)))
+                              #:file-port
+                              (match-lambda
+                                ("root/c" (open-input-string "c"))
+                                ("root/b" (open-input-string "b"))
+                                ("root/a" (open-input-string "a")))
+                              #:directory-entries
+                              (match-lambda
+                                ("root" '("c" "b" "a")))
+                              ;; We wish to deliberately create invalid
+                              ;; entries
+                              #:postprocess-entries identity)))
+    (call-with-tree-port unsorted-tree port-bad-nar?)))
+
+(test-assert "write-file-tree + fold-archive, duplicate directory entries"
+  (let* ((duplicates-tree (list #:file-type+size
+                                (match-lambda
+                                  ("root" (values 'directory 0))
+                                  ("root/a" (values 'regular 1)))
+                                #:file-port
+                                (match-lambda
+                                  ("root/a" (open-input-string "a")))
+                                #:directory-entries
+                                (match-lambda
+                                  ("root" '("a" "a" "a")))
+                                ;; We wish to deliberately create invalid
+                                ;; entries
+                                #:postprocess-entries identity)))
+    (call-with-tree-port duplicates-tree port-bad-nar?)))
+
+(test-assert "write-file-tree + fold-archive, invalid directory entries"
+  (let* ((invalid-names (list "." ".." "" "../" "./"
+                              "/" "/bin/shh" "../../etc/passwwwd"
+                              (string #\nul) (string #\. #\/ #\nul)))
+         (invalid-name-trees (map (lambda (name)
+                                    (list #:file-type+size
+                                          (match-lambda
+                                            ("root" (values 'directory 0))
+                                            (_ (values 'regular 1)))
+                                          #:file-port
+                                          (lambda (_)
+                                            (open-input-string "a"))
+                                          #:directory-entries
+                                          (match-lambda
+                                            ("root" (list name)))
+                                          ;; We wish to deliberately create
+                                          ;; invalid entries
+                                          #:postprocess-entries identity))
+                                  invalid-names)))
+    (every (lambda (tree)
+             (call-with-tree-port tree port-bad-nar?))
+           invalid-name-trees)))
+
 (test-equal "write-file-tree + fold-archive, flat file"
   '(("R" regular "abcdefg"))
 
diff --git a/tests/publish.scm b/tests/publish.scm
index 3c80c50d515..91576abf139 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -96,6 +96,14 @@
         (lambda ()
           exp ...)))))
 
+;; 'call-with-temporary-output-file' produces a filename for a file that
+;; already exists, whereas this produces a filename for which no file exists
+;; inside a temporary directory.
+(define (call-with-temporary-output-filename proc)
+  (call-with-temporary-directory
+   (lambda (directory)
+     (proc (string-append directory "/output")))))
+
 ;; guix-publish uses (current-processor-count) as the default number of
 ;; workers, however on a system with a large number of cores, that large
 ;; number of worker threads being used in the course of these tests can end up
@@ -238,8 +246,8 @@ FileSize: ~a~%"
 
 (test-equal "/nar/*"
   "bar"
-  (call-with-temporary-output-file
-   (lambda (temp port)
+  (call-with-temporary-output-filename
+   (lambda (temp)
      (let ((nar (utf8->string
                  (http-get-body
                   (publish-uri
@@ -249,8 +257,8 @@ FileSize: ~a~%"
 
 (test-equal "/nar/gzip/*"
   "bar"
-  (call-with-temporary-output-file
-   (lambda (temp port)
+  (call-with-temporary-output-filename
+   (lambda (temp)
      (let ((nar (http-get-port
                  (publish-uri
                   (string-append "/nar/gzip/" (basename %item))))))
@@ -270,8 +278,8 @@ FileSize: ~a~%"
 
 (test-equal "/nar/lzip/*"
   "bar"
-  (call-with-temporary-output-file
-   (lambda (temp port)
+  (call-with-temporary-output-filename
+   (lambda (temp)
      (let ((nar (http-get-port
                  (publish-uri
                   (string-append "/nar/lzip/" (basename %item))))))
@@ -282,8 +290,8 @@ FileSize: ~a~%"
 (unless (zstd-supported?) (test-skip 1))
 (test-equal "/nar/zstd/*"
   "bar"
-  (call-with-temporary-output-file
-   (lambda (temp port)
+  (call-with-temporary-output-filename
+   (lambda (temp)
      (let ((nar (http-get-port
                  (publish-uri
                   (string-append "/nar/zstd/" (basename %item))))))
@@ -408,8 +416,8 @@ FileSize: ~a~%"
 (test-equal "/nar/ with properly encoded '+' sign"
   "Congrats!"
   (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
-    (call-with-temporary-output-file
-     (lambda (temp port)
+    (call-with-temporary-output-filename
+     (lambda (temp)
        (let ((nar (utf8->string
                    (http-get-body
                     (publish-uri
@@ -798,3 +806,7 @@ FileSize: ~a~%"
                (http-post (publish-uri path))))))
 
 (test-end "publish")
+
+;;; Local Variables:
+;;; eval: (put 'call-with-temporary-output-filename 'scheme-indent-function 0)
+;;; End: