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>

4 files changed, 164 insertions, 17 deletions

diff --git a/guix/serialization.scm b/guix/serialization.scm
index c0f5ee5e86d..54ff5da03d9 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -550,6 +550,13 @@ which case you can use 'identity'."
 (define port-conversion-strategy
   (fluid->parameter %default-port-conversion-strategy))
 
+(define (valid-nar-file-name? name)
+  (not (or (string-null? name)
+           (string-index name #\/)
+           (string-index name #\nul)
+           (string=? name "..")
+           (string=? name "."))))
+
 (define (fold-archive proc seed port file)
   "Read a file (possibly a directory structure) in Nar format from PORT.  Call
 PROC on each file or directory read from PORT using:
@@ -610,6 +617,7 @@ depends on TYPE."
         (("(" "type" "directory")
          (let ((dir file))
            (let loop ((prefix (read-string port))
+                      (previous #f) ; for verifying ordering and uniqueness
                       (result (proc file 'directory #f result)))
              (match prefix
                ("entry"
@@ -617,6 +625,23 @@ depends on TYPE."
                              (read-string port) (read-string port)
                              (read-string port))
                   (("(" "name" file "node")
+                   (unless (valid-nar-file-name? file)
+                     (raise
+                      (condition
+                       (&message (message "invalid filename"))
+                       (&nar-read-error (port port)
+                                        (file dir)
+                                        (token file)))))
+                   (when (and previous
+                              (string>=? previous file))
+                     (raise
+                      (condition
+                       (&message
+                        ;; This also catches duplicate entries.
+                        (message "directory entry not in strictly ascending order"))
+                       (&nar-read-error (port port)
+                                        (file dir)
+                                        (token file)))))
                    (let ((result (read (string-append dir "/" file) result)))
                      (match (read-string port)
                        (")" #f)
@@ -628,7 +653,7 @@ depends on TYPE."
                           (&nar-read-error (port port)
                                            (file file)
                                            (token x))))))
-                     (loop (read-string port) result)))))
+                     (loop (read-string port) file result)))))
                (")"                               ;done with DIR
                 (proc file 'directory-complete #f result))
                (x
@@ -642,12 +667,25 @@ depends on TYPE."
            (&message (message "unsupported nar entry type"))
            (&nar-read-error (port port) (file file) (token x)))))))))
 
+
+(define (call-with-port* port proc)
+  "Like call-with-port, but closes PORT unconditionally when PROC's dynamic
+extent is left instead of only when PROC finishes normally."
+  (dynamic-wind
+    (const #t)
+    (lambda ()
+      (proc port))
+    (lambda ()
+      (close-port port))))
+
 (define (dump-file file input size type)
-  "Dump SIZE bytes from INPUT to FILE.
+  "Dump SIZE bytes from INPUT to FILE, throwing system-error with an errno of
+EEXIST if FILE already exists.
 
 This procedure is suitable for use as the #:dump-file argument to
 'restore-file'."
-  (call-with-output-file file
+  (call-with-port* (open file (logior O_WRONLY O_CREAT O_EXCL
+                                      O_NOFOLLOW O_CLOEXEC))
     (lambda (output)
       (dump input output size))))
 
@@ -685,6 +723,7 @@ a custom procedure, for instance to deduplicate FILE on the fly."
 
 ;;; Local Variables:
 ;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
+;;; eval: (put 'call-with-port* 'scheme-indent-function 1)
 ;;; End:
 
 ;;; serialization.scm ends here
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 2005653c95c..a9deceb3765 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -310,17 +310,30 @@ OUTPUT as it goes."
 
   (make-custom-binary-input-port "tee input port" read! #f #f #f))
 
+(define (call-with-fresh-output-file file proc)
+  "Like call-with-output-file, but ensure FILE is newly-created and does not
+follow symlinks.  Throw to key 'system-error with errno EEXIST if FILE already
+exists."
+  (let ((port (open file (logior O_WRONLY O_CREAT O_EXCL
+                                 O_NOFOLLOW O_CLOEXEC))))
+    (dynamic-wind (const #t)
+                  (lambda ()
+                    (proc port))
+                  (lambda ()
+                    (close-port port)))))
+
 (define* (dump-file/deduplicate file input size type
                                 #:key (store (%store-directory)))
-  "Write SIZE bytes read from INPUT to FILE.  TYPE is a symbol, either
-'regular or 'executable.
+  "Write SIZE bytes read from INPUT to FILE, throwing system-error with an
+errno of EEXIST if FILE already exists.  TYPE is a symbol, either 'regular or
+'executable.
 
 This procedure is suitable as a #:dump-file argument to 'restore-file'.  When
 used that way, it deduplicates files on the fly as they are restored, thereby
 removing the need for a deduplication pass that would re-read all the files
 down the road."
   (define (dump-and-compute-hash)
-    (call-with-output-file file
+    (call-with-fresh-output-file file
       (lambda (output)
         (let-values (((hash-port get-hash)
                       (open-hash-port (hash-algorithm sha256))))
@@ -333,7 +346,7 @@ down the road."
 
   (if (>= size %deduplication-minimum-size)
       (deduplicate file (dump-and-compute-hash) #:store store)
-      (call-with-output-file file
+      (call-with-fresh-output-file file
         (lambda (output)
           (if (file-port? input)
               (sendfile output input size 0)
@@ -352,3 +365,7 @@ down the road."
                                    'regular
                                    'executable)
                                #:store store)))))
+
+;;; Local Variables:
+;;; eval: (put 'call-with-fresh-output-file 'scheme-indent-function 1)
+;;; End:
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: