summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Network/BitTorrent/Exchange.hs71
-rw-r--r--src/Network/BitTorrent/Exchange/Protocol.hs44
-rw-r--r--src/Network/BitTorrent/Internal.hs3
3 files changed, 58 insertions, 60 deletions
diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs
index 2173cf8b..dda7d304 100644
--- a/src/Network/BitTorrent/Exchange.hs
+++ b/src/Network/BitTorrent/Exchange.hs
@@ -60,10 +60,11 @@ waitMessage se = do
60 Nothing -> waitMessage se 60 Nothing -> waitMessage se
61 Just msg -> do 61 Just msg -> do
62 liftIO $ updateIncoming se 62 liftIO $ updateIncoming se
63 liftIO $ print msg
63 return msg 64 return msg
64 65
65signalMessage :: Message -> PeerSession -> PeerWire () 66signalMessage :: PeerSession -> Message -> PeerWire ()
66signalMessage msg se = do 67signalMessage se msg = do
67 C.yield msg 68 C.yield msg
68 liftIO $ updateOutcoming se 69 liftIO $ updateOutcoming se
69 70
@@ -71,58 +72,75 @@ signalMessage msg se = do
71getPieceCount :: PeerSession -> IO PieceCount 72getPieceCount :: PeerSession -> IO PieceCount
72getPieceCount = undefined 73getPieceCount = undefined
73 74
75canOffer :: PeerSession -> PeerWire Bitfield
76canOffer PeerSession {..} = liftIO $ do
77 pbf <- readIORef $ peerBitfield
78 cbf <- readIORef $ clientBitfield $ swarmSession
79 return $ BF.difference pbf cbf
80
81revise :: PeerSession -> PeerWire ()
82revise se @ PeerSession {..} = do
83 isInteresting <- (not . BF.null) <$> canOffer se
84 SessionStatus {..} <- liftIO $ readIORef peerSessionStatus
85
86 when (isInteresting /= _interested seClientStatus) $
87 signalMessage se $ if isInteresting then Interested else NotInterested
88
89
74nextEvent :: PeerSession -> PeerWire Event 90nextEvent :: PeerSession -> PeerWire Event
75nextEvent se @ PeerSession {..} = waitMessage se >>= diff 91nextEvent se @ PeerSession {..} = waitMessage se >>= go
76 where 92 where
77 -- diff finds difference between 93 go KeepAlive = nextEvent se
78-- diff KeepAlive = nextEvent se 94 go Choke = do
79 diff msg = do
80 liftIO $ print (ppMessage msg)
81 nextEvent se
82
83 handleMessage Choke = do
84 SessionStatus {..} <- liftIO $ readIORef peerSessionStatus 95 SessionStatus {..} <- liftIO $ readIORef peerSessionStatus
85 if psChoking sePeerStatus 96 if _choking sePeerStatus
86 then nextEvent se 97 then nextEvent se
87 else undefined 98 else undefined
88 99
89 handleMessage Unchoke = undefined 100 go Unchoke = do
101 SessionStatus {..} <- liftIO $ readIORef peerSessionStatus
102 if not (_choking sePeerStatus)
103 then nextEvent se
104 else if undefined
105 then undefined
106 else undefined
90 --return $ Available BF.difference 107 --return $ Available BF.difference
91 108
92 handleMessage Interested = return undefined 109 go Interested = return undefined
93 handleMessage NotInterested = return undefined 110 go NotInterested = return undefined
94 handleMessage (Have ix) = do 111
112 go (Have ix) = do
95 pc <- liftIO $ getPieceCount se 113 pc <- liftIO $ getPieceCount se
96 haveMessage $ have ix (haveNone pc) -- TODO singleton 114 haveMessage $ have ix (haveNone pc) -- TODO singleton
97 115
98 handleMessage (Bitfield bf) = undefined 116 go (Bitfield bf) = undefined
99 handleMessage (Request bix) = do 117 go (Request bix) = do
100 undefined 118 undefined
101 119
102 handleMessage msg @ (Piece blk) = undefined 120 go msg @ (Piece blk) = undefined
103 handleMessage msg @ (Port _) 121 go msg @ (Port _)
104 = checkExtension msg ExtDHT $ do 122 = checkExtension msg ExtDHT $ do
105 undefined 123 undefined
106 124
107 handleMessage msg @ HaveAll 125 go msg @ HaveAll
108 = checkExtension msg ExtFast $ do 126 = checkExtension msg ExtFast $ do
109 pc <- liftIO $ getPieceCount se 127 pc <- liftIO $ getPieceCount se
110 haveMessage (haveAll pc) 128 haveMessage (haveAll pc)
111 129
112 handleMessage msg @ HaveNone 130 go msg @ HaveNone
113 = checkExtension msg ExtFast $ do 131 = checkExtension msg ExtFast $ do
114 pc <- liftIO $ getPieceCount se 132 pc <- liftIO $ getPieceCount se
115 haveMessage (haveNone pc) 133 haveMessage (haveNone pc)
116 134
117 handleMessage msg @ (SuggestPiece ix) 135 go msg @ (SuggestPiece ix)
118 = checkExtension msg ExtFast $ do 136 = checkExtension msg ExtFast $ do
119 undefined 137 undefined
120 138
121 handleMessage msg @ (RejectRequest ix) 139 go msg @ (RejectRequest ix)
122 = checkExtension msg ExtFast $ do 140 = checkExtension msg ExtFast $ do
123 undefined 141 undefined
124 142
125 handleMessage msg @ (AllowedFast pix) 143 go msg @ (AllowedFast pix)
126 = checkExtension msg ExtFast $ do 144 = checkExtension msg ExtFast $ do
127 undefined 145 undefined
128 146
@@ -148,7 +166,10 @@ newtype P2P a = P2P {
148 runP2P :: ReaderT PeerSession PeerWire a 166 runP2P :: ReaderT PeerSession PeerWire a
149 } deriving (Monad, MonadReader PeerSession, MonadIO) 167 } deriving (Monad, MonadReader PeerSession, MonadIO)
150 168
151instance MonadState Bitfield P2P where 169instance MonadState SessionStatus P2P where
170 get = asks peerSessionStatus >>= liftIO . readIORef
171 put x = asks peerSessionStatus >>= liftIO . (`writeIORef` x)
172
152 173
153runConduit :: Socket -> Conduit Message IO Message -> IO () 174runConduit :: Socket -> Conduit Message IO Message -> IO ()
154runConduit sock p2p = 175runConduit sock p2p =
diff --git a/src/Network/BitTorrent/Exchange/Protocol.hs b/src/Network/BitTorrent/Exchange/Protocol.hs
index dc25a9c9..46e25fa3 100644
--- a/src/Network/BitTorrent/Exchange/Protocol.hs
+++ b/src/Network/BitTorrent/Exchange/Protocol.hs
@@ -51,16 +51,9 @@ module Network.BitTorrent.Exchange.Protocol
51 , ppMessage 51 , ppMessage
52 52
53 -- * Exchange control 53 -- * Exchange control
54 -- ** Peer status
55 , PeerStatus(..) 54 , PeerStatus(..)
56 , setChoking, setInterested
57 , initPeerStatus
58
59 -- ** Session status
60 , SessionStatus(..) 55 , SessionStatus(..)
61 , initSessionStatus 56-- , canUpload, canDownload
62 , setClientStatus, setPeerStatus
63 , canUpload, canDownload
64 57
65 -- ** Defaults 58 -- ** Defaults
66 , defaultUnchokeSlots 59 , defaultUnchokeSlots
@@ -73,6 +66,7 @@ import Data.ByteString (ByteString)
73import qualified Data.ByteString as B 66import qualified Data.ByteString as B
74import qualified Data.ByteString.Char8 as BC 67import qualified Data.ByteString.Char8 as BC
75import qualified Data.ByteString.Lazy as Lazy 68import qualified Data.ByteString.Lazy as Lazy
69import Data.Default
76import Data.Serialize as S 70import Data.Serialize as S
77import Data.Int 71import Data.Int
78import Data.Word 72import Data.Word
@@ -429,21 +423,12 @@ ppMessage msg = text (show msg)
429 423
430-- | 424-- |
431data PeerStatus = PeerStatus { 425data PeerStatus = PeerStatus {
432 psChoking :: Bool 426 _choking :: Bool
433 , psInterested :: Bool 427 , _interested :: Bool
434 } 428 }
435 429
436-- | Any session between peers starts as choking and not interested. 430instance Default PeerStatus where
437initPeerStatus :: PeerStatus 431 def = PeerStatus True False
438initPeerStatus = PeerStatus True False
439
440-- | Update choking field.
441setChoking :: Bool -> PeerStatus -> PeerStatus
442setChoking b ps = ps { psChoking = b }
443
444-- | Update interested field.
445setInterested :: Bool -> PeerStatus -> PeerStatus
446setInterested b ps = ps { psInterested = b }
447 432
448-- | 433-- |
449data SessionStatus = SessionStatus { 434data SessionStatus = SessionStatus {
@@ -451,20 +436,10 @@ data SessionStatus = SessionStatus {
451 , sePeerStatus :: PeerStatus 436 , sePeerStatus :: PeerStatus
452 } 437 }
453 438
454-- | Initial session status after two peers handshaked. 439instance Default SessionStatus where
455initSessionStatus :: SessionStatus 440 def = SessionStatus def def
456initSessionStatus = SessionStatus initPeerStatus initPeerStatus
457
458-- | Update client status.
459setClientStatus :: (PeerStatus -> PeerStatus)
460 -> SessionStatus -> SessionStatus
461setClientStatus f ss = ss { seClientStatus = f (seClientStatus ss) }
462
463-- | Update peer status.
464setPeerStatus :: (PeerStatus -> PeerStatus)
465 -> SessionStatus -> SessionStatus
466setPeerStatus f ss = ss { sePeerStatus = f (sePeerStatus ss) }
467 441
442{-
468-- | Can the /client/ to upload to the /peer/? 443-- | Can the /client/ to upload to the /peer/?
469canUpload :: SessionStatus -> Bool 444canUpload :: SessionStatus -> Bool
470canUpload SessionStatus {..} 445canUpload SessionStatus {..}
@@ -474,6 +449,7 @@ canUpload SessionStatus {..}
474canDownload :: SessionStatus -> Bool 449canDownload :: SessionStatus -> Bool
475canDownload SessionStatus {..} 450canDownload SessionStatus {..}
476 = psInterested seClientStatus && not (psChoking sePeerStatus) 451 = psInterested seClientStatus && not (psChoking sePeerStatus)
452-}
477 453
478-- | Indicates how many peers are allowed to download from the client 454-- | Indicates how many peers are allowed to download from the client
479-- by default. 455-- by default.
diff --git a/src/Network/BitTorrent/Internal.hs b/src/Network/BitTorrent/Internal.hs
index 91dc35d5..38087f0d 100644
--- a/src/Network/BitTorrent/Internal.hs
+++ b/src/Network/BitTorrent/Internal.hs
@@ -27,6 +27,7 @@ import Control.Concurrent.STM
27import Control.Exception 27import Control.Exception
28 28
29import Data.IORef 29import Data.IORef
30import Data.Default
30import Data.Function 31import Data.Function
31import Data.Ord 32import Data.Ord
32import Data.Set as S 33import Data.Set as S
@@ -196,7 +197,7 @@ withPeerSession ss @ SwarmSession {..} addr
196 maxOutcomingTime (sendKA sock) 197 maxOutcomingTime (sendKA sock)
197 <*> newChan 198 <*> newChan
198 <*> pure clientBitfield 199 <*> pure clientBitfield
199 <*> newIORef initSessionStatus 200 <*> newIORef def
200 return (sock, ps) 201 return (sock, ps)
201 202
202 closeSession = close . fst 203 closeSession = close . fst