path: root/gnu/gnunet/scripts/download-store.scm

;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2021 GNUnet e.V.
;;
;;   GNUnet is free software: you can redistribute it and/or modify it
;;   under the terms of the GNU Affero General Public License as published
;;   by the Free Software Foundation, either version 3 of the License,
;;   or (at your option) any later version.
;;
;;   GNUnet is distributed in the hope that it will be useful, but
;;   WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   Affero General Public License for more details.
;;
;;   You should have received a copy of the GNU Affero General Public License
;;   along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;;   SPDX-License-Identifier: AGPL-3.0-or-later

;; TODO: parallel downloads
(library (gnu gnunet scripts download-store)
  (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)
	  (ice-9 match)
	  (only (rnrs control) when unless)
	  (only (rnrs programs) exit)
	  (only (guile)
		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
		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))
  (begin
    (define %supported-formats
      '("gnunet-nar-sxml/0"))

    (define (gnunet-fs-uri? str)
      (or (string-prefix? "gnunet://fs/chk" str)
	  (string-prefix? "gnunet://fs/loc" str)))

    ;; TODO fit in a progress bar
    (define %options-specification
      `((version (single-char #\v))
	(help    (single-char #\h))
	(format  (single-char #\f)
		 (value #t)
		 (predicate ,(cute member <> %supported-formats)))
	(input   (single-char #\i)
		 (value #t)
		 (predicate ,gnunet-fs-uri?))
	(output  (single-char #\o)
		 (value #t))
	(nar     (value #t))
	;; GNUnet options
	(config      (single-char #\c)
		     (value #t))
	(anonymity   (single-char #\a)
		     (value #t))
	(no-network  (single-char #\n))
	(parallelism (single-char #\p)
		     (value #t))
	(request-parallelism
	 (single-char #\r)
	 (value #t))))

    (define *config*
      (make-parameter
       (string-append (getenv "HOME") "/.config/gnunet.conf")))
    (define *anonymity* (make-parameter 1))
    (define *no-network* (make-parameter #f))
    (define *parallelism* (make-parameter #f))
    (define *request-parallelism* (make-parameter #f))

    (define (call-with-options options thunk)
      "Call the thunk @var{thunk} in an environment where
the options @var{options} are applied."
      (define opt (cute option-ref options <> <>))
      (define (num sym default)
	(let ((value/str (opt sym #f)))
	  (if value/str
	      (string->number value/str)
	      default)))
      (parameterize ((*config* (opt 'config (*config*)))
		     (*anonymity* (num 'anonymity (*anonymity*)))
		     (*no-network* (opt 'no-network (*no-network*)))
		     (*parallelism* (num 'parallelism (*parallelism*)))
		     (*request-parallelism* (num 'request-parallelism
						 (*request-parallelism*))))
	(thunk)))

    (define %version-string
      "scheme-gnunet download-store v0.0")

    (define %help
      "Usage: download-store [OPTIONS] -i URI -o FILENAME
Download store items from GNUnet using a GNUnet CHK or LOC URI
(gnunet://fs/chk/...).

The result may contain symbolic links and executables, beware!
The umask probably should include readability, writability
and executability.
Download resumption is currently unsupported.

  -v, --version    Print version information
  -h, --help       Print this message
  -f, --format     Representation of store items to use,
                   'any' by default.
  -i, --input      URI to download
  -o, --output     Filename to save store item at.
      --nar        Location to write the nar to.

GNUnet options
  -c, --config      GNUnet configuration for publishing
  -a, --anonymity   Anonymity level for downloading
  -n, --no-network  Do not contact the network, only the
                    local peer.")

    (define (main arguments)
      (let ((options (getopt-long arguments %options-specification)))
	(call-with-options options (cute inner-main options)))
      (exit 0))

    (define (inner-main options)
      (cond ((option-ref options 'version #f)
	     (display %version-string)
	     (newline))
	    ((option-ref options 'help #f)
	     (display %help)
	     (newline))
	    ((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
		(option-ref options 'input #f)
		(option-ref options 'output #f)))
	     (when (option-ref options 'nar #f)
	       (download:gnunet-nar/0-to-nar
		(option-ref options 'input #f)
		(option-ref options 'nar #f))))
	    (else ???)))

    (define (gnunet-download uri output-filename)
      "Download URI to the file OUTPUT, which is
created if needed, as a single file."
      (unless (or (string-prefix? "gnunet://fs/chk/" uri)
		  (string-prefix? "gnunet://fs/loc/" uri))
	(throw 'xxx-invalid-uri uri))
      (when (string-any #\nul uri)
	(throw 'xxx-invalid-uri uri))
      (let* ((*binary* "gnunet-download")
	     (cmd `(,*binary*
		    ,@(if (*config*)
			  `("-c" ,(*config*))
			  '())
		    ,@(if (*no-network*)
			  '("-n")
			  '())
		    "-a" ,(number->string (*anonymity*))
		    "-o" ,output-filename
		    ,uri))
	     (result (apply system* cmd)))
	(unless (= (status:exit-val result) 0)
	  ;; XXX proper error message
	  (throw 'gnunet-download-eep 'gnunet-download-???))
	(values)))

    (define (gnunet-download/bytevector uri)
      "Like gnunet-download, but return a bytevector
instead of writing to a file."
      (call-with-temporary-output-file
       (lambda (filename out)
	 (gnunet-download uri filename)
	 (get-bytevector-all out))))

    (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))
	     ;; 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* (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}."
      (define (file-type+size 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.
	  (gnunet-download hash (port-filename 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)
      (when executable?
	(chmod output
	       (logior (stat:mode (stat output))
		       (logand #o111 (lognot (umask)))))))

    (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 (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 (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 (@ (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 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)))))))

    ;; 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))))