summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/BitTorrent.hs3
-rw-r--r--src/Network/BitTorrent/Exchange.hs47
-rw-r--r--src/Network/BitTorrent/Exchange/Protocol.hs22
-rw-r--r--src/Network/BitTorrent/Internal.hs12
-rw-r--r--src/Network/BitTorrent/Tracker.hs2
5 files changed, 37 insertions, 49 deletions
diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs
index 7ec0a067..85571470 100644
--- a/src/Network/BitTorrent.hs
+++ b/src/Network/BitTorrent.hs
@@ -29,12 +29,9 @@ module Network.BitTorrent
29 , awaitEvent, yieldEvent 29 , awaitEvent, yieldEvent
30 ) where 30 ) where
31 31
32import Control.Concurrent
33import Control.Exception 32import Control.Exception
34import Control.Monad 33import Control.Monad
35 34
36import Data.IORef
37
38import Network 35import Network
39 36
40import Data.Torrent 37import Data.Torrent
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
24import Control.Applicative 24import Control.Applicative
25import Control.Concurrent
26import Control.Concurrent.STM
27import Control.Exception 25import Control.Exception
28import Control.Lens 26import Control.Lens
29import Control.Monad.Reader 27import Control.Monad.Reader
30import Control.Monad.State
31import Control.Monad.Trans.Resource 28import Control.Monad.Trans.Resource
32 29
33import Data.IORef
34import Data.Function
35import Data.Ord
36import Data.Set as S
37
38import Data.Conduit as C 30import Data.Conduit as C
39import Data.Conduit.Cereal 31import Data.Conduit.Cereal
40import Data.Conduit.Network 32import Data.Conduit.Network
@@ -49,7 +41,6 @@ import Network.BitTorrent.Extension
49import Network.BitTorrent.Peer 41import Network.BitTorrent.Peer
50import Network.BitTorrent.Exchange.Protocol 42import Network.BitTorrent.Exchange.Protocol
51import Data.Bitfield as BF 43import Data.Bitfield as BF
52import Data.Torrent
53 44
54 45
55data Event = Available Bitfield 46data Event = Available Bitfield
@@ -74,7 +65,7 @@ runConduit sock p2p =
74awaitMessage :: P2P Message 65awaitMessage :: P2P Message
75awaitMessage = P2P (ReaderT go) 66awaitMessage = 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--
253yieldEvent :: Event -> P2P () 246yieldEvent :: Event -> P2P ()
254yieldEvent (Available bf) = undefined 247yieldEvent (Available _ ) = undefined
255yieldEvent (Want bix) = do 248yieldEvent (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
279ixRange :: (Num a, Integral a) => Int -> BlockIx -> (a, a) 279ixRange :: (Num a, Integral a) => Int -> BlockIx -> (a, a)
280ixRange pieceSize ix = (offset, offset + len) 280ixRange 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
421ppMessage :: Message -> Doc 421ppMessage :: Message -> Doc
422ppMessage (Bitfield _) = "Bitfield" 422ppMessage (Bitfield _) = "Bitfield"
423ppMessage (Piece blk) = "Piece" <+> ppBlock blk 423ppMessage (Piece blk) = "Piece" <+> ppBlock blk
424ppMessage (Cancel ix) = "Cancel" <+> ppBlockIx ix 424ppMessage (Cancel i ) = "Cancel" <+> ppBlockIx i
425ppMessage (SuggestPiece pix) = "Suggest" <+> int pix 425ppMessage (SuggestPiece pix) = "Suggest" <+> int pix
426ppMessage (RejectRequest ix) = "Reject" <+> ppBlockIx ix 426ppMessage (RejectRequest i ) = "Reject" <+> ppBlockIx i
427ppMessage msg = text (show msg) 427ppMessage 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
133newClient :: [Extension] -> IO ClientSession 133newClient :: [Extension] -> IO ClientSession
134newClient exts = do 134newClient 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
178newLeacher cs t @ Torrent {..} 179newLeacher cs t @ Torrent {..}
179 = newSwarmSession (haveNone (pieceCount tInfo)) cs t 180 = newSwarmSession (haveNone (pieceCount tInfo)) cs t
180 181
181isLeacher :: SwarmSession -> IO Bool 182--isLeacher :: SwarmSession -> IO Bool
182isLeacher = undefined 183--isLeacher = undefined
183
184getClientBitfield :: MonadIO m => SwarmSession -> m Bitfield
185getClientBitfield = liftIO . readTVarIO . clientBitfield
186 184
187{- 185{-
188haveDone :: MonadIO m => PieceIx -> SwarmSession -> m () 186haveDone :: MonadIO m => PieceIx -> SwarmSession -> m ()
@@ -306,7 +304,7 @@ fullBF :: (MonadReader PeerSession m) => m Bitfield
306fullBF = liftM haveAll getPieceCount 304fullBF = liftM haveAll getPieceCount
307 305
308singletonBF :: (MonadReader PeerSession m) => PieceIx -> m Bitfield 306singletonBF :: (MonadReader PeerSession m) => PieceIx -> m Bitfield
309singletonBF ix = liftM (BF.singleton ix) getPieceCount 307singletonBF i = liftM (BF.singleton i) getPieceCount
310 308
311adjustBF :: (MonadReader PeerSession m) => Bitfield -> m Bitfield 309adjustBF :: (MonadReader PeerSession m) => Bitfield -> m Bitfield
312adjustBF bf = (`adjustSize` bf) `liftM` getPieceCount 310adjustBF 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 ()