;; Copyright (C) 2022, Matt Welland
;;   All rights reserved.
;; 
;;   Redistribution and use in source and binary forms, with or without
;;   modification, are permitted provided that the following conditions are met:
;; 
;;   Redistributions of source code must retain the above copyright notice, this
;;   list of conditions and the following disclaimer.
;;   Redistributions in binary form must reproduce the above copyright notice,
;;   this list of conditions and the following disclaimer in the documentation
;;   and/or other materials provided with the distribution.
;;   Neither the name of the author nor the names of its contributors may be
;;   used to endorse or promote products derived from this software without
;;   specific prior written permission.
;; 
;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;;   AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;   IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;   ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
;;   LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;   CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;   SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;   INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;   CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;   ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;   POSSIBILITY OF SUCH DAMAGE.


(module fcp

(insert-file
 gen-ssk
 retrieve-file)

(import scheme
	(chicken io)
	(chicken tcp)
	(chicken base)
	(chicken file)
	(chicken string)
	(chicken port)
	(chicken pretty-print)
	(chicken process-context posix)
	(chicken time)
	srfi-1
	srfi-18
	srfi-69
	base64
	regex
	matchable
	)
  
(define port (make-parameter 9481))
(define host (make-parameter "localhost")) ;; 127.0.0.1"))
(define verbosity (make-parameter 0))

(define (doprint . params)
  (if (> (verbosity) 0)
      (with-output-to-port (current-error-port)
	(lambda ()(apply print params)))))

;; send conc of str with \r\n
;;
(define (send-and-print p . str)
  (let* ((basestr (apply conc str))
	 (fullstr (conc basestr "\r\n")))
    (display fullstr p)
    (doprint "Sending: \""basestr"\"")))

(define *vars* (make-hash-table))
(define (save-vars dats)
  (map (lambda (dat)
	 (hash-table-set! *vars* (car dat)(cdr dat)))
       dats))

;; wait until val (a regex) matches an item in the input queue
;; then clear the queue
;;
(define (input-wait i val)
  (doprint "Waiting for: "val)
  (let loop ()
    (let ((inl (read-line i)))
      (if (string-match val inl)
	  (doprint "Got: "inl)
	  (begin
	    (doprint "Received: "inl)
	    (loop))
	  ))))

(define (addr->baseaddress addr)
  (match (string-match "^(\\S+)\\s+(\\S+)\\s+<(.*)>$" addr)
    ((_ firstname lastname baseaddress)
     baseaddress)
    (else
     addr)))

;; get the next message and return an alist of vars
;; with _msgtype_ set to the message type
;;
(define (get-next-message i)
  (let loop ((res    '())
	     (msgtype #f))
    (let* ((inl (read-line i)))
      (doprint "Recv: "inl)
      (if (not (eof-object? inl))
	  (if (not msgtype) ;; first line must be the type
	      (if (string-match ".*=.*" inl) ;; should never have an = in a message type
		  (begin
		    (print "ERROR: expecting message type but got \""inl"\"")
		    (loop res msgtype))
		  (loop (cons `(_msgtype_ . ,inl) res) inl))
	      (match (string-match "^([^=]+)=(.*)$" inl)
		((_ var val)(loop (cons `(,(string->symbol var) . ,val) res) msgtype))
		(else
		 (if (equal? inl "EndMessage")
		     res
		     (begin
		       (print "ERROR: expecting either var=val or EndMessage but got \""inl"\"")
		       (loop res msgtype))))))
	  res))))
		   

(define (send-var o var val)
  (send-and-print o (conc var"="val)))

;; Hello

(define (client-send-hello o idstr)
  (send-and-print o "ClientHello")
  (send-var o "Name" idstr)
  (send-var o "ExpectedVersion" "2.0")
  (send-and-print o "EndMessage"))

(define (wait-for-node-hello i)
  (let* ((dat (get-next-message i))
	 (mtp (alist-ref '_msgtype_ dat)))
    (if (equal? mtp "NodeHello")
	(begin
	  (save-vars dat)
	  #t)
	(begin
	  (print "ERROR: Expected NodeHello message but got "mtp)
	  #f))))

(define (send-watch-global o)
  (send-and-print o "WatchGlobal")
  (send-var o "Enabled" "true")
  (send-var o "VerbosityMask" "1")
  (send-and-print o "EndMessage"))

(define (test-dda i o directory)
  (send-and-print o "TestDDARequest")
  (send-var o "Directory" directory)
  (send-var o "WantReadDirectory" "true")
  (send-var o "WantWriteDirectory" "true")
  (send-and-print o "EndMessage")
  (thread-sleep! 1) ;; is there a deterministic way?
  (let loop ()
    (if (char-ready? i)
	(let* ((dats (get-next-message i))
	       (content (alist-ref 'ContentToWrite dats))
	       (writefn (alist-ref 'WriteFilename dats))
	       (readfn  (alist-ref 'ReadFilename dats)))
	  (if (not (and dats content writefn readfn))
	      (begin
		(print "Got "dats" but missing content, writefn or readfn.")
		(loop))
	      (let* ((resdat  (with-input-from-file readfn
				read-line)))
		(with-output-to-file writefn
		  (lambda ()
		    (print content)))
		(send-and-print o "TestDDAResponse")
		(send-var o "Directory" directory)
		(send-var o "ReadContent" resdat)
		(send-and-print o "EndMessage"))))
	(begin
	  (thread-sleep! 5)
	  (loop))))
  (get-next-message i) ;; should be the TestDDAComplete
  )

(define (with-connection key proc)
  (let-values (((i o)(tcp-connect (host) (port))))
    ;; idea was to do the hello here, however it didn't work.
    (client-send-hello o key) ;; dunno why this didn't seem to work
    (wait-for-node-hello i)   ;; same calls still needed when with-connection used
    (let* ((result (proc i o)))
      (close-input-port i)
      (close-output-port o)
      result)))

;; Progress: retrieved 0 out of 1 and 1 (false)
;; Recv: CompatibilityMode
;; Recv: Min=COMPAT_UNKNOWN
;; Recv: Identifier=MTY3MTQxNDAzNS0vdG1wLXRlbi1oYWJpdHMtcmVjZWl2ZWQtdHJ5NC5wZGYx
;; Recv: Max=COMPAT_UNKNOWN
;; Recv: Definitive=false
;; Recv: Global=true
;; Recv: DontCompress=true
;; Recv: Min.Number=0
;; Recv: Max.Number=0
;; Recv: EndMessage

(define (retrieve-file uri directory fname)
  (let ((key (make-key (current-seconds) directory fname))
	(fullname (conc directory"/"fname)))
    (with-connection
     key
     (lambda (i o)
       (test-dda i o directory)
       (send-and-print o "ClientGet")
       (send-var o "IgnoreDS" "false")
       (send-var o "DSOnly" "false")
       (send-var o "URI" uri)
       (send-var o "Identifier" key)
       (send-var o "Verbosity" "0")
       (send-var o "ReturnType" "disk")
       ;; (send-var o "MaxSize" "100")
       ;; (send-var o "MaxTempSize" "1000")
       (send-var o "MaxRetries" "100")
       (send-var o "PriorityClass" "1")
       (send-var o "Persistence" "reboot")
       (send-var o "ClientToken" "hello")
       (send-var o "Global" "true")
       (send-var o "BinaryBlob" "false")
       ;; (send-var o "FilterData" "true")
       (send-var o "Filename" fullname)
       (send-and-print o "EndMessage")
       (send-watch-global o)
       (let loop ()
	 (let* ((msg (if (char-ready? i)
			 (get-next-message i)
			 #f))
		(msgforus (and msg
			      (equal? (alist-ref 'Identifier msg) key))))
	   (if msgforus
	       (begin
		 ;; (pp msg)
		 (if (alist-ref 'Succeeded msg)
		     (doprint "Progress: "
			    "retrieved "(alist-ref 'Succeeded msg)
			    " out of "(alist-ref 'Required msg)
			    " and "(alist-ref 'Total msg)" ("(or (alist-ref 'FinalizedTotal msg) "")")"))
		 (if (and (equal? (alist-ref 'FinalizedTotal msg) "true")
			  (file-exists? fullname))
		     #t
		     (if (and (equal? (alist-ref 'Min msg) "COMPAT_UNKNOWN")
			      (equal? (alist-ref 'Max msg) "COMPAT_UNKNOWN"))
			 (begin
			   (print "Failed to find "uri)
			   #f)
			 (begin
			   (thread-sleep! 1)
			   (loop)))))
	       (begin
		 (thread-sleep! 1)
		 (loop)))))
       ))))
 
;; address format "First Last <first_last@something.freenet>"
;;
(define (insert-file directory fname #!optional (uri #f))
  (let ((key (make-key (current-seconds) directory fname)))
    (with-connection
     key
     (lambda (i o)
       ;; first send the DDA request
       (test-dda i o directory)
       
       (send-and-print o "ClientPut")
       (send-var o "URI" (or uri "CHK@"))
       (send-var o "UploadFrom" "disk")
       (send-var o "Filename" (conc directory"/"fname))
       (send-var o "Identifier" key)
       ;; (send-var o "ClientToken" This is the debian sarge dvd number 1
       (send-var o "Global" "true") ;; it'd be nice if send-var took #t and #f
       (send-and-print o "EndMessage")
       
       (send-watch-global o)
       (let loop  ()
	 (if (char-ready? i)
	     (let* ((dats (get-next-message i))
		    (mtp  (alist-ref '_msgtype_ dats)))
	       (doprint "GOT: "dats)
	       (if (equal? mtp "URIGenerated")
		   (alist-ref 'URI dats)
		   (loop)))
	     (begin
	       (display ".")
	       (flush-output)
	       (thread-sleep! 5)
	       (loop))))))))

;; (insert-file "/home/matt" ".bashrc")
;; address format "First Last <first_last@something.freenet>"
;;
(define (gen-ssk)
  (let* ((key (make-key (current-seconds) (current-process-id))))
    (with-connection
     key
     (lambda (i o)
       (send-and-print o "GenerateSSK")
       (send-var o "Identifier" key)
       (send-and-print o "EndMessage")
       ;; SSKKeypair
       ;; InsertURI=freenet:SSK@AKTTKG6YwjrHzWo67laRcoPqibyiTdyYufjVg54fBlWr,AwUSJG5ZS-FDZTqnt6skTzhxQe08T-fbKXj8aEHZsXM/
       ;; RequestURI=freenet:SSK@BnHXXv3Fa43w~~iz1tNUd~cj4OpUuDjVouOWZ5XlpX0,AwUSJG5ZS-FDZTqnt6skTzhxQe08T-fbKXj8aEHZsXM,AQABAAE/
       ;; Identifier=My Identifier from GenerateSSK
       ;; EndMessage
       (let loop ()
	 (let* ((msg (if (char-ready? i)
			 (get-next-message i)
			 #f)))
	   (pp msg)
	   (if msg
	       (if (and (equal? (alist-ref '_msgtype_ msg) "SSKKeypair")
			(equal? (alist-ref 'Identifier msg) key))
		   msg
		   (begin
		     (thread-sleep! 1)
		     (loop)))
	       (begin
		 (thread-sleep! 1)
		 (loop)))))))))

(define (make-key . params)
  (let ((key (string-translate
	      (base64-encode (string-intersperse (map conc params) "-"))
	      "=" "x")))
    (doprint "Created key "key)
    key))

(define (register-directory directory)
  ;; (let-values (((i o)(tcp-connect (host) (port))))
  ;;   (client-send-hello o key)
  ;;   (wait-for-node-hello i)
  (let ((key (make-key (current-seconds) directory)))
    (with-connection
     key
     (lambda (i o)
       ;; first send the DDA request
       (test-dda i o directory)))))
  
)