diff options
Diffstat (limited to 'src/Network/BitTorrent')
-rw-r--r-- | src/Network/BitTorrent/Exchange.hs | 47 | ||||
-rw-r--r-- | src/Network/BitTorrent/Exchange/Protocol.hs | 22 | ||||
-rw-r--r-- | src/Network/BitTorrent/Internal.hs | 12 | ||||
-rw-r--r-- | src/Network/BitTorrent/Tracker.hs | 2 |
4 files changed, 37 insertions, 46 deletions
diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs index 0e2799b2..3235a626 100644 --- a/src/Network/BitTorrent/Exchange.hs +++ b/src/Network/BitTorrent/Exchange.hs | |||
@@ -22,19 +22,11 @@ module Network.BitTorrent.Exchange | |||
22 | ) where | 22 | ) where |
23 | 23 | ||
24 | import Control.Applicative | 24 | import Control.Applicative |
25 | import Control.Concurrent | ||
26 | import Control.Concurrent.STM | ||
27 | import Control.Exception | 25 | import Control.Exception |
28 | import Control.Lens | 26 | import Control.Lens |
29 | import Control.Monad.Reader | 27 | import Control.Monad.Reader |
30 | import Control.Monad.State | ||
31 | import Control.Monad.Trans.Resource | 28 | import Control.Monad.Trans.Resource |
32 | 29 | ||
33 | import Data.IORef | ||
34 | import Data.Function | ||
35 | import Data.Ord | ||
36 | import Data.Set as S | ||
37 | |||
38 | import Data.Conduit as C | 30 | import Data.Conduit as C |
39 | import Data.Conduit.Cereal | 31 | import Data.Conduit.Cereal |
40 | import Data.Conduit.Network | 32 | import Data.Conduit.Network |
@@ -49,7 +41,6 @@ import Network.BitTorrent.Extension | |||
49 | import Network.BitTorrent.Peer | 41 | import Network.BitTorrent.Peer |
50 | import Network.BitTorrent.Exchange.Protocol | 42 | import Network.BitTorrent.Exchange.Protocol |
51 | import Data.Bitfield as BF | 43 | import Data.Bitfield as BF |
52 | import Data.Torrent | ||
53 | 44 | ||
54 | 45 | ||
55 | data Event = Available Bitfield | 46 | data Event = Available Bitfield |
@@ -74,7 +65,7 @@ runConduit sock p2p = | |||
74 | awaitMessage :: P2P Message | 65 | awaitMessage :: P2P Message |
75 | awaitMessage = P2P (ReaderT go) | 66 | awaitMessage = P2P (ReaderT go) |
76 | where | 67 | where |
77 | go se = do | 68 | go _ = do |
78 | liftIO $ putStrLn "trying recv:" | 69 | liftIO $ putStrLn "trying recv:" |
79 | mmsg <- await | 70 | mmsg <- await |
80 | case mmsg of | 71 | case mmsg of |
@@ -169,10 +160,10 @@ awaitEvent = awaitMessage >>= go | |||
169 | status.peerStatus.interested .= False | 160 | status.peerStatus.interested .= False |
170 | awaitEvent | 161 | awaitEvent |
171 | 162 | ||
172 | go (Have ix) = do | 163 | go (Have idx) = do |
173 | new <- singletonBF ix | 164 | new <- singletonBF idx |
174 | bitfield %= BF.union new | 165 | bitfield %= BF.union new |
175 | revise | 166 | _ <- revise |
176 | 167 | ||
177 | offer <- peerOffer | 168 | offer <- peerOffer |
178 | if not (BF.null offer) | 169 | if not (BF.null offer) |
@@ -182,7 +173,7 @@ awaitEvent = awaitMessage >>= go | |||
182 | go (Bitfield bf) = do | 173 | go (Bitfield bf) = do |
183 | new <- adjustBF bf | 174 | new <- adjustBF bf |
184 | bitfield .= new | 175 | bitfield .= new |
185 | revise | 176 | _ <- revise |
186 | 177 | ||
187 | offer <- peerOffer | 178 | offer <- peerOffer |
188 | if not (BF.null offer) | 179 | if not (BF.null offer) |
@@ -205,38 +196,40 @@ awaitEvent = awaitMessage >>= go | |||
205 | then return (Fragment blk) | 196 | then return (Fragment blk) |
206 | else awaitEvent | 197 | else awaitEvent |
207 | 198 | ||
208 | {- | 199 | go (Cancel _) = do |
200 | error "cancel message not implemented" | ||
201 | |||
209 | go (Port _) = do | 202 | go (Port _) = do |
210 | requireExtension ExtDHT | 203 | requireExtension ExtDHT |
211 | undefined | 204 | error "port message not implemented" |
212 | 205 | ||
213 | go HaveAll = do | 206 | go HaveAll = do |
214 | requireExtension ExtFast | 207 | requireExtension ExtFast |
215 | bitfield <~ fullBF | 208 | bitfield <~ fullBF |
216 | revise | 209 | _ <- revise |
217 | awaitEvent | 210 | awaitEvent |
218 | 211 | ||
219 | go HaveNone = do | 212 | go HaveNone = do |
220 | requireExtension ExtFast | 213 | requireExtension ExtFast |
221 | bitfield <~ emptyBF | 214 | bitfield <~ emptyBF |
222 | revise | 215 | _ <- revise |
223 | awaitEvent | 216 | awaitEvent |
224 | 217 | ||
225 | go (SuggestPiece ix) = do | 218 | go (SuggestPiece idx) = do |
226 | requireExtension ExtFast | 219 | requireExtension ExtFast |
227 | bf <- use bitfield | 220 | bf <- use bitfield |
228 | if ix `BF.notMember` bf | 221 | if idx `BF.notMember` bf |
229 | then Available <$> singletonBF ix | 222 | then Available <$> singletonBF idx |
230 | else awaitEvent | 223 | else awaitEvent |
231 | 224 | ||
232 | go (RejectRequest ix) = do | 225 | go (RejectRequest _) = do |
233 | requireExtension ExtFast | 226 | requireExtension ExtFast |
234 | awaitMessage | 227 | awaitEvent |
235 | 228 | ||
236 | go (AllowedFast pix) = | 229 | go (AllowedFast _) = do |
237 | requireExtension ExtFast | 230 | requireExtension ExtFast |
238 | awaitMessage | 231 | awaitEvent |
239 | -} | 232 | |
240 | 233 | ||
241 | 234 | ||
242 | -- | | 235 | -- | |
@@ -251,7 +244,7 @@ awaitEvent = awaitMessage >>= go | |||
251 | -- @ | 244 | -- @ |
252 | -- | 245 | -- |
253 | yieldEvent :: Event -> P2P () | 246 | yieldEvent :: Event -> P2P () |
254 | yieldEvent (Available bf) = undefined | 247 | yieldEvent (Available _ ) = undefined |
255 | yieldEvent (Want bix) = do | 248 | yieldEvent (Want bix) = do |
256 | offer <- peerOffer | 249 | offer <- peerOffer |
257 | if ixPiece bix `BF.member` offer | 250 | if ixPiece bix `BF.member` offer |
diff --git a/src/Network/BitTorrent/Exchange/Protocol.hs b/src/Network/BitTorrent/Exchange/Protocol.hs index d2d3da6c..5ea104cc 100644 --- a/src/Network/BitTorrent/Exchange/Protocol.hs +++ b/src/Network/BitTorrent/Exchange/Protocol.hs | |||
@@ -220,9 +220,9 @@ instance Serialize BlockIx where | |||
220 | get = BlockIx <$> getInt <*> getInt <*> getInt | 220 | get = BlockIx <$> getInt <*> getInt <*> getInt |
221 | {-# INLINE get #-} | 221 | {-# INLINE get #-} |
222 | 222 | ||
223 | put ix = do putInt (ixPiece ix) | 223 | put i = do putInt (ixPiece i) |
224 | putInt (ixOffset ix) | 224 | putInt (ixOffset i) |
225 | putInt (ixLength ix) | 225 | putInt (ixLength i) |
226 | {-# INLINE put #-} | 226 | {-# INLINE put #-} |
227 | 227 | ||
228 | -- | Format block index in human readable form. | 228 | -- | Format block index in human readable form. |
@@ -277,11 +277,11 @@ blockRange pieceSize blk = (offset, offset + len) | |||
277 | {-# SPECIALIZE blockRange :: Int -> Block -> (Int64, Int64) #-} | 277 | {-# SPECIALIZE blockRange :: Int -> Block -> (Int64, Int64) #-} |
278 | 278 | ||
279 | ixRange :: (Num a, Integral a) => Int -> BlockIx -> (a, a) | 279 | ixRange :: (Num a, Integral a) => Int -> BlockIx -> (a, a) |
280 | ixRange pieceSize ix = (offset, offset + len) | 280 | ixRange pieceSize i = (offset, offset + len) |
281 | where | 281 | where |
282 | offset = fromIntegral pieceSize * fromIntegral (ixPiece ix) | 282 | offset = fromIntegral pieceSize * fromIntegral (ixPiece i) |
283 | + fromIntegral (ixOffset ix) | 283 | + fromIntegral (ixOffset i) |
284 | len = fromIntegral (ixLength ix) | 284 | len = fromIntegral (ixLength i) |
285 | {-# INLINE ixRange #-} | 285 | {-# INLINE ixRange #-} |
286 | {-# SPECIALIZE ixRange :: Int -> BlockIx -> (Int64, Int64) #-} | 286 | {-# SPECIALIZE ixRange :: Int -> BlockIx -> (Int64, Int64) #-} |
287 | 287 | ||
@@ -410,8 +410,8 @@ instance Serialize Message where | |||
410 | put HaveAll = putInt 1 >> putWord8 0x0E | 410 | put HaveAll = putInt 1 >> putWord8 0x0E |
411 | put HaveNone = putInt 1 >> putWord8 0x0F | 411 | put HaveNone = putInt 1 >> putWord8 0x0F |
412 | put (SuggestPiece pix) = putInt 5 >> putWord8 0x0D >> putInt pix | 412 | put (SuggestPiece pix) = putInt 5 >> putWord8 0x0D >> putInt pix |
413 | put (RejectRequest ix) = putInt 13 >> putWord8 0x10 >> put ix | 413 | put (RejectRequest i ) = putInt 13 >> putWord8 0x10 >> put i |
414 | put (AllowedFast ix) = putInt 5 >> putWord8 0x11 >> putInt ix | 414 | put (AllowedFast i ) = putInt 5 >> putWord8 0x11 >> putInt i |
415 | 415 | ||
416 | 416 | ||
417 | -- | Format messages in human readable form. Note that output is | 417 | -- | Format messages in human readable form. Note that output is |
@@ -421,9 +421,9 @@ instance Serialize Message where | |||
421 | ppMessage :: Message -> Doc | 421 | ppMessage :: Message -> Doc |
422 | ppMessage (Bitfield _) = "Bitfield" | 422 | ppMessage (Bitfield _) = "Bitfield" |
423 | ppMessage (Piece blk) = "Piece" <+> ppBlock blk | 423 | ppMessage (Piece blk) = "Piece" <+> ppBlock blk |
424 | ppMessage (Cancel ix) = "Cancel" <+> ppBlockIx ix | 424 | ppMessage (Cancel i ) = "Cancel" <+> ppBlockIx i |
425 | ppMessage (SuggestPiece pix) = "Suggest" <+> int pix | 425 | ppMessage (SuggestPiece pix) = "Suggest" <+> int pix |
426 | ppMessage (RejectRequest ix) = "Reject" <+> ppBlockIx ix | 426 | ppMessage (RejectRequest i ) = "Reject" <+> ppBlockIx i |
427 | ppMessage msg = text (show msg) | 427 | ppMessage msg = text (show msg) |
428 | 428 | ||
429 | {----------------------------------------------------------------------- | 429 | {----------------------------------------------------------------------- |
diff --git a/src/Network/BitTorrent/Internal.hs b/src/Network/BitTorrent/Internal.hs index a3e1a5cd..0355c147 100644 --- a/src/Network/BitTorrent/Internal.hs +++ b/src/Network/BitTorrent/Internal.hs | |||
@@ -133,7 +133,8 @@ getCurrentProgress = liftIO . readTVarIO . currentProgress | |||
133 | newClient :: [Extension] -> IO ClientSession | 133 | newClient :: [Extension] -> IO ClientSession |
134 | newClient exts = do | 134 | newClient exts = do |
135 | mgr <- Ev.new | 135 | mgr <- Ev.new |
136 | forkIO $ loop mgr | 136 | -- TODO kill this thread when leave client |
137 | _ <- forkIO $ loop mgr | ||
137 | 138 | ||
138 | ClientSession | 139 | ClientSession |
139 | <$> newPeerID | 140 | <$> newPeerID |
@@ -178,11 +179,8 @@ newLeacher :: ClientSession -> Torrent -> IO SwarmSession | |||
178 | newLeacher cs t @ Torrent {..} | 179 | newLeacher cs t @ Torrent {..} |
179 | = newSwarmSession (haveNone (pieceCount tInfo)) cs t | 180 | = newSwarmSession (haveNone (pieceCount tInfo)) cs t |
180 | 181 | ||
181 | isLeacher :: SwarmSession -> IO Bool | 182 | --isLeacher :: SwarmSession -> IO Bool |
182 | isLeacher = undefined | 183 | --isLeacher = undefined |
183 | |||
184 | getClientBitfield :: MonadIO m => SwarmSession -> m Bitfield | ||
185 | getClientBitfield = liftIO . readTVarIO . clientBitfield | ||
186 | 184 | ||
187 | {- | 185 | {- |
188 | haveDone :: MonadIO m => PieceIx -> SwarmSession -> m () | 186 | haveDone :: MonadIO m => PieceIx -> SwarmSession -> m () |
@@ -306,7 +304,7 @@ fullBF :: (MonadReader PeerSession m) => m Bitfield | |||
306 | fullBF = liftM haveAll getPieceCount | 304 | fullBF = liftM haveAll getPieceCount |
307 | 305 | ||
308 | singletonBF :: (MonadReader PeerSession m) => PieceIx -> m Bitfield | 306 | singletonBF :: (MonadReader PeerSession m) => PieceIx -> m Bitfield |
309 | singletonBF ix = liftM (BF.singleton ix) getPieceCount | 307 | singletonBF i = liftM (BF.singleton i) getPieceCount |
310 | 308 | ||
311 | adjustBF :: (MonadReader PeerSession m) => Bitfield -> m Bitfield | 309 | adjustBF :: (MonadReader PeerSession m) => Bitfield -> m Bitfield |
312 | adjustBF bf = (`adjustSize` bf) `liftM` getPieceCount | 310 | adjustBF bf = (`adjustSize` bf) `liftM` getPieceCount |
diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs index 11bc52de..c3bce63a 100644 --- a/src/Network/BitTorrent/Tracker.hs +++ b/src/Network/BitTorrent/Tracker.hs | |||
@@ -188,7 +188,7 @@ withTracker initProgress conn action = bracket start end (action . fst) | |||
188 | resp <- tryJust isIOException $ do | 188 | resp <- tryJust isIOException $ do |
189 | askTracker (regularReq defaultNumWant conn pr) | 189 | askTracker (regularReq defaultNumWant conn pr) |
190 | case resp of | 190 | case resp of |
191 | Right (ok @ OK {..}) -> do | 191 | Right (OK {..}) -> do |
192 | writeIORef seInterval respInterval | 192 | writeIORef seInterval respInterval |
193 | writeList2Chan sePeers respPeers | 193 | writeList2Chan sePeers respPeers |
194 | _ -> return () | 194 | _ -> return () |