! Copyright (C) 2020 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: accessors arrays assocs bencode byte-arrays checksums
-checksums.sha combinators fry grouping http.client io io.binary
-io.encodings.binary io.files io.pathnames io.sockets
-io.streams.byte-array kernel literals make math math.bitwise
-math.parser math.ranges namespaces random sequences splitting
-strings urls ;
+USING: accessors arrays assocs bencode byte-arrays byte-vectors
+calendar checksums checksums.sha combinators destructors endian
+grouping http.client io io.encodings.binary io.files
+io.pathnames io.sockets io.streams.byte-array io.streams.duplex
+kernel literals make math math.bitwise math.functions math.order
+math.parser namespaces random ranges sequences splitting strings
+timers ui ui.gadgets.panes ui.tools.listener urls ;
IN: bittorrent
<<
CONSTANT: ALPHANUMERIC $[
[
- CHAR: a CHAR: z [a,b] %
- CHAR: A CHAR: Z [a,b] %
- CHAR: 0 CHAR: 9 [a,b] %
+ CHAR: a CHAR: z [a..b] %
+ CHAR: A CHAR: Z [a..b] %
+ CHAR: 0 CHAR: 9 [a..b] %
".-_~" %
] { } make
]
dup "announce-list" of [ nip first random ] [ "announce" of ] if* ;
: scrape-url ( metainfo -- url/f )
- announce-url "announce" over path>> subseq? [
+ announce-url dup path>> "announce" subseq-of? [
[ "announce" "scrape" replace ] change-path
] [ drop f ] if ;
]
} cleave ;
+TUPLE: magnet display-name exact-length exact-topic
+web-seed acceptable-source exact-source keyword-topic
+manifest-topic address-tracker ;
+
+: magnet-link>magnet ( url -- magnet-url )
+ [ magnet new ] dip
+ >url query>> {
+ [ "dn" of >>display-name ]
+ [ "xl" of >>exact-length ]
+ [ "xt" of >>exact-topic ]
+ [ "ws" of >>web-seed ]
+ [ "as" of >>acceptable-source ]
+ [ "xs" of >>exact-source ]
+ [ "kt" of >>keyword-topic ]
+ [ "mt" of >>manifest-topic ]
+ [ "tr" of >>address-tracker ]
+ } cleave ;
+
: parse-peer4 ( peerbin -- inet4 )
4 cut [
[ number>string ] { } map-as "." join
: message> ( message -- bytes )
binary [ write-message ] with-byte-writer ;
+
+
+
+
+SYMBOL: torrent-max-block-size
+torrent-max-block-size [ 16384 ] initialize
+
+SYMBOL: torrent-directory
+torrent-directory [ "~/Desktop" ] initialize
+
+
+
+: with-debug ( quot -- )
+ ui-running? [
+ get-listener output>> <pane-stream> swap
+ '[ @ flush ] with-output-stream*
+ ] [
+ '[ @ flush ] with-global
+ ] if ; inline
+
+
+! connection
+
+TUPLE: torrent metainfo tracker peers ;
+
+:: <torrent> ( metainfo -- torrent )
+ torrent new
+ metainfo >>metainfo
+ metainfo load-tracker >>tracker
+ V{ } clone >>peers
+ ;
+
+: torrent-path ( torrent -- path )
+ metainfo>> { "info" "name" } [ of ] each
+ torrent-directory get prepend-path ;
+
+
+DEFER: <peer>
+
+: random-peer ( torrent -- peer )
+ dup tracker>> "peers" of random <peer> ;
+
+: update-tracker ( client -- client )
+ dup metainfo>> load-tracker >>tracker ;
+
+
+! peers
+
+TUPLE: peer < disposable torrent remote stream local handshake
+self-choking self-interested peer-choking peer-interested timer
+#pieces piece-length bitfield current-index current-piece ;
+
+DEFER: with-peer
+
+:: <peer> ( torrent remote -- peer )
+ peer new
+ torrent >>torrent
+ remote >>remote
+
+ t >>self-choking
+ f >>self-interested
+ t >>peer-choking
+ f >>peer-interested
+
+ dup '[
+ _ [ T{ keep-alive } write-message flush ] with-peer
+ ] 30 seconds dup <timer> >>timer
+
+ torrent metainfo>> "info" of
+ "pieces" of length 20 / [ >>#pieces ] keep
+
+ 8 / ceiling <byte-array> >>bitfield
+
+ torrent metainfo>> "info" of
+ "piece length" of [ >>piece-length ] keep
+
+ <byte-vector> >>current-piece
+ ;
+
+M: peer dispose
+ dup timer>> stop-timer
+ [ dispose f ] change-stream
+ f >>local f >>remote drop ;
+
+:: with-peer ( peer quot -- )
+ [
+ peer remote>> remote-address set
+ peer local>> local-address set
+ peer stream>> quot with-stream*
+ ] with-scope ; inline
+
+: connect-peer ( peer -- peer )
+ dup remote>> binary <client> [ >>stream ] [ >>local ] bi* ;
+
+: handshake-peer ( peer -- peer )
+ dup torrent>> metainfo>> info-hash
+ torrent-peer-id get <handshake> write-handshake
+ read-handshake >>handshake ;
+
+: fast-peer? ( peer -- ? )
+ handshake>> reserved>> 7 swap nth 3 swap bit? ;
+
+: unchoke-peer ( peer -- peer )
+ T{ unchoke } write-message f >>self-choking
+ T{ interested } write-message t >>self-interested
+ flush ;
+
+: choke-peer ( peer -- peer )
+ T{ choke } write-message t >>self-choking
+ T{ not-interested } write-message f >>self-interested
+ flush ;
+
+:: verify-block ( peer -- peer )
+ peer current-piece>> sha1 checksum-bytes
+ peer current-index>> 20 * dup 20 +
+ peer torrent>> metainfo>>
+ { "info" "pieces" } [ of ] each
+ B{ } subseq-as assert=
+ peer ;
+
+:: save-block ( peer -- peer )
+ peer torrent>> torrent-path binary [
+ peer current-index>>
+ peer piece-length>> *
+ seek-absolute seek-output
+ peer current-piece>> write
+ ] with-file-appender peer ;
+
+:: next-block ( peer -- peer )
+ peer current-index>> [ 1 + ] [ 0 ] if*
+ peer #pieces>>
+ peer bitfield>> '[ _ check-bitfield ] find-integer-from
+ peer current-index<<
+ 0 peer current-piece>> set-length
+ peer ;
+
+:: request-piece ( peer -- peer )
+ peer current-index>>
+ [ peer next-block current-index>> ] unless*
+ peer current-piece>> length
+ peer piece-length>> over - torrent-max-block-size get min
+ [
+ 2drop
+ peer
+ verify-block
+ save-block
+ next-block
+ request-piece
+ ] [
+ request boa write-message flush peer
+ ] if-zero ;
+
+GENERIC: handle-message ( peer message -- peer )
+
+M: object handle-message drop ;
+
+M: choke handle-message
+ drop t >>peer-choking ;
+
+M: unchoke handle-message
+ drop f >>peer-choking
+ dup self-choking>> [ next-block request-piece ] unless ;
+
+M: interested handle-message
+ drop t >>peer-interested ;
+
+M: not-interested handle-message
+ drop f >>peer-interested ;
+
+M: have handle-message
+ t swap index>> pick bitfield>> set-nth ;
+
+M: bitfield handle-message
+ 2dup [ bitfield>> length ] bi@ assert=
+ bitfield>> >>bitfield ;
+
+M: request handle-message
+ [ index>> ] [ begin>> ] [ length>> ] tri
+ reject-request boa write-message ;
+
+M: have-all handle-message
+ drop [ length [ 255 ] B{ } replicate-as ] change-bitfield ;
+
+M: have-none handle-message
+ drop [ length <byte-array> ] change-bitfield ;
+
+M:: piece handle-message ( peer message -- peer )
+ peer current-index>> message index>> assert=
+ peer current-piece>> length message begin>> assert=
+ message [ block>> ] [ begin>> ] bi peer current-piece>> copy
+ peer request-piece ;
+
+: read-messages ( peer -- peer )
+ [ read-message ] [ handle-message ] while* ;
projects / factor.git / blobdiff