123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126 |
- #!/usr/bin/env bash
- # -*- scheme -*-
- # A Freenet Client Protocol library for Guile Scheme.
- exec -a "${0}" guile -L $(dirname $(realpath "$0")) -e '(fcp-example)' -c '' "${@}"
- ; !#
- ;; for emacs (defun test-this-file () (interactive) (save-current-buffer) (async-shell-command (concat (buffer-file-name (current-buffer)) " --test")))
- (define-module (fcp-example)
- #:export (main))
- (import
- (only (fcp) message-create message-task message-type message-data message-fields
- message-client-get message-client-get-realtime message-client-get-bulk
- message-client-put message-client-put-realtime message-client-put-bulk
- message-remove-request
- send-message processor-put! processor-delete!
- printing-passthrough-processor printing-discarding-processor
- discarding-processor processor-nodehello-printer
- processor-datafound-getdata
- node-ip-set! node-port-set!
- task-id
- call-with-fcp-connection with-fcp-connection)
- (only (ice-9 pretty-print) pretty-print)
- (only (srfi srfi-1) first second third assoc)
- (only (srfi srfi-26) cut)
- (srfi srfi-37 );; commandline handling
- (only (rnrs bytevectors) string->utf8 utf8->string))
- (define (request-successful-upload message)
- "When the put succeeds, download the data."
- (if (equal? 'PutSuccessful (message-type message))
- (let ((fields (message-fields message)))
- (when (and=> (assoc 'URI fields) (λ (uri-cel) (equal? key (cdr uri-cel))))
- (send-message
- (message-client-get-realtime get-task key)))
- #f)
- message))
- (define (record-successful-download message)
- "When the download succeeds, display the result"
- (if (equal? 'AllData (message-type message))
- (let ((task (message-task message)))
- (when (equal? task get-task)
- (format #t "Received Message: ~a\n" (utf8->string (message-data message)))
- (set! successful #t))
- #f)
- message))
- (define (remove-successful-tasks-from-queue message)
- "Cleanup the task because we use the global queue for easier debugging"
- (when (member (message-type message) '(AllData PutSuccessful))
- (send-message (message-remove-request (message-task message))))
- message)
- (define put-task (task-id))
- (define get-task (task-id))
- (define key (string-append "KSK@" put-task))
- (define successful #f)
- (define (setup-handlers)
- ;; standard processors
- (processor-put! printing-discarding-processor)
- (processor-put! processor-nodehello-printer)
- ;; immediately request data from successfull get requests
- (processor-put! processor-datafound-getdata)
- ;; custom processors
- (processor-put! request-successful-upload)
- (processor-put! record-successful-download)
- (processor-put! remove-successful-tasks-from-queue))
- ;; commandline handling via srfi-37
- (define options
- (list
- (option '(#\V "version") #f #f
- (λ (opt name args loads)
- (display "Guile FCP version 0.2\n")
- (quit)))
- (option '(#\h "help") #f #f
- (λ (opt name args loads)
- (format #t "Usage: ~a [options]
-
- Options:
- -h --help show this dialog
- -V --version show the version
- -H IP_OR_HOSTNAME --host=IP_OR_HOSTNAME set the node address
- -P PORT --port=PORT set the FCP port
- " (car (program-arguments)))
- (quit)))
- (option '(#\P "port") #t #f
- (λ (opt name arg loads)
- (node-port-set! arg)
- loads))
- (option '(#\H "host") #t #f
- (λ (opt name arg loads)
- (node-ip-set! arg)
- loads))))
- (define (main args)
- (define arguments
- (args-fold (cdr args)
- options
- (lambda (opt name arg loads)
- (error "Unrecognized option `~A'" name))
- (lambda (op loads) (cons op loads))
- '()))
- (setup-handlers)
- ;; open the FCP connection. Anything inside this scope can
- ;; communicate directly with Freenet via FCP, other interaction
- ;; must be done through processing procedures as setup above.
- (with-fcp-connection
- ;; get the ball rolling
- (send-message
- (message-client-put-realtime put-task key
- (string->utf8 (string-append "Hello " key))))
- (while (not successful)
- (display ".")
- (sleep 1))))
|