fcp.w 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604
  1. #!/usr/bin/env bash
  2. # -*- wisp -*-
  3. # A Freenet Client Protocol library for Guile Scheme.
  4. guile -L $(dirname $(realpath "$0")) -c '(import (language wisp spec))'
  5. PROG="$0"
  6. if [[ "$1" == "-i" ]]; then
  7. shift
  8. exec -a "${PROG}" guile -L $(dirname $(realpath "$0")) --language=wisp -x .w -e '(fcp)' -- "${@}"
  9. else
  10. exec -a "${0}" guile -L $(dirname $(realpath "$0")) --language=wisp -x .w -e '(fcp)' -c '' "${@}"
  11. fi;
  12. ; !#
  13. ;; for emacs (defun test-this-file () (interactive) (save-current-buffer) (async-shell-command (concat (buffer-file-name (current-buffer)) " --test")))
  14. define-module : fcp
  15. . #:export
  16. main
  17. . message-create message-task message-type message-data message-fields
  18. . message-client-get message-client-get-realtime message-client-get-bulk
  19. . message-client-put message-client-put-realtime message-client-put-bulk
  20. . message-remove-request
  21. . send-message processor-put! processor-delete!
  22. . printing-passthrough-processor printing-discarding-processor
  23. . discarding-processor processor-nodehello-printer
  24. . processor-datafound-getdata
  25. . task-id
  26. . node-ip-set! node-port-set!
  27. . call-with-fcp-connection with-fcp-connection
  28. define version "0.0.0 just-do-it"
  29. import
  30. only (srfi srfi-19) current-date date->string string->date date->time-utc time-utc->date
  31. . make-time time-utc time-duration add-duration current-time
  32. only (securepassword) letterblocks-nice
  33. only (srfi srfi-9) define-record-type
  34. only (srfi srfi-9 gnu) set-record-type-printer!
  35. only (ice-9 pretty-print) pretty-print truncated-print
  36. only (ice-9 rdelim) read-line read-delimited
  37. only (ice-9 format) format
  38. only (srfi srfi-1) first second third alist-cons assoc lset<= lset-intersection lset-difference take
  39. only (rnrs bytevectors) make-bytevector bytevector-length string->utf8 utf8->string bytevector?
  40. only (rnrs io ports) get-bytevector-all get-bytevector-n
  41. . put-bytevector bytevector->string port-eof?
  42. only (ice-9 popen) open-output-pipe
  43. only (ice-9 regex) string-match match:substring
  44. ice-9 threads
  45. ice-9 atomic
  46. only (ice-9 q) make-q enq! deq! q-empty?
  47. sxml simple
  48. doctests
  49. define : string-replace-string s char replacement-string
  50. string-join (string-split s char) replacement-string
  51. define : replace-KSK-escaped s
  52. string-replace-string : string-replace-string s #\+ "-"
  53. . #\= "-"
  54. define : task-id
  55. replace-KSK-escaped : letterblocks-nice 6
  56. ;; the shared FCP socket
  57. define sock #f
  58. define ip "127.0.0.1"
  59. define port "9483"
  60. define : fcp-socket-create
  61. define addrs : getaddrinfo ip port
  62. define addr : first addrs
  63. define s : socket (addrinfo:fam addr) (addrinfo:socktype addr) (addrinfo:protocol addr)
  64. connect s : addrinfo:addr addr
  65. . s
  66. define-record-type <message>
  67. message-create task type data fields
  68. . message?
  69. task message-task
  70. type message-type
  71. data message-data
  72. fields message-fields ;; avoid duplicates: fred joins duplicate fields with ";" to a single value
  73. ;; use a custom printer which avoids printing the full data
  74. set-record-type-printer! <message>
  75. lambda : record port
  76. format port "#<<message> task: ~A type: ~A data: ~a, fields: ~A"
  77. message-task record
  78. message-type record
  79. if : bytevector? : message-data record
  80. format #f "length=~a" : bytevector-length : message-data record
  81. message-data record
  82. message-fields record
  83. define : format-field field
  84. format #f "~a=~a"
  85. car field
  86. cdr field
  87. define : join-fields fields
  88. ## : tests : test-equal "A=B\nX=V" : join-fields : list (cons 'A "B") (cons 'X 'V)
  89. string-join
  90. map format-field fields
  91. . "\n"
  92. define field-key car
  93. define field-value cdr
  94. define : field-split s
  95. let : : where : string-index s #\=
  96. if where
  97. cons
  98. string->symbol : substring/shared s 0 where
  99. substring/shared s (+ where 1) (string-length s)
  100. cons s ""
  101. define : write-message message sock
  102. display (message-type message) sock
  103. newline sock
  104. when : message-task message
  105. format sock "Identifier=~a\n"
  106. message-task message
  107. when : not : null? : message-fields message
  108. display : join-fields : message-fields message
  109. . sock
  110. newline sock
  111. cond
  112. : message-data message
  113. format sock "~a\n"
  114. format-field : cons 'DataLength : bytevector-length : message-data message
  115. format sock "Data\n"
  116. put-bytevector sock : message-data message
  117. else
  118. display 'EndMessage sock
  119. newline sock
  120. atomic-box-set! sending-message #f
  121. ;; avoid overloading the node ;; FIXME: is this actually needed? Just added because it might fix crashes.
  122. usleep 1000 ;; max of 1000 messages per second
  123. define : message-client-hello
  124. message-create #f 'ClientHello #f
  125. list : cons 'Name "FetchpullClient"
  126. cons 'ExpectedVersion "2.0"
  127. define : message-watch-global
  128. message-create #f 'WatchGlobal #f
  129. list : cons 'Enabled "true"
  130. cons 'VerbosityMask 0 ;; simple progress
  131. define : message-disconnect
  132. message-create #f 'Disconnect #f
  133. list
  134. define : message-client-get task URI custom-fields
  135. ;; https://github.com/freenet/wiki/wiki/FCPv2-ClientGet
  136. message-create task 'ClientGet #f
  137. append
  138. list : cons 'URI URI
  139. ' : Verbosity . 0 ;; only be informed when the download is finished
  140. ReturnType . direct
  141. Global . true
  142. Persistence . reboot
  143. . custom-fields
  144. define : message-client-get-realtime task URI
  145. message-client-get task URI
  146. '
  147. PriorityClass . 2
  148. RealTimeFlag . true
  149. FilterData . false
  150. MaxRetries . 0
  151. define : message-client-get-bulk task URI
  152. message-client-get task URI
  153. '
  154. PriorityClass . 3 ;; medium
  155. RealTimeFlag . false
  156. FilterData . false
  157. MaxRetries . 1 ;; -1 means: try indefinitely, with ULPR, essentially long polling
  158. define : message-client-put task URI data custom-fields
  159. ;; https://github.com/freenet/wiki/wiki/FCPv2-ClientPut
  160. message-create task 'ClientPut data
  161. append
  162. list : cons 'URI URI
  163. ` : Global . true
  164. Persistence . reboot
  165. UploadFrom . direct
  166. . custom-fields
  167. define : message-client-put-realtime task URI data
  168. message-client-put task URI data
  169. '
  170. PriorityClass . 2
  171. MaxRetries . 0 ;; default: 10
  172. RealTimeFlag . true
  173. DontCompress . true
  174. ExtraInsertsSingleBlock . 0
  175. ExtraInsertsSplitfileHeaderBlock . 0
  176. ;; for realtime do NOT send Metadata.ContentType (or set it
  177. ;; to "" -> Metadata.isTrivial()), else you force at least
  178. ;; one level redirect.
  179. define : message-client-put-bulk task URI data
  180. message-client-put task URI data
  181. '
  182. PriorityClass . 3 ;; medium
  183. RealTimeFlag . false
  184. DontCompress . false
  185. define : message-remove-request task
  186. message-create task 'RemoveRequest #f
  187. list : cons 'Global 'true
  188. define supported-messages
  189. ' NodeHello GetFailed DataFound AllData PutSuccessful PutFailed
  190. define ignored-messages ;; TODO: implement support for these messages
  191. ' CompatibilityMode ExpectedDataLength ExpectedHashes ExpectedMIME PersistentGet PersistentPut SendingToNetwork SimpleProgress URIGenerated PersistentRequestRemoved
  192. define : log-warning message things
  193. format : current-output-port
  194. . "Warning: ~a: ~a\n" message things
  195. define : read-message port
  196. if : or (port-closed? port) (port-eof? port)
  197. . #f
  198. let loop : : type : string->symbol : read-line port
  199. define DataLength #f
  200. define task #f
  201. let readlines : : lines : list : read-line port
  202. define line : first lines
  203. define field : field-split line
  204. when : equal? 'DataLength : field-key field
  205. set! DataLength
  206. field-value field
  207. when : equal? 'Identifier : field-key field
  208. set! task
  209. field-value field
  210. ;; pretty-print : list 'line line 'type type
  211. cond
  212. : string-index line #\=
  213. readlines : cons (read-line port) lines
  214. : member type supported-messages
  215. let
  216. :
  217. data ;; EndMessage has no Data
  218. if : and DataLength : not : equal? "EndMessage" line
  219. get-bytevector-n port (string->number DataLength)
  220. . #f
  221. message-create task type data
  222. map field-split : cdr lines
  223. else
  224. when : not : member type ignored-messages
  225. log-warning "unsupported message type" : list type lines
  226. if : port-eof? port
  227. . #f
  228. loop : string->symbol : read-line port
  229. define next-message
  230. make-atomic-box #f
  231. define sending-message
  232. make-atomic-box #f
  233. define : send-message message
  234. ;; wait until the message was retrieved. This only replaces if the previous content was #f. take-message-to-send switches takes the messages
  235. let try : : failed : atomic-box-compare-and-swap! next-message #f message
  236. when failed
  237. usleep 100
  238. try : atomic-box-compare-and-swap! next-message #f message
  239. define : take-message-to-send
  240. ;; get the message and reset next-message to #f to allow taking another message
  241. atomic-box-set! sending-message #t ;; set to false again after successful write-message
  242. atomic-box-swap! next-message #f
  243. define message-processors
  244. make-atomic-box : list
  245. define : process message
  246. let loop : (processors (atomic-box-ref message-processors)) (msg message)
  247. cond
  248. : not msg
  249. . #f
  250. : null? processors
  251. . msg
  252. else
  253. loop (cdr processors)
  254. (first processors) msg
  255. define : processor-put! processor
  256. let loop : : old : atomic-box-ref message-processors
  257. define old-now : atomic-box-compare-and-swap! message-processors old : cons processor old
  258. when : not : equal? old old-now
  259. loop : atomic-box-ref message-processors
  260. define : processor-delete! processor
  261. let loop : : old : atomic-box-ref message-processors
  262. define old-now : atomic-box-compare-and-swap! message-processors old : delete processor old
  263. when : not : equal? old old-now
  264. loop : atomic-box-ref message-processors
  265. define stop-fcp-threads #f
  266. define : fcp-read-loop sock
  267. let loop : : message : read-message sock
  268. when message
  269. warn-unhandled
  270. process message
  271. usleep 10
  272. when : not stop-fcp-threads
  273. loop : read-message sock
  274. define : fcp-write-loop sock
  275. let loop : : message : take-message-to-send
  276. if message
  277. write-message message sock
  278. begin
  279. atomic-box-set! sending-message #f
  280. usleep 10
  281. when : not stop-fcp-threads
  282. loop : take-message-to-send
  283. define : warn-unhandled message
  284. when message
  285. format #t ;; avoid writing to the error port elsewhere, that causes multithreading problems. Use current-output-port instead
  286. . "Unhandled message ~a: ~A\n"
  287. message-type message
  288. . message
  289. . #f
  290. define : printing-passthrough-processor message
  291. pretty-print message
  292. . message
  293. define : printing-discarding-processor message
  294. pretty-print message
  295. . #f
  296. define : discarding-processor message
  297. . #f
  298. define : processor-nodehello-printer message
  299. cond
  300. : equal? 'NodeHello : message-type message
  301. pretty-print message
  302. . #f
  303. else message
  304. define : help args
  305. format : current-output-port
  306. . "~a [-i] [--help | --version | --test | YYYY-mm-dd]
  307. Options:
  308. -i load the script and run an interactive REPL."
  309. first args
  310. ;; timing information (alists)
  311. define get-successful : list
  312. define get-failed : list
  313. define put-successful : list
  314. define put-failed : list
  315. define get-alldata : list ; the actual data, for debugging
  316. define all-found-data-tasks : list
  317. define : processor-datafound-getdata message
  318. cond
  319. : equal? 'DataFound : message-type message
  320. pretty-print message
  321. when : not : member (message-task message) all-found-data-tasks
  322. send-message
  323. message-create : message-task message
  324. . 'GetRequestStatus #f
  325. list : cons 'Global 'true
  326. set! all-found-data-tasks
  327. cons : message-task message
  328. take all-found-data-tasks : min 100 : length all-found-data-tasks
  329. . #f
  330. else message
  331. define : processor-record-datafound-time message
  332. cond
  333. : equal? 'DataFound : message-type message
  334. let : : task : message-task message
  335. when : not : assoc task get-successful ;; only add if not yet known
  336. set! get-successful
  337. alist-cons task (current-time-seconds) get-successful
  338. . #f
  339. else message
  340. define : current-time-seconds
  341. car : gettimeofday
  342. define : processor-record-alldata-time message
  343. cond
  344. : equal? 'AllData : message-type message
  345. let : : task : message-task message
  346. when : not : assoc task get-successful ;; only add if not yet known
  347. set! get-successful
  348. alist-cons task (current-time-seconds) get-successful
  349. . #f
  350. else message
  351. define : processor-record-getfailed-time message
  352. cond
  353. : equal? 'GetFailed : message-type message
  354. let : : task : message-task message
  355. when : not : assoc task get-failed ;; only add if not yet known
  356. set! get-failed
  357. alist-cons task (current-time-seconds) get-failed
  358. . #f
  359. else message
  360. define : processor-record-putfailed-time message
  361. cond
  362. : equal? 'PutFailed : message-type message
  363. let : : task : message-task message
  364. when : not : assoc task put-failed ;; only add if not yet known
  365. set! put-failed
  366. alist-cons task (current-time-seconds) put-failed
  367. . #f
  368. else message
  369. define : processor-record-putsuccessful-time message
  370. cond
  371. : equal? 'PutSuccessful : message-type message
  372. let : : task : message-task message
  373. when : not : assoc task put-successful ;; only add if not yet known
  374. set! put-successful
  375. alist-cons task (current-time-seconds) put-successful
  376. . #f
  377. else message
  378. define : processor-record-identifier-collision-put-time message
  379. cond
  380. : equal? 'IdentifierCollision : message-type message
  381. let : : task : message-task message
  382. when : not : assoc task put-failed ;; only add if not yet known
  383. set! put-failed
  384. alist-cons task (current-time-seconds) put-failed
  385. . #f
  386. else message
  387. define-record-type <duration-entry>
  388. duration-entry key duration successful operation mode
  389. . timing-entry?
  390. key duration-entry-key
  391. duration duration-entry-duration
  392. successful duration-entry-success
  393. operation duration-entry-operation ;; get or put
  394. mode duration-entry-mode ;; realtime bulk speehacks
  395. define timeout-seconds : * 3600 3 ;; 3 hours maximum wait time
  396. define : timeout? timeout-seconds start-times
  397. and : not : null? start-times
  398. pair? : car start-times
  399. > : - (current-time-seconds) timeout-seconds
  400. cdr : car start-times
  401. define : remove-all-keys keys
  402. define : remove-key key
  403. send-message
  404. message-remove-request key
  405. map remove-key keys
  406. define %this-module : current-module
  407. define : test
  408. processor-put! printing-discarding-processor
  409. set! sock : fcp-socket-create
  410. let
  411. :
  412. fcp-read-thread
  413. begin-thread
  414. fcp-read-loop sock
  415. fcp-write-thread
  416. begin-thread
  417. fcp-write-loop sock
  418. send-message : message-client-hello
  419. send-message : message-watch-global
  420. send-message : message-client-get-realtime (letterblocks-nice 6) "USK@N82omidQlapADLWIym1u4rXvEQhjoIFbMa5~p1SKoOY,LE3WlYKas1AIdoVX~9wahrTlV5oZYhvJ4AcYYGsBq-w,AQACAAE/irclogs/772/2018-11-23.weechatlog"
  421. sleep 30
  422. send-message : message-disconnect
  423. doctests-testmod %this-module
  424. join-thread fcp-write-thread : + 30 : current-time-seconds
  425. join-thread fcp-read-thread : + 30 : current-time-seconds
  426. processor-delete! printing-discarding-processor
  427. close sock
  428. define : call-with-fcp-connection thunk
  429. set! sock : fcp-socket-create
  430. set! stop-fcp-threads #f
  431. let
  432. :
  433. fcp-read-thread
  434. begin-thread
  435. fcp-read-loop sock
  436. fcp-write-thread
  437. begin-thread
  438. fcp-write-loop sock
  439. send-message : message-client-hello
  440. send-message : message-watch-global
  441. thunk
  442. while : or (atomic-box-ref next-message) (atomic-box-ref sending-message)
  443. format #t "waiting for message to be sent: next-message: ~a , sending: ~a\n" (atomic-box-ref next-message) (atomic-box-ref sending-message)
  444. sleep 1
  445. send-message : message-disconnect
  446. set! stop-fcp-threads #t
  447. sleep 3
  448. close sock
  449. join-thread fcp-write-thread : + 3 : current-time-seconds
  450. join-thread fcp-read-thread : + 3 : current-time-seconds
  451. ;; FIXME: using new fcp connections in sequential code-parts fails with
  452. ;; ERROR: In procedure display: Wrong type argument in position 2: #<closed: file 7f106e118770>
  453. ;; ERROR: In procedure fport_read: Die Verbindung wurde vom Kommunikationspartner zurückgesetzt
  454. ;; therefore you should only use a single FCP connection for your program.
  455. define-syntax-rule : with-fcp-connection exp ...
  456. call-with-fcp-connection
  457. λ () exp ...
  458. define : final-action? args
  459. if {(length args) <= 1} #f
  460. cond
  461. : equal? "--help" : second args
  462. help args
  463. . #t
  464. : equal? "--version" : second args
  465. format : current-output-port
  466. . "~a\n" version
  467. . #t
  468. : equal? "--test" : second args
  469. test
  470. . #t
  471. else #f
  472. define : node-port-set! node-port
  473. set! port node-port
  474. define : node-ip-set! node-ip
  475. set! ip node-ip
  476. define : main args
  477. define put-task : task-id
  478. define get-task : task-id
  479. define key : string-append "KSK@" put-task
  480. define successful #f
  481. define : request-successful-upload message
  482. cond
  483. : equal? 'PutSuccessful : message-type message
  484. let : : fields : message-fields message
  485. when : and=> (assoc 'URI fields) : λ (uri) : equal? key : cdr uri
  486. pretty-print message
  487. send-message
  488. message-client-get-realtime get-task key
  489. send-message
  490. message-remove-request : message-task message
  491. . #f
  492. else message
  493. define : record-successful-download message
  494. cond
  495. : equal? 'AllData : message-type message
  496. let : : task : message-task message
  497. when : equal? task get-task
  498. pretty-print message
  499. display "Data: "
  500. truncated-print : utf8->string (message-data message)
  501. newline
  502. set! successful #t
  503. send-message
  504. message-remove-request task
  505. . #f
  506. else message
  507. ;; standard processorrs
  508. processor-put! printing-discarding-processor
  509. processor-put! processor-nodehello-printer
  510. ;; immediately request data from successfull get requests
  511. processor-put! processor-datafound-getdata
  512. ;; custom processors
  513. processor-put! request-successful-upload
  514. processor-put! record-successful-download
  515. when : not : final-action? args
  516. with-fcp-connection
  517. ;; get the ball rolling
  518. send-message
  519. message-client-put-realtime put-task key
  520. string->utf8 : string-append "Hello " key
  521. while : not successful
  522. display "."
  523. sleep 10