1 ! Copyright (C) 2020 John Benediktsson
2 ! See https://factorcode.org/license.txt for BSD license
3 USING: accessors arrays assocs bencode byte-arrays byte-vectors
4 calendar checksums checksums.sha combinators destructors endian
5 grouping http.client io io.encodings.binary io.files
6 io.pathnames io.sockets io.streams.byte-array io.streams.duplex
7 kernel literals make math math.bitwise math.functions math.order
8 math.parser namespaces random ranges sequences splitting strings
9 timers ui ui.gadgets.panes ui.tools.listener urls ;
14 CONSTANT: ALPHANUMERIC $[
16 CHAR: a CHAR: z [a..b] %
17 CHAR: A CHAR: Z [a..b] %
18 CHAR: 0 CHAR: 9 [a..b] %
23 : random-peer-id ( -- bytes )
24 20 [ ALPHANUMERIC random ] B{ } replicate-as ;
27 SYMBOL: torrent-peer-id
28 torrent-peer-id [ random-peer-id ] initialize
31 torrent-port [ 6881 ] initialize
36 : bitfield-index ( n -- j i )
39 : set-bitfield ( elt n bitfield -- )
40 [ bitfield-index rot ] dip -rot
41 '[ _ _ [ set-bit ] [ clear-bit ] if ] change-nth ;
43 : check-bitfield ( n bitfield -- ? )
44 [ bitfield-index swap ] dip nth swap bit? ;
49 : http-get-bencode ( url -- obj )
50 <get-request> BV{ } clone [
51 '[ _ push-all ] do-http-request check-response drop
52 ] keep B{ } like bencode> ;
57 GENERIC: load-metainfo ( obj -- metainfo )
59 M: url load-metainfo http-get-bencode ;
61 M: pathname load-metainfo
62 binary [ read-bencode ] with-file-reader ;
64 M: string load-metainfo
65 dup "http" head? [ >url ] [ <pathname> ] if load-metainfo ;
67 : info-hash ( metainfo -- hash )
68 "info hash" swap dup '[
69 drop _ "info" of >bencode sha1 checksum-bytes
72 : announce-url ( metainfo -- url )
73 dup "announce-list" of [ nip first random ] [ "announce" of ] if* ;
75 : scrape-url ( metainfo -- url/f )
76 announce-url dup path>> "announce" subseq-of? [
77 [ "announce" "scrape" replace ] change-path
84 : tracker-url ( metainfo -- url )
88 info-hash "info_hash" set-query-param
89 torrent-peer-id get "peer_id" set-query-param
90 torrent-port get "port" set-query-param
91 0 "uploaded" set-query-param
92 0 "downloaded" set-query-param
93 1 "compact" set-query-param
96 { "info" "length" } [ of ] each
97 "left" set-query-param
101 TUPLE: magnet display-name exact-length exact-topic
102 web-seed acceptable-source exact-source keyword-topic
103 manifest-topic address-tracker select-only peer ;
105 : magnet-link>magnet ( url -- magnet-url )
108 [ "dn" of >>display-name ]
109 [ "xl" of >>exact-length ]
110 [ "xt" of >>exact-topic ]
111 [ "ws" of >>web-seed ]
112 [ "as" of >>acceptable-source ]
113 [ "xs" of >>exact-source ]
114 [ "kt" of >>keyword-topic ]
115 [ "mt" of >>manifest-topic ]
116 [ "tr" of >>address-tracker ]
117 [ "so" of >>select-only ]
121 : parse-peer4 ( peerbin -- inet4 )
123 [ number>string ] { } map-as "." join
126 : parse-peer4s ( peersbin -- inet4s )
128 [ [ "ip" of ] [ "port" of ] bi <inet4> ] map
130 6 <groups> [ parse-peer4 ] map
133 : parse-peer6 ( peerbin -- inet6 )
135 2 <groups> [ be> number>string ] map ":" join
138 : parse-peer6s ( peersbin -- inet6s )
139 18 <groups> [ parse-peer6 ] map ;
141 : load-tracker ( torrent -- response )
142 tracker-url http-get-bencode
143 "peers" over [ parse-peer4s ] change-at ;
145 : send-event ( torrent event -- response )
146 [ tracker-url ] [ "event" set-query-param ] bi*
153 TUPLE: handshake string reserved info-hash peer-id ;
155 : <handshake> ( info-hash peer-id -- handshake )
157 "BitTorrent protocol" >byte-array >>string
158 8 <byte-array> >>reserved
162 : read-handshake ( -- handshake/f )
164 [ 48 + read ] keep cut 8 cut 20 cut handshake boa
167 : write-handshake ( handshake -- )
169 [ string>> [ length write1 ] [ write ] bi ]
171 [ info-hash>> write ]
179 TUPLE: not-interested ;
181 TUPLE: bitfield bitfield ;
182 TUPLE: request index begin length ;
183 TUPLE: piece index begin block ;
184 TUPLE: cancel index begin length ;
186 TUPLE: suggest-piece index ;
189 TUPLE: reject-request index begin length ;
190 TUPLE: allowed-fast index ;
191 TUPLE: extended id payload ;
192 TUPLE: unknown id payload ;
194 : read-int ( -- n/f ) 4 read [ be> ] [ f ] if* ;
196 : parse-message ( bytes -- message/f )
199 { 0 [ drop choke boa ] }
200 { 1 [ drop unchoke boa ] }
201 { 2 [ drop interested boa ] }
202 { 3 [ drop not-interested boa ] }
203 { 4 [ 4 head be> have boa ] }
204 { 5 [ bitfield boa ] }
205 { 6 [ 4 cut 4 cut 4 head [ be> ] tri@ request boa ] }
206 { 7 [ 4 cut 4 cut [ [ be> ] bi@ ] dip piece boa ] }
207 { 8 [ 4 cut 4 cut 4 head [ be> ] tri@ cancel boa ] }
210 { 9 [ be> port boa ] }
213 { 0x0D [ 4 head be> suggest-piece boa ] }
214 { 0x0E [ drop have-all boa ] }
215 { 0x0F [ drop have-none boa ] }
216 { 0x10 [ 4 cut 4 cut 4 head [ be> ] tri@ reject-request boa ] }
217 { 0x11 [ 4 head be> allowed-fast boa ] }
220 { 0x14 [ unclip swap extended boa ] }
222 ! Hash Transfer Protocol
223 ! { 0x15 [ "HashRequest" ] }
224 ! { 0x16 [ "Hashes" ] }
225 ! { 0x17 [ "HashReject" ] }
229 : read-message ( -- message )
232 { 0 [ keep-alive boa ] }
233 [ read [ parse-message ] [ f ] if* ]
236 : write-int ( n -- ) 4 >be write ;
238 GENERIC: write-message ( message -- )
240 M: keep-alive write-message drop 0 write-int ;
242 M: choke write-message drop 1 write-int 0 write1 ;
244 M: unchoke write-message drop 1 write-int 1 write1 ;
246 M: interested write-message drop 1 write-int 2 write1 ;
248 M: not-interested write-message drop 1 write-int 3 write1 ;
250 M: have write-message
251 5 write-int 4 write1 index>> write-int ;
253 M: bitfield write-message
254 field>> dup length 1 + write-int 5 write1 write ;
256 M: request write-message
257 [ index>> ] [ begin>> ] [ length>> ] tri
258 13 write-int 6 write1 [ write-int ] tri@ ;
260 M: piece write-message
261 [ index>> ] [ offset>> ] [ block>> ] tri
262 dup length 9 + write-int 7 write1
263 [ write-int ] [ write-int ] [ write ] tri* ;
265 M: cancel write-message
266 [ index>> ] [ offset>> ] [ length>> ] tri
267 13 write-int 8 write1 [ write-int ] tri@ ;
269 M: port write-message
270 5 write-int 9 write1 port>> write-int ;
272 M: suggest-piece write-message
273 5 write-int 0x0D write1 index>> write-int ;
275 M: have-all write-message drop 1 write-int 0x0E write1 ;
277 M: have-none write-message drop 1 write-int 0x0F write1 ;
279 M: reject-request write-message
280 [ index>> ] [ begin>> ] [ length>> ] tri
281 13 write-int 0x10 write1 [ write-int ] tri@ ;
283 M: allowed-fast write-message
284 5 write-int 0x11 write1 index>> write-int ;
286 M: extended write-message
287 [ payload>> ] [ id>> ] bi
288 over length 2 + write-int 0x14 write1 write1 write ;
290 M: unknown write-message
291 [ payload>> ] [ id>> ] bi
292 over length 1 + write-int write1 write ;
294 : >message ( bytes -- message )
295 binary [ read-message ] with-byte-reader ;
297 : message> ( message -- bytes )
298 binary [ write-message ] with-byte-writer ;
303 SYMBOL: torrent-max-block-size
304 torrent-max-block-size [ 16384 ] initialize
306 SYMBOL: torrent-directory
307 torrent-directory [ "~/Desktop" ] initialize
311 : with-debug ( quot -- )
313 get-listener output>> <pane-stream> swap
314 '[ @ flush ] with-output-stream*
316 '[ @ flush ] with-global
322 TUPLE: torrent metainfo tracker peers ;
324 :: <torrent> ( metainfo -- torrent )
327 metainfo load-tracker >>tracker
331 : torrent-path ( torrent -- path )
332 metainfo>> { "info" "name" } [ of ] each
333 torrent-directory get prepend-path ;
338 : random-peer ( torrent -- peer )
339 dup tracker>> "peers" of random <peer> ;
341 : update-tracker ( client -- client )
342 dup metainfo>> load-tracker >>tracker ;
347 TUPLE: peer < disposable torrent remote stream local handshake
348 self-choking self-interested peer-choking peer-interested timer
349 #pieces piece-length bitfield current-index current-piece ;
353 :: <peer> ( torrent remote -- peer )
364 _ [ T{ keep-alive } write-message flush ] with-peer
365 ] 30 seconds dup <timer> >>timer
367 torrent metainfo>> "info" of
368 "pieces" of length 20 / [ >>#pieces ] keep
370 8 / ceiling <byte-array> >>bitfield
372 torrent metainfo>> "info" of
373 "piece length" of [ >>piece-length ] keep
375 <byte-vector> >>current-piece
379 dup timer>> stop-timer
380 [ dispose f ] change-stream
381 f >>local f >>remote drop ;
383 :: with-peer ( peer quot -- )
385 peer remote>> remote-address set
386 peer local>> local-address set
387 peer stream>> quot with-stream*
388 ] with-scope ; inline
390 : connect-peer ( peer -- peer )
391 dup remote>> binary <client> [ >>stream ] [ >>local ] bi* ;
393 : handshake-peer ( peer -- peer )
394 dup torrent>> metainfo>> info-hash
395 torrent-peer-id get <handshake> write-handshake
396 read-handshake >>handshake ;
398 : fast-peer? ( peer -- ? )
399 handshake>> reserved>> 7 swap nth 3 swap bit? ;
401 : unchoke-peer ( peer -- peer )
402 T{ unchoke } write-message f >>self-choking
403 T{ interested } write-message t >>self-interested
406 : choke-peer ( peer -- peer )
407 T{ choke } write-message t >>self-choking
408 T{ not-interested } write-message f >>self-interested
411 :: verify-block ( peer -- peer )
412 peer current-piece>> sha1 checksum-bytes
413 peer current-index>> 20 * dup 20 +
414 peer torrent>> metainfo>>
415 { "info" "pieces" } [ of ] each
416 B{ } subseq-as assert=
419 :: save-block ( peer -- peer )
420 peer torrent>> torrent-path binary [
422 peer piece-length>> *
423 seek-absolute seek-output
424 peer current-piece>> write
425 ] with-file-appender peer ;
427 :: next-block ( peer -- peer )
428 peer current-index>> [ 1 + ] [ 0 ] if*
430 peer bitfield>> '[ _ check-bitfield ] find-integer-from
432 0 peer current-piece>> set-length
435 :: request-piece ( peer -- peer )
437 [ peer next-block current-index>> ] unless*
438 peer current-piece>> length
439 peer piece-length>> over - torrent-max-block-size get min
448 request boa write-message flush peer
451 GENERIC: handle-message ( peer message -- peer )
453 M: object handle-message drop ;
455 M: choke handle-message
456 drop t >>peer-choking ;
458 M: unchoke handle-message
459 drop f >>peer-choking
460 dup self-choking>> [ next-block request-piece ] unless ;
462 M: interested handle-message
463 drop t >>peer-interested ;
465 M: not-interested handle-message
466 drop f >>peer-interested ;
468 M: have handle-message
469 t swap index>> pick bitfield>> set-nth ;
471 M: bitfield handle-message
472 2dup [ bitfield>> length ] bi@ assert=
473 bitfield>> >>bitfield ;
475 M: request handle-message
476 [ index>> ] [ begin>> ] [ length>> ] tri
477 reject-request boa write-message ;
479 M: have-all handle-message
480 drop [ length [ 255 ] B{ } replicate-as ] change-bitfield ;
482 M: have-none handle-message
483 drop [ length <byte-array> ] change-bitfield ;
485 M:: piece handle-message ( peer message -- peer )
486 peer current-index>> message index>> assert=
487 peer current-piece>> length message begin>> assert=
488 message [ block>> ] [ begin>> ] bi peer current-piece>> copy
491 : read-messages ( peer -- peer )
492 [ read-message ] [ handle-message ] while* ;