From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:55061) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ff3dd-0006jc-HY for guix-patches@gnu.org; Mon, 16 Jul 2018 09:34:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ff3db-0002Ij-G2 for guix-patches@gnu.org; Mon, 16 Jul 2018 09:34:05 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:37365) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1ff3db-0002Id-Bp for guix-patches@gnu.org; Mon, 16 Jul 2018 09:34:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ff3db-0005aX-3o for guix-patches@gnu.org; Mon, 16 Jul 2018 09:34:03 -0400 Subject: [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree'. References: <20180716133049.15108-1-ludo@gnu.org> In-Reply-To: <20180716133049.15108-1-ludo@gnu.org> Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Mon, 16 Jul 2018 15:33:22 +0200 Message-Id: <20180716133327.15901-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 32174@debbugs.gnu.org * guix/serialization.scm (write-contents-from-port): New procedure. (write-contents): Write in terms of 'write-contents-from-port'. (filter/sort-directory-entries, write-file-tree): New procedures. (write-file): Rewrite in terms of 'write-file-tree'. * tests/nar.scm ("write-file-tree + restore-file"): New test. --- guix/serialization.scm | 140 +++++++++++++++++++++++++++++++---------- tests/nar.scm | 62 +++++++++++++++++- 2 files changed, 169 insertions(+), 33 deletions(-) diff --git a/guix/serialization.scm b/guix/serialization.scm index b41a0a09d..129374f54 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -47,6 +47,7 @@ nar-read-error-token write-file + write-file-tree restore-file)) ;;; Comment: @@ -211,14 +212,19 @@ substitute invalid byte sequences with question marks. This is a (lambda () (close-port port)))))) - (write-string "contents" p) - (write-long-long size p) (call-with-binary-input-file file - ;; Use 'sendfile' when P is a file port. - (if (file-port? p) - (cut sendfile p <> size 0) - (cut dump <> p size))) - (write-padding size p)) + (lambda (input) + (write-contents-from-port input p size)))) + +(define (write-contents-from-port input output size) + "Write SIZE bytes from port INPUT to port OUTPUT." + (write-string "contents" output) + (write-long-long size output) + ;; Use 'sendfile' when both OUTPUT and INPUT are file ports. + (if (and (file-port? output) (file-port? input)) + (sendfile output input size 0) + (dump input output size)) + (write-padding size output)) (define (read-contents in out) "Read the contents of a file from the Nar at IN, write it to OUT, and return @@ -263,47 +269,113 @@ the size in bytes." sub-directories of FILE as needed. For each directory entry, call (SELECT? FILE STAT), where FILE is the entry's absolute file name and STAT is the result of 'lstat'; exclude entries for which SELECT? does not return true." + (write-file-tree file port + #:file-type+size + (lambda (file) + (let* ((stat (lstat file)) + (size (stat:size stat))) + (case (stat:type stat) + ((directory) + (values 'directory size)) + ((regular) + (values (if (zero? (logand (stat:mode stat) + #o100)) + 'regular + 'executable) + size)) + (else + (values (stat:type stat) size))))) ;bah! + #:file-port (cut open-file <> "r0b") + #:symlink-target readlink + + #:directory-entries + (lambda (directory) + ;; 'scandir' defaults to 'string-locale '("." ".."))) + string '("." "..")) lst) + string '("." ".."))) string +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -152,6 +152,66 @@ (test-begin "nar") +(test-assert "write-file-tree + restore-file" + (let* ((file1 (search-path %load-path "guix.scm")) + (file2 (search-path %load-path "guix/base32.scm")) + (file3 "#!/bin/something") + (output (string-append %test-dir "/output"))) + (dynamic-wind + (lambda () #t) + (lambda () + (define-values (port get-bytevector) + (open-bytevector-output-port)) + (write-file-tree "root" port + #:file-type+size + (match-lambda + ("root" + (values 'directory 0)) + ("root/foo" + (values 'regular (stat:size (stat file1)))) + ("root/lnk" + (values 'symlink 0)) + ("root/dir" + (values 'directory 0)) + ("root/dir/bar" + (values 'regular (stat:size (stat file2)))) + ("root/dir/exe" + (values 'executable (string-length file3)))) + #:file-port + (match-lambda + ("root/foo" (open-input-file file1)) + ("root/dir/bar" (open-input-file file2)) + ("root/dir/exe" (open-input-string file3))) + #:symlink-target + (match-lambda + ("root/lnk" "foo")) + #:directory-entries + (match-lambda + ("root" '("foo" "dir" "lnk")) + ("root/dir" '("bar" "exe")))) + (close-port port) + + (rm-rf %test-dir) + (mkdir %test-dir) + (restore-file (open-bytevector-input-port (get-bytevector)) + output) + (and (file=? (string-append output "/foo") file1) + (string=? (readlink (string-append output "/lnk")) + "foo") + (file=? (string-append output "/dir/bar") file2) + (string=? (call-with-input-file (string-append output "/dir/exe") + get-string-all) + file3) + (> (logand (stat:mode (lstat (string-append output "/dir/exe"))) + #o100) + 0) + (equal? '("." ".." "bar" "exe") + (scandir (string-append output "/dir"))) + (equal? '("." ".." "dir" "foo" "lnk") + (scandir output)))) + (lambda () + (false-if-exception (rm-rf %test-dir)))))) + (test-assert "write-file supports non-file output ports" (let ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) -- 2.18.0