[gnunet-scheme] 67/324: scripts: Don't flatten the FS tree and use SXML instead of JSON

[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 9befd560c5eccc4fdc5f5ded588167cf9fd73b68
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sat Jan 30 21:02:07 2021 +0100

    scripts: Don't flatten the FS tree and use SXML instead of JSON
    
    * gnu/gnunet/scripts/download-store.scm: use a SXML tree instead
      of JSON.
    * gnu/gnunet/scripts/publish-store.scm: likewise.
---
 gnu/gnunet/scripts/download-store.scm | 214 +++++++++++++++-------------------
 gnu/gnunet/scripts/publish-store.scm  | 107 ++++++++---------
 2 files changed, 147 insertions(+), 174 deletions(-)

diff --git a/gnu/gnunet/scripts/download-store.scm 
b/gnu/gnunet/scripts/download-store.scm
index d3c9e15..d52ed28 100644
--- a/gnu/gnunet/scripts/download-store.scm
+++ b/gnu/gnunet/scripts/download-store.scm
@@ -25,6 +25,7 @@
          (rnrs io simple)
          (rnrs io ports)
          (rnrs bytevectors)
+         (only (ice-9 match) match)
          (only (rnrs control) when unless)
          (only (rnrs programs) exit)
          (only (guile)
@@ -35,7 +36,6 @@
                throw
                file-exists? symlink stat mkdir umask
                chmod stat:mode logior logand lognot getenv)
-         (json)
          (srfi srfi-1)
          (srfi srfi-1)
          (srfi srfi-26)
@@ -43,7 +43,7 @@
          (srfi srfi-41))
   (begin
     (define %supported-formats
-      '("any" "gnunet-nix-archive-json/0"))
+      '("gnunet-nar-sxml/0"))
 
     (define (gnunet-fs-uri? str)
       (or (string-prefix? "gnunet://fs/chk" str)
@@ -103,7 +103,7 @@ the options @var{options} are applied."
       "scheme-gnunet download-store v0.0")
 
     (define %help
-      "Usage: download-store [OPTIONS] -i URI -o DIRECTORY
+      "Usage: download-store [OPTIONS] -i URI -o FILENAME
 Download store items from GNUnet using a GNUnet CHK or LOC URI
 (gnunet://fs/chk/...).
 
@@ -117,7 +117,7 @@ Download resumption is currently unsupported.
   -f, --format     Representation of store items to use,
                    'any' by default.
   -i, --input      URI to download
-  -o, --output     Directory to save store items in.
+  -o, --output     Filename to save store item at.
       --nar        Location to write the nar to.
 
 GNUnet options
@@ -138,8 +138,8 @@ GNUnet options
            ((option-ref options 'help #f)
             (display %help)
             (newline))
-           ((member (option-ref options 'format "gnunet-nix-archive-json/0")
-                    '("gnunet-nix-archive-json/0" "any"))
+           ((equal? (option-ref options 'format "gnunet-nar-sxml/0")
+                    "gnunet-nar-sxml/0")
             ;; TODO should multiple outputs be allowed?
             (when (option-ref options 'output #f)
               (download:gnunet-nar/0-to-fs
@@ -187,126 +187,104 @@ instead of writing to a file."
     (define (download:gnunet-nar/0-to-fs uri output)
       "Download the normalised archive in @var{gnunet-nix-archive-json/0}
 format from @var{uri} to the directory @var{output}."
+      (when (file-exists? output)
+       (throw 'xxx-already-exists))
+      (download-sxml/root! (download->sxml uri) output))
+
+    (define (download->sxml uri)
       (let* ((container/bv (gnunet-download/bytevector uri))
-            (container/json (utf8->string container/bv))
-            (container/scm (json-string->scm container/json)))
-       (unless (equal? (assoc "version" container/scm)
-                       '("version" . "gnunet-nix-archive-json/0"))
-         (throw 'download-eep 'xxx-proper-error-message))
-       (let ((sorted (sort-entries (cdr (assoc "entries" container/scm)))))
-         (verify-entries sorted)
-         (download-entries! sorted output))))
+            ;; XXX don't allow hash-comma and other read constructs
+            ;; XXX check locale, character encoding, etc. things
+            (container/sxml
+             (read (open-bytevector-input-port container/bv))))
+       container/sxml))
 
     (define (download:gnunet-nar/0-to-nar uri 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 (download-entries! entries output)
-      (define (prefix name)
-       (string-append output "/" name))
-      (define (download-entry! entry)
-       (let* ((type (cdr (assoc "type" entry)))
-              (name (cdr (assoc "name" entry)))
-              (output (prefix name)))
-         (cond ((string=? type "directory")
-                (mkdir output))
-               ((or (string=? type "regular")
-                    (string=? type "executable"))
-                (gnunet-download (cdr (assoc "hash" entry)) output)
-                (when (string=? type "executable")
-                  (chmod output
-                         (logior (stat:mode (stat output))
-                                 (logand #o111 (lognot (umask)))))))
-               ((string=? type "symlink")
-                ;; FIXME check whether guile rejects
-                ;; \0, or silently trims them off
-                (symlink (cdr (assoc "target" entry)) output))
-               (else ???))))
-      (unless (file-exists? output)
-       (mkdir output))
-      (vector-for-each download-entry! entries))
+    (define (create:regular hash output executable?)
+      (gnunet-download hash output)
+      (when executable?
+       (chmod output
+              (logior (stat:mode (stat output))
+                      (logand #o111 (lognot (umask)))))))
 
-    (define (sort-entries entries)
-      "Sort ENTRIES, a list or vector of nar entries,
-in an order they should be created (parent directories should
-be created before children, for example"
-      (define (list<? component<? x y)
-       (cond ((and (eq? x '()) (eq? y '())) #f)
-             ((eq? x '()) #t)
-             ((eq? y '()) #f)
-             ((component<? (car x) (car y)) #t)
-             ((component<? (car y) (car x)) #f)
-             (else (list<? component<? (cdr x) (cdr y)))))
-      (define (entry<? x y)
-       (list<? string<?
-               (string-split (cdr (assoc "name" x)) #\/)
-               (string-split (cdr (assoc "name" y)) #\/)))
-      (sort entries entry<?))
+    (define (create:symlink target output)
+      (when (string-any #\nul target)
+       ;; Probably unsupported by the kernel,
+       ;; and various applications.
+       (throw 'XXX-no-nul-bytes-in-symlinks))
+      (symlink target output))
 
-    (define (vector->stream s)
-      (stream-map (cute vector-ref s <>)
-                 (stream-take (vector-length s)
-                              (stream-from 0))))
+    (define (download-sxml/root! sxml output)
+      "Download the structure described by SXML to OUTPUT.
+OUTPUT may not already exists, and the file described by
+SXML may not have a name."
+      (match sxml
+       (`(regular (@ (executable? ,executable?)
+                     (hash ,hash)))
+        (create:regular hash output executable?))
+       (`(symlink (@ (target ,target)))
+        (create:symlink target output))
+       ;; XXX I thought I never created a
+       ;; node (directory (@) . stuff)?
+       ;; Where did the (@) appear?
+       (`(directory (@) . ,files)
+        (mkdir output)
+        (verify-directory-entries! files)
+        (for-each (cute download-sxml/entry! <> output) files))))
 
-    (define (store-name? x)
-      'xxx 'todo 'for-example-no-nul-bytes
-      #t)
+    (define (download-sxml/entry! sxml parent-output)
+      "Download the structure described by SXML to OUTPUT/NAME,
+where NAME is the name of the file described by SXML.
+OUTPUT/NAME may not already exist."
+      (define (prefix name)
+       (string-append parent-output "/" name))
+      (match sxml
+       (`(regular (@ (name ,name)
+                     (executable? ,executable?)
+                     (hash ,hash)))
+        (create:regular hash (prefix name) executable?))
+       (`(symlink (@ (target ,target)
+                     (name ,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 (verify-entries sorted)
-      "Make sure there are no inconsistencies in SORTED"
-      (define sorted-stream (vector->stream sorted))
-      (define (name x)
-       (cdr (assoc "name" x)))
-      (define (duplicate? l)
-       (apply (lambda (x y)
-                (string=? (name x) (name y)))
-              l))
-      (define sorted-2à2
-       (stream-zip sorted-stream
-                   (stream-cdr sorted-stream)))
-      (define duplicates
-       (stream-filter duplicate? sorted-2à2))
-      (define bad-characters
-       (stream-filter (negate store-name?) sorted-stream))
-      (define (bad-name? x)
-       (or (= 0 (string-length x))
-           (any (lambda (x)
-                  (or (= 0 (string-length x))
-                      (string=? x ".")
-                      (string=? x "..")))
-                (string-split x #\/))))
-      (define bad-name
-       (stream-filter (compose bad-name? name) sorted-stream))
-      (define (directory-exists? latest next)
-       (let ((type-latest (cdr (assoc "type" latest)))
-             (type-next   (cdr (assoc "type" next))))
-         ;; entry in directory
-         (or (and (equal? type-latest "directory")
-                  (string-prefix?
-                   (string-append (name latest) "/")
-                   (name next)))
-             ;; two entries in same directory,
-             ;; or next entry is in some (grand...)parent of
-             ;; type-latest, or it is a top-level file
-             (let ((d (dirname (name next))))
-               (or (string=? d ".")
-                   (string-prefix? (string-append d "/") (name latest)))))))
-      (define missing-dir
-       (stream-filter (lambda (args)
-                        (not (apply directory-exists? args)))
-                      sorted-2à2))
-      (define first-entry-not-root
-       (stream-filter
-        (negate (lambda (x) (string=? "." (dirname (name x)))))
-        (stream-take 1 sorted-stream)))
-      (define bad
-       (stream-append
-        (stream-map (cute cons 'first-entry-not-root <>)
-                    first-entry-not-root)
-        (stream-map (cute cons 'duplicate <>) duplicates)
-        (stream-map (cute cons 'bad-characters <>) bad-characters)
-        (stream-map (cute cons 'bad-name <>) bad-name)
-        (stream-map (cute cons 'missing-dir <>) missing-dir)))
-      (stream-for-each (lambda (z) (throw '??? z))
-                      bad))))
+    (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)
+                 (cond ((not (string=? name))
+                        (throw 'XXX-is-not-a-string))
+                       ((or (string=? name ".")
+                            (string=? name ".."))
+                        (throw 'XXX-no-dotdot-allowed))
+                       ((string-any #\nul name)
+                        (throw 'XXX-no-nul-allowed))
+                       ((> (string-length name) 255)
+                        (throw 'XXX-way-to-long-filename))))
+               names)
+      ;; Detect duplicates
+      (let loop ((previous #f) (next-names (sort names string<?)))
+       (if (null? next-names)
+           'ok
+           (let ((next (car next-names)))
+             (if (equal? previous next)
+                 (throw 'duplicate-name)
+                 (loop next (cdr next-names)))))))))
diff --git a/gnu/gnunet/scripts/publish-store.scm 
b/gnu/gnunet/scripts/publish-store.scm
index ca5c2af..a41a6c4 100644
--- a/gnu/gnunet/scripts/publish-store.scm
+++ b/gnu/gnunet/scripts/publish-store.scm
@@ -17,21 +17,26 @@
 ;;   SPDX-License-Identifier: AGPL-3.0-or-later
 
 ;; Brief: publish an item of the store (GNU Guix) to GNUnet
-;; A quirk of the directory format to keep in mind:
+;;
+;; A quirk of the GNUnet's directory format to keep in mind:
 ;;  * the basename of the directory is saved in the .gnd
 ;;  * the basename of regular files that are published
 ;;     as-is isn't saved (but is included in the surrounding
 ;;     .gnd)
+;;
+;; The format used here is a SXML tree, as that seems most
+;; simple to use with Guix' @code{write-file-tree}.
 
 (library (gnu gnunet scripts publish-store)
+  ;; XXX check exports
   (export main
          store-item->sxml
          directory->sxmls
          publish-object
-         publish-sxml->json
          gnunet-publish)
   (import (rnrs base)
          (rnrs io simple)
+         (ice-9 optargs)
          (ice-9 getopt-long)
          (gnu gnunet scripts guix-stuff)
          (only (ice-9 ftw) scandir)
@@ -55,7 +60,6 @@
          (ice-9 regex)
          (ice-9 popen)
          (ice-9 rdelim)
-         (json)
          (sxml match)
          (only (ice-9 optargs)
                define*))
@@ -65,12 +69,13 @@
        (help     (single-char #\h))
        (format   (single-char #\f)
                  (value #t)
-                 (predicate ,(cute member <> '("gnunet-nix-archive-json/0"))))
+                 (predicate ,(cute member <> '("gnunet-nar-sxml/0"))))
        (input    (single-char #\i)
                  (value #t))
+       (nar      (value #t))
        (simulate (single-char #\s))
        ;; Debugging options
-       (display-json)
+       (display-sxml)
        ;; GNUnet options
        (config      (single-char #\c)
                     (value #t))
@@ -83,7 +88,7 @@
                     (value #t))))
 
     (define *simulate* (make-parameter #f))
-    (define *display-json* (make-parameter #f))
+    (define *display-sxml* (make-parameter #f))
     (define *config*
       (make-parameter (string-append (getenv "HOME")
                                     "/.config/gnunet.conf")))
@@ -102,7 +107,7 @@ the options @var{options} are applied."
              (string->number value/str)
              default)))
       (parameterize ((*simulate* (opt 'simulate (*simulate*)))
-                    (*display-json* (opt 'display-json (*display-json*)))
+                    (*display-sxml* (opt 'display-sxml (*display-sxml*)))
                     (*config* (opt 'config (*config*)))
                     (*anonymity* (num 'anonymity (*anonymity*)))
                     (*priority* (num 'priority (*priority*)))
@@ -119,11 +124,12 @@ Publish a (GNU Guix, or Nix) store item INPUT into GNUnet.
   -s, --simulate   Do not actually publish INPUT, only print the
                    computed URI
   -f, --format     Format for representing a store item,
-                   currently gnunet-nix-archive-json/0
+                   currently gnunet-nar-sxml/0
   -i, --input      Store item to publish
+      --nar        Publish a nar instead
 
 Debugging options
-      --display-json  Display generated JSON to stdout
+      --display-sxml  Display generated SXML to stdout
 
 GNUnet options
   -c, --config       GNUnet configuration for publishing
@@ -145,23 +151,25 @@ GNUnet options
              ((option-ref options 'help #f)
               (display %help (current-output-port))
               (newline (current-output-port)))
-             ((equal? (option-ref options 'format "gnunet-nix-archive-json/0")
-                      "gnunet-nix-archive-json/0")
+             ((equal? (option-ref options 'format "gnunet-nar-sxml/0")
+                      "gnunet-nar-sxml/0")
               (let ((result
                      (call-with-options
-                      options (cute publish-nar
-                                #:input (option-ref options 'input #f)))))
+                      options
+                      (lambda ()
+                        (publish-nar/sxml/1
+                         #:input (option-ref options 'input #f))))))
                 (format (current-output-port)
                         "Published at ~a in ~a format~%"
-                        result "gnunet-nix-archive-json/0")))
+                        result "gnunet-nar-sxml/0")))
              (else ???))))
 
-    (define* (publish-nar #:key input)
+    (define* (publish-nar/sxml/1 #:key input)
       (let* ((sxml (store-item->sxml input))
-            (json (publish-sxml->json sxml)))
-       (when (*display-json*)
-         (display (current-output-port) json))
-       (publish-object (string->utf8 json))))
+            (sxml/hashed (sxml-publish-leaves! sxml #:include-name? #f)))
+       (when (*display-sxml*)
+         (write (current-output-port) sxml/hashed))
+       (publish-object (string->utf8 (object->string sxml/hashed)))))
 
     (define gnunet-publish-uri-regexp
       (make-regexp "\\b(gnunet://fs/chk/([A-Z0-9]+).([A-Z0-9]+).[0-9]+)\\b"))
@@ -204,44 +212,31 @@ as a string."
          (throw 'gnunet-publish-eep 'gnunet-publish-???))
        (extract-uri text-1)))
 
-    (define (publish-sxml->json sxml)
+    (define* (sxml-publish-leaves! sxml #:key (include-name? #t))
       "Publish SXML, an SXML as returned by store-item->sxml,
-and return a JSON string representing it, with individual files
-referred to by their hash."
-      (define (path-append left right)
-       (cond ((or (string=? left "") (string=? left "/"))
-              right)
-             (else (string-append left "/" right))))
-      (define (flatten-sxml prefix sxml)
-       (sxml-match sxml
-                   ((regular (@ (name ,name)
-                                (executable? ,executable?)
-                                (data-from-file ,filename)))
-                    `(((name . ,(path-append prefix name))
-                       (type . ,(if executable?
-                                      "executable"
-                                      "regular"))
-                       (hash . ,(publish-object filename)))))
-                   ((symlink (@ (name ,name)
-                                (target ,target)))
-                    `(((name . ,(path-append prefix name))
-                       (type . "symlink")
-                       (target . ,target))))
-                   ((directory (@ (name ,name))
-                               . ,rest)
-                    `(((name . ,(path-append prefix name))
-                       (type . "directory"))
-                      . ,(concatenate
-                          (map (let ((prefix (path-append prefix name)))
-                                 (lambda (e)
-                                   (flatten-sxml prefix e)))
-                               rest))))))
-      (let* ((flattened (flatten-sxml "" sxml))
-            (flattened/vector (list->vector flattened))
-            (wrapped `((version . "gnunet-nix-archive-json/0")
-                       (entries . ,flattened/vector)))
-            (wrapped/string (scm->json-string wrapped)))
-       wrapped/string))
+and return a SXML where the on-disk filenames are replaced
+by the corresponding GNUnet URIs.  If INCLUDE-NAME? is false,
+the name of the top-level entry is not included in the returned
+SXML."
+      (define (maybe-name name)
+       (if include-name?
+           `((name ,name))
+           '()))
+      (sxml-match sxml
+                 ((regular (@ (name ,name)
+                              (executable? ,executable?)
+                              (data-from-file ,filename)))
+                  `(regular (@ ,@(maybe-name name)
+                               (executable? ,executable?)
+                               (hash ,(publish-object filename)))))
+                 ((symlink (@ (name ,name)
+                              (target ,target)))
+                  `(symlink (@ ,@(maybe-name name)
+                               (target ,target))))
+                 ((directory (@ (name ,name))
+                             . ,rest)
+                  `(directory (@ ,@(maybe-name name))
+                              . ,(map sxml-publish-leaves! rest)))))
 
     (define (publish-object data)
       "Publish DATA, a bytevector or filename, and return

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