[gnunet-scheme] 35/324: scripts: publish-store: compute file tree

[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 e147c28f1f133d273e5f93895251cc56e9220c7e
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sat Jan 23 11:40:18 2021 +0100

    scripts: publish-store: compute file tree
    
    This tree now has to be indexed, hashed, ....
    
    * gnu/gnunet/scripts/publish-store.scm
      (main): fix order of arguments of 'display',
      and fix usage of option-ref
      (store-item->sxml, directory->sxmls): new procedure
      (add-name): helper procedure for adding file name to sxml
---
 gnu/gnunet/scripts/publish-store.scm | 68 +++++++++++++++++++++++++++++++-----
 1 file changed, 60 insertions(+), 8 deletions(-)

diff --git a/gnu/gnunet/scripts/publish-store.scm 
b/gnu/gnunet/scripts/publish-store.scm
index b187804..fff8b88 100644
--- a/gnu/gnunet/scripts/publish-store.scm
+++ b/gnu/gnunet/scripts/publish-store.scm
@@ -22,6 +22,15 @@
   (import (rnrs base)
          (rnrs io simple)
          (ice-9 getopt-long)
+         (only (ice-9 ftw) scandir)
+         (only (srfi srfi-1) member)
+         (only (guile)
+               logand
+               lstat
+               stat:type
+               stat:perms
+               stat:size)
+         (sxml match)
          (only (ice-9 optargs)
                define*))
   (begin
@@ -57,17 +66,60 @@ GNUnet options
     (define (main arguments)
       (let ((options (getopt-long arguments %options-specification)))
        (cond ((option-ref options 'version #f)
-              (display (current-output-port)
-                       "scheme-gnunet publish-store v0.0")
+              (display "scheme-gnunet publish-store v0.0"
+                       (current-output-port))
               (newline (current-output-port)))
-             ((option-ref options '--help #f)
-              (display (current-output-port) %help)
+             ((option-ref options 'help #f)
+              (display %help (current-output-port))
               (newline (current-output-port)))
              ((equal? (option-ref options '--format "gnunet-nar") "gnunet-nar")
-              (publish-nar #:input (option-ref options '--input #f)
-                           #:simulate (option-ref options '--simulate #f)
-                           #:config (option-ref options '--config #f)))
+              (publish-nar #:input (option-ref options 'input #f)
+                           #:simulate (option-ref options 'simulate #f)
+                           #:config (option-ref options 'config #f)))
              (else ???))))
 
     (define* (publish-nar #:key input simulate config)
-      ???)))
+      ;; FIXME use this
+      (display (store-item->sxml input))
+      (newline)
+      ???)
+
+    (define (store-item->sxml filename)
+      (let* ((stat  (lstat filename))
+            (type  (stat:type stat))
+            (perms (stat:perms stat))
+            (executable?
+             (= (logand perms #o0001)
+                #o0001)))
+       (case (stat:type stat)
+         ((regular)
+          `(regular (@ (size ,(stat:size stat))
+                       (executable? ,executable?)
+                       (data-from-file ,filename))))
+         ((directory)
+          `(directory ,@(directory->sxmls filename)))
+         ((symlink)
+          `(symlink (@ (target ,(readlink filename)))))
+         (else ???))))
+
+    ;; FIXME I can't use sxml-match properly
+    (define (add-name sxml name)
+      (cons (car sxml)
+           (if (and (pair? (cdr sxml))
+                    (eq? (caadr sxml) '@))
+               `((@ (name ,name) . ,(cdadr sxml))
+                 . ,(cddr sxml))
+               `((@ (name ,name))
+                 . ,(cdr sxml)))))
+
+    (define (directory->sxmls filename)
+      (let ((names (scandir filename
+                           (lambda (n)
+                             (not (member n '("." ".."))))
+                           string<?)))
+       (map (lambda (name)
+              (add-name (store-item->sxml (string-append filename
+                                                         "/"
+                                                         name))
+                        name))
+            names)))))

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