-
Notifications
You must be signed in to change notification settings - Fork 0
/
fcp-example.scm
executable file
·125 lines (107 loc) · 4.49 KB
/
fcp-example.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
#!/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))))