Commit 072d7e47 authored by Julien Lepiller's avatar Julien Lepiller

torrent: Add high-level functions to connect to peers.

* torrent/protocol.scm (potential-peer): New data type.
(peer-fiber): New procedure.
* doc/guile-torrent.texi: Document them.
parent 07383294
......@@ -472,4 +472,46 @@ whether that peer has piece number @var{piece}.
Update @var{bitfield} such that it now has the bit corresponding to piece
number @var{piece} set.
@end deffn
Additionnaly, this module defines higher-level functions and data types:
@deffn {Data Type} potential-peer
This data type represents coordinates to a peer we aren't currently connected
to. This is typically used to record peer lists received from trackers or
other protocols.
@table @asis
@item host
The host of the peer.
@item port
The port the peer listens on.
@item freshness
Determines whether we learned about that peer a short or a long time ago.
@end table
@end deffn
@deffn {Scheme Procedure} peer-fiber @var{parent-channel} @var{peer} @
@var{peerid} @var{infohash} @var{bitfield}
Runs a fiber that connects to a peer, listens for commands and reports peer
status. This fiber runs indefinitely until it receives a @code{'quit} signal
on its private channel.
@var{parent-channel} is the channel to which the fiber should report changes
to the current peer. These messages are are either
@code{`(("type" peer) ("peer" @var{peer}))} to report either a new connection or
an update to the peer fields, or @code{`(("type" peer-closed) ("peer" @var{peer}))}
to signal the peer is disconnected and should not be taken into account anymore.
This last message is given only when the fiber stops unexpectedly after it
advertised a new peer. If an error occured before the connection could be
advertised to the @var{parent-channel}, no message is sent to the channel.
@var{peer} is a @code{potential-peer} whose @var{host} and @var{port} fields
are used to connect to the peer it represents. @var{peerid} is the peer ID of
this client. @var{infohash} is the infohash of the torrent that should be
recovered from that peer and @var{bitfield} is the bitfield representation of
the pieces we have and don't have yet.
@end deffn
@bye
......@@ -21,7 +21,10 @@
#:use-module (ice-9 match)
#:use-module (rnrs base)
#:use-module (rnrs bytevectors)
#:use-module (torrent utils fibers)
#:use-module (fibers)
#:use-module (fibers channels)
#:use-module (fibers operations)
#:export (make-peer
peer?
peer-id
......@@ -33,6 +36,12 @@
peer-am-interested
peer-channel
make-potential-peer
potential-peer?
potential-peer-host
potential-peer-port
potential-peer-freshness
generate-id
get-new-peer
update-peer
......@@ -52,7 +61,9 @@
send-port
has?
has))
has
peer-fiber))
(define-record-type peer
(make-peer id sock bitfield choking interested am-choking am-interested channel)
......@@ -66,6 +77,13 @@
(am-interested peer-am-interested)
(channel peer-channel))
(define-record-type potential-peer
(make-potential-peer host port freshness)
potential-peer?
(host potential-peer-host)
(port potential-peer-port)
(freshness potential-peer-freshness))
(define* (update-peer peer
#:key
(id (peer-id peer)) (sock (peer-sock peer))
......@@ -248,3 +266,166 @@ it is made readable in this format: -<two-letter program id><four-digits version
(bytevector-u8-set!
bitfield (div piece 8)
(update-bit (mod piece 8) (bytevector-u8-ref bitfield (div piece 8)))))
(define (peer-read-fiber channel sock)
(lambda ()
(catch
#t
(lambda ()
(let loop ()
(put-message channel (list (cons "type" 'received)
(cons "message" (receive-message sock))))
(loop)))
(lambda () #t))))
(define (peer-write-fiber read-channel write-channel sock)
(lambda ()
(let loop ()
(match
(let ((message
(timeout-perform-operation 60 (get-operation write-channel))))
message)
('timeout
(send-keep-alive sock)
(loop))
('stop #t)
('choke
(begin
(send-choke sock)
(put-nonblocking read-channel `(("type" . action) ("action" . choke)))
(loop)))
('unchoke
(begin
(send-unchoke sock)
(put-nonblocking read-channel `(("type" . action) ("action" . unchoke)))
(loop)))
('interested
(begin
(send-interested sock)
(put-nonblocking read-channel `(("type" . action) ("action" . interested)))
(loop)))
('not-interested
(begin
(send-not-interested sock)
(put-nonblocking read-channel `(("type" . action) ("action" . not-interested)))
(loop)))
(val
(match (assoc-ref val "type")
('have
(begin
(send-have sock (assoc-ref val "have"))
(loop)))
('bitfield
(begin
(send-bitfield sock (assoc-ref val "bitfield"))
(loop)))
('request
(begin
(send-request sock (assoc-ref val "index") (assoc-ref val "start")
(assoc-ref val "len"))
(loop)))
('piece
(begin
(send-piece sock (assoc-ref val "index") (assoc-ref val "start")
(assoc-ref val "block"))
(loop)))
('cancel
(begin
(send-cancel sock (assoc-ref val "index") (assoc-ref val "start")
(assoc-ref val "len"))
(loop)))
('port
(begin
(send-port sock (assoc-ref val "port"))
(loop)))))))))
(define (peer-fiber parent-channel peer peerid infohash bitfield)
(lambda ()
(catch
#t
(lambda ()
(let ((peer (get-new-peer (potential-peer-host peer) (potential-peer-port peer)))
(read-channel (make-channel))
(write-channel (make-channel)))
(send-handshake (peer-sock peer) infohash (string->utf8 peerid))
(let* ((rpeerid (receive-handshake (peer-sock peer) infohash))
(peer (update-peer peer #:id rpeerid)))
(spawn-fiber (peer-read-fiber read-channel (peer-sock peer)))
(spawn-fiber (peer-write-fiber read-channel write-channel (peer-sock peer)))
(put-message parent-channel `(("type" . peer) ("peer" . ,peer)))
(catch
#t
(lambda ()
(if bitfield
(put-message write-channel
(list
(cons "type" 'bitfield)
(cons "bitfield" bitfield))))
(let loop ((peer peer))
(match
(let ((message
(perform-operation
(choice-operation
(get-operation (peer-channel peer))
(get-operation read-channel)))))
message)
('stop
(put-message write-channel 'stop)
#t)
('unchoke
(put-message write-channel 'unchoke))
('interested
(put-message write-channel 'interested))
(val
(match (assoc-ref val "type")
('action
(let ((peer
(match (assoc-ref val "action")
('choke (update-peer peer #:am-choking #t))
('unchoke (update-peer peer #:am-choking #f))
('interested (update-peer peer #:am-interested #t))
('not-interested (update-peer peer #:am-interested #f)))))
(put-message parent-channel
`(("type" . peer) ("peer" . ,peer)))
(loop peer)))
('received
(let ((peer
(match (assoc-ref val "message")
('keepalive peer)
('choke (update-peer peer #:choking #t))
('unchoke (update-peer peer #:choking #f))
('interested (update-peer peer #:interested #t))
('not-interested (update-peer peer #:interested #f))
(val
(match (assoc-ref val "type")
('have
(let ((bitfield (peer-bitfield peer)))
(has bitfield (assoc-ref val "piece"))
(update-peer peer #:bitfield bitfield)))
('bitfield
(update-peer peer #:bitfield (assoc-ref val "bitfield")))
('request peer)
('piece
(begin
(put-message parent-channel (cons (cons "who" peer) val))
peer))
('cancel peer)
('port peer))))))
(put-message parent-channel
`(("type" . peer) ("peer" . ,peer)))
(loop peer)))
('have
(put-message write-channel val))
('request
(put-message write-channel val)))))
(loop peer)))
(lambda (key . args)
(format #t "~%~%Peer threw an exception: ~a: ~{~a ~}~%" key args)
(put-message write-channel 'stop)
(if peer
(put-message
parent-channel
(list
(cons "type" 'peer-closed)
(cons "value" peer)))))))))
(lambda (typ . args) (format #t "Initialisation failed: ~a: ~a~%" typ args)))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment