[gnunet-scheme] 68/324: scripts: download-store: allow downloads in nar format

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

commit 759ca0a45d7817cb0b337a13a2cb1662ba1caffe
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sun Jan 31 15:47:26 2021 +0100

    scripts: download-store: allow downloads in nar format
    
    * gnu/gnunet/scripts/download-store.scm
      (write-file-tree/recursive): wrapper around Guix' write-file-tree.
      (download:gnunet-nar/0-to-nar): implement.
      (call-with-cmdline-output-port): new procedure.
      (download-sxml/entry!): fix parsing of sxml of symlinks.
      (entry-name): move out of verify-directory-entries!
      (gnunet-hash-size): new procedure, extract file sizes
      from gnunet://fs/chk/... URIs.
---
 gnu/gnunet/scripts/download-store.scm | 169 ++++++++++++++++++++++++++++++----
 gnu/gnunet/scripts/guix-stuff.scm     |  11 ++-
 2 files changed, 162 insertions(+), 18 deletions(-)

diff --git a/gnu/gnunet/scripts/download-store.scm 
b/gnu/gnunet/scripts/download-store.scm
index d52ed28..50d2c4b 100644
--- a/gnu/gnunet/scripts/download-store.scm
+++ b/gnu/gnunet/scripts/download-store.scm
@@ -21,23 +21,33 @@
   (export main)
   (import (gnu gnunet scripts guix-stuff)
          (ice-9 getopt-long)
+         (ice-9 optargs)
          (rnrs base)
          (rnrs io simple)
          (rnrs io ports)
          (rnrs bytevectors)
-         (only (ice-9 match) match)
+         (only (guix serialization)
+               ;; XXX make optional
+               write-file-tree)
+         (ice-9 match)
          (only (rnrs control) when unless)
          (only (rnrs programs) exit)
          (only (guile)
-               string-any
+               substring string-any
                string-prefix? system* status:exit-val
                string-split sort negate compose
                dirname
                throw
                file-exists? symlink stat mkdir umask
-               chmod stat:mode logior logand lognot getenv)
-         (srfi srfi-1)
+               chmod stat:mode logior logand lognot getenv
+               make-hash-table hash-ref hash-set!
+               force-output setvbuf delete-file
+               port-filename fileno)
+         (only (ice-9 fdes-finalizers)
+               add-fdes-finalizer!)
          (srfi srfi-1)
+         (only (srfi srfi-13)
+               string-index-right)
          (srfi srfi-26)
          (srfi srfi-39)
          (srfi srfi-41))
@@ -199,10 +209,128 @@ format from @var{uri} to the directory @var{output}."
              (read (open-bytevector-input-port container/bv))))
        container/sxml))
 
