;; 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) (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 (else (doprint 0 "Unaccounted for message: \n"msg) (loop))) (begin (thread-sleep! 1) (loop))))))))) ;; address format "First Last " ;; (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 " ;; (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))))) )