maximed
/
scheme-gnunet


			
				
					
						
						
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280
							;; This file is part of scheme-GNUnet.
;; Copyright © 2021, 2022 GNUnet e.V.
;;
;; scheme-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.
;;
;; scheme-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

;; Go to localhost:8089/reload to reload the module
(define-module (guile-user)
  #:declarative? #f)

(use-modules (fibers)
	     (fibers conditions)
	     (rnrs bytevectors)
	     (gnu extractor enum)
	     (gnu gnunet block)
	     (gnu gnunet crypto)
	     (gnu gnunet utils bv-slice)
	     (gnu gnunet config db)
	     (gnu gnunet config fs)
	     (rnrs hashtables)
	     ((gnu gnunet nse client)
	      #:prefix #{nse:}#)
	     ((gnu gnunet dht client)
	      #:prefix #{dht:}#)
	     (web response)
	     (web server)
	     (web uri)
	     (web request)
	     (web form)
	     (srfi srfi-11)
	     (ice-9 match)
	     (sxml simple))

(define config (load-configuration))

(define* (respond/html body #:key (status-code 200))
  "@var{status-code}: the HTTP status code to return. By default, the status code
for success is used."
  (values (build-response
	   #:code status-code
	   #:headers `((content-type application/xhtml+xml) (charset . "utf-8")))
	  (lambda (port)
	    (display "<!DOCTYPE html>\n" port)
	    (sxml->xml `(html (@ (xmlns "http://www.w3.org/1999/xhtml"))
			      (head (title "Hello"))
			      (body ,body))
		       port))))

;; TODO: make the form work, defaults, ...

(define (data-encoding-input name id)
  `(select
    (@ (name ,name) (id ,id))
    (option (@ (value "utf-8-text")) "free-form text encoded as UTF-8")
    (option (@ (value "hexadecimal")) "binary data encoded in hexadecimal")))

(define (common-get/put-form-parts %prefix)
  (define (prefix id) ; ids must be unique within a document
    (string-append %prefix id))
  `((li (label (@ (for "type")) "Type: ")
	    (input (@ (type "number") (id "type") (name "type"))))
    (li (label (@ (for "replication-level")) "Replication level: ")
	(input (@ (type "number") (id ,(prefix "replication-level"))
		  (name "replication-level"))))
    (li (label (@ (for "key-encoding")) "Key encoding: ")
	,(data-encoding-input "key-encoding" (prefix "key-encoding")))
    (li (label (@ (for "key")) "Key: ")
	(input (@ (type "text") (id ,(prefix "key")) (name "key"))))))

(define search-form
  `(form
    (@ (action "/search-dht") (method "post")) ; TODO should be "get"
    (ul ,@(common-get/put-form-parts "get-"))
    (input (@ (type "submit") (value "Search the DHT")))))

;; TODO: make the form work, defaults, ...
(define put-form
  `(form
    (@ (action "/put-dht") (method "post"))
    (ul ,@(common-get/put-form-parts "put-")
	(li (label (@ (for "put-data-encoding")) "Encoding of data: ")
	    ,(data-encoding-input "data-encoding" "put-data-encoding"))
	(li (label (@ (for "put-data")) "Data to insert: ")
	    (input (@ (type "text") (id "put-data") (name "data")))))
    (input (@ (type "submit") (value "Put it into the DHT")))))

(define cadet-start-chat-form
  `(form
    (@ (action "/start-cadet-chat") (method "post"))
    (ul (li (label (@ (for "cadet-start-peer"))
		   "Identity of remote peer to connect to")
	    (input (@ (type "text") (id "cadet-start-peer") (name "peer"))))
	(li (label (@ (for "cadet-port-name"))
		   "Name of the port to connect to (as a string)")
	    (input (@ (type "text") (id "cadet-port-name") (name "port")))))
    (input (@ (type "submit") (value "Connect!")))))

(define (cadet-chat-forms)
  `(p "TODO!"))

(define (estimate->html estimate)
  `(dl (dt "Timestamp")
       (dd ,(number->string (nse:estimate:timestamp estimate)))
       (dt "Number of peers")
       (dd ,(number->string (nse:estimate:number-peers estimate)))
       (dt "Standard deviation")
       (dd ,(number->string (nse:estimate:standard-deviation estimate)))))

(define (decode/key encoding data)
  (match encoding
    ("utf-8-text"
     (hash/sha512 (bv-slice/read-write (string->utf8 data))))
    ;; TODO other encodings
    ))

(define (decode/data encoding data)
  (match encoding
    ("utf-8-text"
     (bv-slice/read-write (string->utf8 data))
     ;; TODO other encodings
     )))

(define (process-put-dht dht-server parameters)
  ;; TODO replication level, expiration ...
  (dht:put! dht-server
	    (dht:datum->insertion
	     (dht:make-datum
	      (string->number (assoc-ref parameters "type"))
	      (decode/key (assoc-ref parameters "key-encoding")
			  ;; TODO the key is 00000.... according to gnunet-dht-monitor
			  (assoc-ref parameters "key"))
	      (decode/data (assoc-ref parameters "data-encoding")
			   (assoc-ref parameters "data"))))))

(define (try-utf8->string bv) ; TODO: less duplication
  (catch 'decoding-error
    (lambda () (utf8->string bv))
    (lambda _ #false)))

(define (data->string slice)
  (define bv (make-bytevector (slice-length slice)))
  (slice-copy! slice (bv-slice/read-write bv))
  (define as-string (try-utf8->string bv))
  (or as-string (object->string bv)))

(define (parameters->query parameters)
  "Perform rudimentary validation on the paramaters @var{parameters}
for a /search-dht form. If correct, return an appropriate query object.
If incorrect, return @code{#false}. TODO more validation."
  (let* ((type (and=> (assoc-ref parameters "type") string->number))
	 (key-encoding (assoc-ref parameters "key-encoding"))
	 (key (assoc-ref parameters "key"))
	 (replication-level (assoc-ref parameters "key"))
	 (desired-replication-level
	  (and=> (assoc-ref parameters "replication-level") string->number)))
    (and type key-encoding key replication-level desired-replication-level
	 (dht:make-query type
			 (decode/key key-encoding key)
			 #:desired-replication-level
			 desired-replication-level))))

(define (process-search-dht dht-server parameters)
  (define search-result)
  (define found? (make-condition))
  (define (found %search-result)
    ;; TODO: document necessity of copies and this procedure
    (set! search-result (dht:copy-search-result %search-result))
    (unless (signal-condition! found?)
      (pk "already signalled, is cancelling working correctly, or was this \
merely a race?")))
  (define query (parameters->query parameters))
  (if query
      (let ((search-handle (dht:start-get! dht-server query found)))
	(wait found?)
	;; For this example application, a single response is sufficient.
	;; TODO: cancel from within 'found' (probably buggy)
	(dht:stop-get! search-handle)
	;; TODO: properly format the result, streaming, stop searching
	;; after something has been found or if the client closes the connection ...
	(respond/html `(div (p "Found! ")
			    ;; TODO: better output, determine why the data is bogus
			    (dl (dt "Type: ")
				(dd ,(dht:datum-type
				      (dht:search-result->datum search-result)))
				(dt "Key: ")
				(dd ,(data->string
				      (dht:datum-key
				       (dht:search-result->datum search-result))))
				(dt "Value: ")
				(dd ,(data->string
				      (dht:datum-value
				       (dht:search-result->datum search-result))))
				(dt "Expiration: ")
				(dd ,(object->string
				      (dht:datum-expiration
				       (dht:search-result->datum search-result))))
				(dt "Get path: ") ; TODO as list
				(dd ,(dht:search-result-get-path search-result))
				(dt "Put path: ")
				(dd ,(dht:search-result-put-path search-result))))))
      (respond/html `(p "Some fields were missing / invalid")
		    #:status-code 400)))

(define-once started? #f)

(define (slice-copy slice) ; TODO: move to (gnu gnunet utils bv-slice), use elsewhere?
  (define s (make-slice/read-write (slice-length slice)))
  (slice-copy! slice s)
  s)

(define (url-handler dht-server nse-server cadet-server request body)
  (match (uri-path (request-uri request))
    ("/" (respond/html
	  `(div (p "A few links")
		(ul (li (a (@ (href "/network-size")) "network size"))
		    (li (a (@ (href "/cadet-chat")) "basic chatting via CADET"))
		    (li (a (@ (href "/search-dht")) "search the DHT")
			(li (a (@ (href "/put-dht")) "add things to the DHT")))))))
    ("/reload" ; TODO form with PUT request?
     (reload-module (current-module))
     (respond/html "reloaded!"))
    ("/network-size"
     (respond/html
      (let ((current-estimate (nse:estimate nse-server)))
	(if current-estimate
	    (estimate->html current-estimate)
	    '(p "No etimate yet")))))
    ("/cadet-chat"
     (respond/html `(div (p "You can only connect to a chat here, not start new ones")
			 (p "Run gnunet-cadet --open-port=PORT to run a new chat!")
			 (p "Connect to a chat!")
			 ,cadet-start-chat-form
			 (p "participate in a chat!")
			 ,@(cadet-chat-forms))))
    ("/search-dht" ; TODO check method and Content-Type, validation ...
     (if (pk 'b body)
	 (process-search-dht dht-server (urlencoded->alist body))
	 (respond/html search-form)))
    ("/put-dht" ; TODO check method and Content-Type, validation ...
     (if body
	 (begin
	   (process-put-dht dht-server (urlencoded->alist body))
	   (respond/html '(p "Success!")))
	 (respond/html put-form)))
    (_ (respond/html '(p "not found"))))) ; TODO 404

(define (start config)
  (define nse-server (nse:connect config))
  (define dht-server (dht:connect config))
  (define cadet-server (dht:connect config))
  (define impl (lookup-server-impl 'fiberized))
  (define server (open-server impl `(#:port 8089)))
  (define (url-handler* request body)
    (url-handler dht-server nse-server cadet-server request body))
  (let loop ()
    (let-values (((client request body)
		  (read-client impl server)))
      (spawn-fiber
       (lambda ()
	 (let-values (((response body state)
		       (handle-request url-handler* request body '())))
	   (write-client impl server client response body)))))
    (loop)))

(when (not started?)
  (set! started? #t)
  (run-fibers (lambda () (start config))))