-    (define (download:gnunet-nar/0-to-nar uri output)
+    (define* (write-file-tree/recursive file port
+                                       #:key
+                                       file-type+size
+                                       file-port
+                                       symlink-target
+                                       directory-entries)
+      "A variant of write-file-tree that doesn't identify files
+with strings. DIRECTORY-ENTRIES should return pairs, with as
+car the directory entry name, and as cdr the file."
+      ;; Store ‘fake file name’ -> ‘real identifier’
+      ;;  mappings in a hash table.
+      ;; 913 = number of entries for guile-3.0.5:
+      ;; find /gnu/store/[...]-guile-3.0.5 | wc --lines
+      (let ((h (make-hash-table 913)))
+       (define (lookup-file stringy-file)
+         (hash-ref h stringy-file))
+       (define (add-child! stringy-parent name child)
+         (let ((stringy-child (string-append stringy-parent "/" name)))
+           (when (hash-ref h stringy-child)
+             (throw 'xxx-oops-already-exists-theres-a-duplicate))
+           (hash-set! h stringy-child child)))
+       (define file-type+size* (compose file-type+size lookup-file))
+       (define file-port* (compose file-port lookup-file))
+       (define symlink-target* (compose file-port lookup-file))
+       (define (directory-entries* stringy-directory)
+         (let* ((directory (lookup-file stringy-directory))
+                (entries   (directory-entries directory))
+                (entry->stringy
+                 (lambda (name child)
+                   (add-child! stringy-directory name child)
+                   name))
+                (stringy-entries
+                 (map (lambda (name+child)
+                        (entry->stringy (car name+child)
+                                        (cdr name+child)))
+                      entries)))
+           stringy-entries))
+       (define %stringy-file "")
+       (hash-set! h %stringy-file file)
+       (write-file-tree %stringy-file port
+                        #:file-type+size file-type+size*
+                        #:file-port file-port*
+                        #:symlink-target symlink-target*
+                        #:directory-entries directory-entries*)))
+
+    (define (download:gnunet-nar/0-to-nar uri nar-output)
       "Download the normalised archive in @var{gnunet-nix-archive-json/0}
 format from @var{uri} to the file @var{output}."
-      (throw 'todo 'implement-me 'please))
+      (define (file-type+size file+root?)
+       (display (car file+root?))
+       (if (cdr file+root?)
+           (match (car file+root?)
+             (`(regular (@ (executable? ,executable?)
+                           (hash ,hash)))
+              (values (if executable? 'executable 'regular)
+                      (gnunet-hash->size hash)))
+             ;; XXX where did the (@) appear from?
+             (`(directory (@) . ,_)
+              (values 'directory 'bogus))
+             (`(symlink (@ (target ,_)))
+              (values 'symlink 'bogus)))
+           (match (car file+root?)
+             (`(regular (@ (name . ,_)
+                           (executable? ,executable?)
+                           (hash ,hash)))
+              (values (if executable? 'executable 'regular)
+                      (gnunet-hash->size hash)))
+             (`(directory (@ (name ,_)) . ,_)
+              (values 'directory 'bogus))
+             (`(symlink (@ (name ,_) (target ,_)))
+              (values 'symlink 'bogus)))))
+      (define (port-for-hash hash)
+       (let* ((port (temporary-output-file))
+              (name (port-filename port)))
+         (add-fdes-finalizer! (fileno port)
+                              (lambda (_)
+                                (delete-file name)))
+         ;; XXX copying everything to the filesystem first
+         ;; isn't ideal.
+         (display 'tick)
+         (gnunet-download hash (port-filename port))
+         (display 'tack)
+         (display port)
+         port))
+      (define (file-port file+root?)
+       (port-for-hash
+        (match (car file+root?)
+          (`(regular (@ (executable? ,_)
+                        (hash ,hash))) hash)
+          (`(regular (@ (name ,_)
+                        (executable? ,_)
+                        (hash ,hash))) hash))))
+      (define (symlink-target file+root?)
+       (match (car file+root?)
+         (`(symlink (@ (name ,_) (target ,target)))
+          target)
+         (`(symlink (@ (target ,target)))
+          target)))
+      (define (directory-entries file+root?)
+       (map (lambda (child)
+              (cons (entry-name child)
+                    (cons child #f)))
+            (match (car file+root?)
+              (`(directory (@ (name ,_)) . ,files) files)
+              (`(directory (@) . ,files) files))))
+      (call-with-cmdline-output-port
+       nar-output
+       (lambda (nar-port)
+        (setvbuf nar-port 'block)
+        (write-file-tree/recursive (cons (download->sxml uri) #t)
+                                   nar-port
+                                   #:file-type+size file-type+size
+                                   #:file-port file-port
+                                   #:symlink-target symlink-target
+                                   #:directory-entries directory-entries)
+        (force-output nar-port))))
+
+    (define (call-with-cmdline-output-port name proc)
+      (cond ((string=? name "-")
+            (proc (current-output-port)))
+           (else
+            (call-with-output-file name proc))))
 
     (define (create:regular hash output executable?)
       (gnunet-download hash output)
@@ -247,26 +375,26 @@ OUTPUT/NAME may not already exist."
                      (executable? ,executable?)
                      (hash ,hash)))
         (create:regular hash (prefix name) executable?))
-       (`(symlink (@ (target ,target)
-                     (name ,target)))
+       (`(symlink (@ (name ,name)
+                     (target ,target)))
         (create:symlink target (prefix name)))
        (`(directory (@ (name ,name)) . ,files)
         (mkdir (prefix name))
         (verify-directory-entries! files)
         (for-each (cute download-sxml/entry! <> (prefix name)) files))))
 
+    (define (entry-name sxml)
+      (match sxml
+       (`(regular (@ (name ,name) . ,_))
+        name)
+       (`(symlink (@ (name ,name) . ,_))
+        name)
+       (`(directory (@ (name ,name) . ,_) . ,_)
+        name)))
     (define (verify-directory-entries! entries)
       "Verify whether the names of the entries in ENTRIES
 are unique, and whether they are reasonable (no #\nul bytes,
 not . or ..)."
-      (define (entry-name sxml)
-       (match sxml
-         (`(regular (@ (name ,name) . ,_))
-          name)
-         (`(symlink (@ (name ,name) . ,_))
-          name)
-         (`(directory (@ (name ,name) . ,_) . ,_)
-          name)))
       (define names (map entry-name entries))
       ;; Detect troublesome names
       (for-each (lambda (name)
@@ -287,4 +415,11 @@ not . or ..)."
            (let ((next (car next-names)))
              (if (equal? previous next)
                  (throw 'duplicate-name)
-                 (loop next (cdr next-names)))))))))
+                 (loop next (cdr next-names)))))))
+
+    ;; XXX move this elsewhere
+    (define (gnunet-hash->size str)
+      (let* ((last-dot (string-index-right str #\.))
+            (size/text (substring str (+ 1 last-dot)))
+            (size (string->number size/text)))
+       size))))
diff --git a/gnu/gnunet/scripts/guix-stuff.scm 
b/gnu/gnunet/scripts/guix-stuff.scm
index 37f0601..d2f61de 100644
--- a/gnu/gnunet/scripts/guix-stuff.scm
+++ b/gnu/gnunet/scripts/guix-stuff.scm
@@ -1,6 +1,7 @@
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,7 +19,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu gnunet scripts guix-stuff)
-  #:export (call-with-temporary-output-file))
+  #:export (call-with-temporary-output-file
+           temporary-output-file))
 
 (define (call-with-temporary-output-file proc)
   "Call PROC with a name of a temporary file and open output port to that
@@ -36,3 +38,10 @@ call."
         (false-if-exception (close out))
         (false-if-exception (delete-file template))))))
 
+;; Variant defined in Scheme-GNUnet, that doesn't close the port.
+(define (temporary-output-file)
+  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
+         (template  (string-append directory "/guix-file.XXXXXX"))
+         (out       (mkstemp! template)))
+    (set-port-filename! out template)
+    out))

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.