[gnunet-scheme] 50/324: scripts: download-store: (partially) validate entries

[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 36870dba187cfbbb2bd82fb059186417db980a9d
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon Jan 25 14:46:29 2021 +0100

    scripts: download-store: (partially) validate entries
    
    TODO #\0 bytes should be rejected (maybe some other bytes
    as well).
    
    * gnu/gnunet/scripts/download-store.scm
      (%help): remember that *multiple* store items can be included.
      (%download-nar): use verify-entries, and use 'download-entries!'
      once it is defined.
      (sort-entries): define procedure for sorting entries
      into a reasonable creation order, that can also be used
      for detecting various errors with 'verify-entries' efficiently.
      (vector->stream): define helper procedure.
      (store-name?): define stub.
      (verify-entries): define procedure.
---
 gnu/gnunet/scripts/download-store.scm | 111 +++++++++++++++++++++++++++++++---
 1 file changed, 102 insertions(+), 9 deletions(-)

diff --git a/gnu/gnunet/scripts/download-store.scm 
b/gnu/gnunet/scripts/download-store.scm
index 093ef58..55359a3 100644
--- a/gnu/gnunet/scripts/download-store.scm
+++ b/gnu/gnunet/scripts/download-store.scm
@@ -29,9 +29,15 @@
          (only (rnrs control) unless)
          (only (rnrs programs) exit)
          (only (guile)
-               string-prefix? system* status:exit-val)
-         (json)          (srfi srfi-1)
-         (srfi srfi-26))
+               string-prefix? system* status:exit-val
+               string-split sort negate compose
+               dirname
+               throw)
+         (json)
+         (srfi srfi-1)
+         (srfi srfi-1)
+         (srfi srfi-26)
+         (srfi srfi-41))
   (begin
     (define %supported-formats
       '("any" "gnunet-nix-archive-json/0"))
@@ -68,8 +74,8 @@
       "scheme-gnunet download-store v0.0")
 
     (define %help
-      "Usage: download-store [OPTIONS] -i URI -o FILENAME
-Download a store item from GNUnet using a GNUnet CHK or LOC URI
+      "Usage: download-store [OPTIONS] -i URI -o DIRECTORY
+Download store items from GNUnet using a GNUnet CHK or LOC URI
 (gnunet://fs/chk/...).
 
 The result may contain symbolic links and executables, beware!
@@ -80,7 +86,7 @@ Download resumption is currently unsupported.
   -f, --format     Representation of store items to use,
                    'any' by default.
   -i, --input      URI to download
-  -o, --output     Location to save store item at.
+  -o, --output     Directory to save store items in.
 
 GNUnet options
   -c, --config      GNUnet configuration for publishing
@@ -150,6 +156,93 @@ instead of writing to a file."
       (let* ((container/bv (apply gnunet-download/bytevector uri r))
             (container/json (utf8->string container/bv))
             (container/scm (json-string->scm container/json)))
-       (display container/scm)
-       (display 'do-stuff-please)
-       ???))))
+       (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))))
+
+    (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 (vector->stream s)
+      (stream-map (cute vector-ref s <>)
+                 (stream-take (vector-length s)
+                              (stream-from 0))))
+
+    (define (store-name? x)
+      'xxx 'todo 'for-example-no-nul-bytes
+      #t)
+
+    (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))))

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