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

 ;; add lower level stuff later
 ;;
 ;; send-and-print
 ;; get-next-message
 ;; client-send-hello
 ;; wait-for-node-hello
 ;; test-dda
 ;; with-connection
 ;; make-key
 )

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

;; 2 - debug
;; 1 - normal
;; 0 - quiet, errors only
;;
(define (doprint v . params)
  (if (>= (verbosity) v)
      (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 2 "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 2 "Waiting for: "val)
  (let loop ()
    (let ((inl (read-line i)))
      (if (string-match val inl)
	  (doprint 2 "Got: "inl)
	  (begin
	    (doprint 2 "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 2 "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
		    (doprint 0 "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
		       (doprint 0 "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
	  (doprint 0 "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* ((msg (get-next-message i)))
	  (cond
	   ((alist-ref 'ContentToWrite msg)
	    (let* ((content (alist-ref 'ContentToWrite msg))
		   (writefn (alist-ref 'WriteFilename msg))
		   (readfn  (alist-ref 'ReadFilename msg)))
	      (if (not (and msg content writefn readfn))
		  (begin
		    (doprint 0 "Got "msg" 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")))))
	   (else
	    (doprint 0 "ERROR: in test-dda and got msg:\n" msg)
	    (loop))))
	(begin ;; no input, sleep and peek again
	  (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)))

(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)))
		(msgtype  (and msg (alist-ref '_msgtype_ msg))))
	   (if msgforus
	       (cond
		((equal? msgtype "ProtocolError")
		 (doprint 0 "ERROR: "(or (alist-ref 'CodeDescription msg)
					 (conc "unknown error\nmessage="msg)))
		 #f) ;; stop, failed
		((member msgtype '("PersistentGet" "CompatibilityMode"));; these are ok, keep going
		 (loop))
		((alist-ref 'Succeeded msg) ;; Got data successfully
		 (doprint 1 "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 ;; stop, succeeded
		     (if (and (equal? (alist-ref 'Min msg) "COMPAT_UNKNOWN")
			      (equal? (alist-ref 'Max msg) "COMPAT_UNKNOWN"))
			 (begin
			   (doprint 0 "Failed to find "uri)
			   #f) ;; stop, failed
			 (begin
			   (thread-sleep! 1)
			   (loop))))) ;; keep going
		((member msgtype '("DataFound"))
		 (doprint 1 "Progress: "
			  "retrieved "(alist-ref 'DataLength msg)" Bytes")
		 (if (and (alist-ref 'CompletionTime msg)
			  (file-exists? fullname))
		     #t ;; stop, succeeded
		     (if (and (equal? (alist-ref 'Min msg) "COMPAT_UNKNOWN")
			      (equal? (alist-ref 'Max msg) "COMPAT_UNKNOWN"))
			 (begin
			   (doprint 0 "Failed to find "uri)
			   #f) ;; stop, failed
			 (begin
			   (thread-sleep! 1)
			   (loop))))) ;; keep going
		(else
		 (doprint 0 "Unaccounted for message: \n"msg)
		 (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 2 "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 2 "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)))))
  
)