summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/Exchange.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/Exchange.hs')
-rw-r--r--src/Network/BitTorrent/Exchange.hs45
1 files changed, 44 insertions, 1 deletions
diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs
index 98b19357..9b5a8535 100644
--- a/src/Network/BitTorrent/Exchange.hs
+++ b/src/Network/BitTorrent/Exchange.hs
@@ -10,6 +10,7 @@
10{-# LANGUAGE GeneralizedNewtypeDeriving #-} 10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE MultiParamTypeClasses #-} 11{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE RecordWildCards #-} 12{-# LANGUAGE RecordWildCards #-}
13{-# LANGUAGE FlexibleContexts #-}
13module Network.BitTorrent.Exchange 14module Network.BitTorrent.Exchange
14 ( -- * Block 15 ( -- * Block
15 Block(..), BlockIx(..) 16 Block(..), BlockIx(..)
@@ -22,6 +23,10 @@ module Network.BitTorrent.Exchange
22 , awaitEvent, yieldEvent 23 , awaitEvent, yieldEvent
23 24
24 , disconnect, protocolError 25 , disconnect, protocolError
26
27 , getHaveCount
28 , getWantCount
29 , getPieceCount
25 ) where 30 ) where
26 31
27import Control.Applicative 32import Control.Applicative
@@ -128,9 +133,12 @@ chainP2P :: SwarmSession -> PeerConnection -> P2P () -> IO ()
128 Exceptions 133 Exceptions
129-----------------------------------------------------------------------} 134-----------------------------------------------------------------------}
130 135
136-- | Terminate the current 'P2P' session.
131disconnect :: MonadThrow m => m a 137disconnect :: MonadThrow m => m a
132disconnect = monadThrow PeerDisconnected 138disconnect = monadThrow PeerDisconnected
133 139
140-- TODO handle all protocol details here so we can hide this from
141-- public interface |
134protocolError :: MonadThrow m => Doc -> m a 142protocolError :: MonadThrow m => Doc -> m a
135protocolError = monadThrow . ProtocolError 143protocolError = monadThrow . ProtocolError
136 144
@@ -138,7 +146,40 @@ protocolError = monadThrow . ProtocolError
138 Helpers 146 Helpers
139-----------------------------------------------------------------------} 147-----------------------------------------------------------------------}
140 148
141peerWant :: P2P Bitfield 149-- | Count of client have pieces.
150getHaveCount :: (MonadReader PeerSession m) => m PieceCount
151getHaveCount = undefined
152{-# INLINE getHaveCount #-}
153
154-- | Count of client do not have pieces.
155getWantCount :: (MonadReader PeerSession m) => m PieceCount
156getWantCount = undefined
157{-# INLINE getWantCount #-}
158
159-- | Count of both have and want pieces.
160getPieceCount :: (MonadReader PeerSession m) => m PieceCount
161getPieceCount = asks findPieceCount
162{-# INLINE getPieceCount #-}
163
164-- for internal use only
165emptyBF :: (MonadReader PeerSession m) => m Bitfield
166emptyBF = liftM haveNone getPieceCount
167
168fullBF :: (MonadReader PeerSession m) => m Bitfield
169fullBF = liftM haveAll getPieceCount
170
171singletonBF :: (MonadReader PeerSession m) => PieceIx -> m Bitfield
172singletonBF i = liftM (BF.singleton i) getPieceCount
173
174adjustBF :: (MonadReader PeerSession m) => Bitfield -> m Bitfield
175adjustBF bf = (`adjustSize` bf) `liftM` getPieceCount
176
177getClientBF :: (MonadIO m, MonadReader PeerSession m) => m Bitfield
178getClientBF = asks swarmSession >>= liftIO . getClientBitfield
179
180
181
182peerWant :: P2P Bitfield
142peerWant = BF.difference <$> getClientBF <*> use bitfield 183peerWant = BF.difference <$> getClientBF <*> use bitfield
143 184
144clientWant :: P2P Bitfield 185clientWant :: P2P Bitfield
@@ -154,6 +195,8 @@ clientOffer = do
154 sessionStatus <- use status 195 sessionStatus <- use status
155 if canUpload sessionStatus then peerWant else emptyBF 196 if canUpload sessionStatus then peerWant else emptyBF
156 197
198
199
157revise :: P2P Bitfield 200revise :: P2P Bitfield
158revise = do 201revise = do
159 want <- clientWant 202 want <- clientWant