diff options
Diffstat (limited to 'src/Network/BitTorrent/Internal.hs')
-rw-r--r-- | src/Network/BitTorrent/Internal.hs | 20 |
1 files changed, 14 insertions, 6 deletions
diff --git a/src/Network/BitTorrent/Internal.hs b/src/Network/BitTorrent/Internal.hs index 2f538652..3d07a82f 100644 --- a/src/Network/BitTorrent/Internal.hs +++ b/src/Network/BitTorrent/Internal.hs | |||
@@ -34,8 +34,8 @@ module Network.BitTorrent.Internal | |||
34 | ) | 34 | ) |
35 | , SessionState | 35 | , SessionState |
36 | , bitfield, status | 36 | , bitfield, status |
37 | , emptyBF, fullBF, singletonBF | 37 | , emptyBF, fullBF, singletonBF, adjustBF |
38 | , getPieceCount, getPeerBF | 38 | , getPieceCount, getClientBF |
39 | , sessionError, withPeerSession | 39 | , sessionError, withPeerSession |
40 | 40 | ||
41 | -- * Timeouts | 41 | -- * Timeouts |
@@ -250,10 +250,15 @@ withPeerSession ss @ SwarmSession {..} addr | |||
250 | let caps = encodeExts $ allowedExtensions $ clientSession | 250 | let caps = encodeExts $ allowedExtensions $ clientSession |
251 | let pid = clientPeerID $ clientSession | 251 | let pid = clientPeerID $ clientSession |
252 | let chs = Handshake defaultBTProtocol caps (tInfoHash torrentMeta) pid | 252 | let chs = Handshake defaultBTProtocol caps (tInfoHash torrentMeta) pid |
253 | 253 | putStrLn "trying to connect" | |
254 | sock <- connectToPeer addr | 254 | sock <- connectToPeer addr |
255 | |||
256 | putStrLn "trying to handshake" | ||
255 | phs <- handshake sock chs `onException` close sock | 257 | phs <- handshake sock chs `onException` close sock |
256 | 258 | ||
259 | cbf <- readTVarIO clientBitfield | ||
260 | sendAll sock (encode (Bitfield cbf)) | ||
261 | |||
257 | let enabled = decodeExts (enabledCaps caps (handshakeCaps phs)) | 262 | let enabled = decodeExts (enabledCaps caps (handshakeCaps phs)) |
258 | ps <- PeerSession addr ss enabled | 263 | ps <- PeerSession addr ss enabled |
259 | <$> registerTimeout (eventManager clientSession) | 264 | <$> registerTimeout (eventManager clientSession) |
@@ -281,8 +286,11 @@ fullBF = liftM haveAll getPieceCount | |||
281 | singletonBF :: (MonadReader PeerSession m) => PieceIx -> m Bitfield | 286 | singletonBF :: (MonadReader PeerSession m) => PieceIx -> m Bitfield |
282 | singletonBF ix = liftM (BF.singleton ix) getPieceCount | 287 | singletonBF ix = liftM (BF.singleton ix) getPieceCount |
283 | 288 | ||
284 | getPeerBF :: (MonadIO m, MonadReader PeerSession m) => m Bitfield | 289 | adjustBF :: (MonadReader PeerSession m) => Bitfield -> m Bitfield |
285 | getPeerBF = asks swarmSession >>= liftIO . readTVarIO . clientBitfield | 290 | adjustBF bf = (`adjustSize` bf) `liftM` getPieceCount |
291 | |||
292 | getClientBF :: (MonadIO m, MonadReader PeerSession m) => m Bitfield | ||
293 | getClientBF = asks swarmSession >>= liftIO . readTVarIO . clientBitfield | ||
286 | 294 | ||
287 | --data Signal = | 295 | --data Signal = |
288 | --nextBroadcast :: P2P (Maybe Signal) | 296 | --nextBroadcast :: P2P (Maybe Signal) |
@@ -317,7 +325,7 @@ updateOutcoming PeerSession {..} = | |||
317 | sendKA :: Socket -> IO () | 325 | sendKA :: Socket -> IO () |
318 | sendKA sock {- SwarmSession {..} -} = do | 326 | sendKA sock {- SwarmSession {..} -} = do |
319 | print "I'm sending keep alive." | 327 | print "I'm sending keep alive." |
320 | sendAll sock (encode BT.KeepAlive) | 328 | -- sendAll sock (encode BT.KeepAlive) |
321 | -- let mgr = eventManager clientSession | 329 | -- let mgr = eventManager clientSession |
322 | -- updateTimeout mgr | 330 | -- updateTimeout mgr |
323 | print "Done.." | 331 | print "Done.." |