From 7b481af62313b184a30a5590528f0fd93229a5bc Mon Sep 17 00:00:00 2001 From: Sam T Date: Fri, 14 Jun 2013 21:36:48 +0400 Subject: ~ Specialize some functions for docs. --- src/Network/BitTorrent/Exchange.hs | 54 ++++++++++++++++++++++++-------------- src/Network/BitTorrent/Internal.hs | 15 +++-------- 2 files changed, 37 insertions(+), 32 deletions(-) diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs index 9b5a8535..0fd1d15a 100644 --- a/src/Network/BitTorrent/Exchange.hs +++ b/src/Network/BitTorrent/Exchange.hs @@ -11,6 +11,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} module Network.BitTorrent.Exchange ( -- * Block Block(..), BlockIx(..) @@ -35,14 +36,17 @@ import Control.Concurrent import Control.Lens import Control.Monad.Fork.Class import Control.Monad.Reader +import Control.Monad.State import Control.Monad.Trans.Resource +import Data.IORef import Data.Conduit as C import Data.Conduit.Cereal import Data.Conduit.Network import Data.Serialize as S import Text.PrettyPrint as PP hiding (($$)) + import Network @@ -75,10 +79,12 @@ runPeerWire sock p2p = awaitMessage :: P2P Message awaitMessage = P2P (ReaderT (const go)) where - go = await >>= maybe disconnect return + go = await >>= maybe (monadThrow PeerDisconnected) return +{-# INLINE awaitMessage #-} yieldMessage :: Message -> P2P () yieldMessage msg = P2P $ ReaderT $ \se -> C.yield msg +{-# INLINE yieldMessage #-} {----------------------------------------------------------------------- P2P monad @@ -97,6 +103,14 @@ newtype P2P a = P2P { , MonadIO, MonadThrow, MonadActive , MonadReader PeerSession ) + +instance MonadState SessionState P2P where + {-# SPECIALIZE instance MonadState SessionState P2P #-} + get = asks sessionState >>= liftIO . readIORef + {-# INLINE get #-} + put !s = asks sessionState >>= \ref -> liftIO $ writeIORef ref s + {-# INLINE put #-} + -- TODO instance for MonadFork runSession :: SwarmSession -> PeerAddr -> P2P () -> IO () @@ -134,50 +148,50 @@ chainP2P :: SwarmSession -> PeerConnection -> P2P () -> IO () -----------------------------------------------------------------------} -- | Terminate the current 'P2P' session. -disconnect :: MonadThrow m => m a +disconnect :: P2P a disconnect = monadThrow PeerDisconnected -- TODO handle all protocol details here so we can hide this from -- public interface | -protocolError :: MonadThrow m => Doc -> m a +protocolError :: Doc -> P2P a protocolError = monadThrow . ProtocolError {----------------------------------------------------------------------- Helpers -----------------------------------------------------------------------} --- | Count of client have pieces. -getHaveCount :: (MonadReader PeerSession m) => m PieceCount -getHaveCount = undefined +getClientBF :: P2P Bitfield +getClientBF = asks swarmSession >>= liftIO . getClientBitfield +{-# INLINE getClientBF #-} + +-- | Count of client /have/ pieces. +getHaveCount :: P2P PieceCount +getHaveCount = haveCount <$> getClientBF {-# INLINE getHaveCount #-} --- | Count of client do not have pieces. -getWantCount :: (MonadReader PeerSession m) => m PieceCount -getWantCount = undefined +-- | Count of client do not /have/ pieces. +getWantCount :: P2P PieceCount +getWantCount = totalCount <$> getClientBF {-# INLINE getWantCount #-} --- | Count of both have and want pieces. -getPieceCount :: (MonadReader PeerSession m) => m PieceCount +-- | Count of both /have/ and /want/ pieces. +getPieceCount :: P2P PieceCount getPieceCount = asks findPieceCount {-# INLINE getPieceCount #-} -- for internal use only -emptyBF :: (MonadReader PeerSession m) => m Bitfield +emptyBF :: P2P Bitfield emptyBF = liftM haveNone getPieceCount -fullBF :: (MonadReader PeerSession m) => m Bitfield +fullBF :: P2P Bitfield fullBF = liftM haveAll getPieceCount -singletonBF :: (MonadReader PeerSession m) => PieceIx -> m Bitfield +singletonBF :: PieceIx -> P2P Bitfield singletonBF i = liftM (BF.singleton i) getPieceCount -adjustBF :: (MonadReader PeerSession m) => Bitfield -> m Bitfield +adjustBF :: Bitfield -> P2P Bitfield adjustBF bf = (`adjustSize` bf) `liftM` getPieceCount -getClientBF :: (MonadIO m, MonadReader PeerSession m) => m Bitfield -getClientBF = asks swarmSession >>= liftIO . getClientBitfield - - peerWant :: P2P Bitfield peerWant = BF.difference <$> getClientBF <*> use bitfield @@ -332,7 +346,7 @@ awaitEvent = awaitMessage >>= go requireExtension ExtFast awaitEvent - +-- TODO minimized number of peerOffer calls -- | -- @ diff --git a/src/Network/BitTorrent/Internal.hs b/src/Network/BitTorrent/Internal.hs index 8ce7afbf..5ac58d46 100644 --- a/src/Network/BitTorrent/Internal.hs +++ b/src/Network/BitTorrent/Internal.hs @@ -56,6 +56,7 @@ module Network.BitTorrent.Internal -- * Peer , PeerSession( PeerSession, connectedPeerAddr , swarmSession, enabledExtensions + , sessionState ) , SessionState , withPeerSession @@ -352,7 +353,8 @@ waitVacancy se = Peer session -----------------------------------------------------------------------} --- | Peer session contain all data necessary for peer to peer communication. +-- | Peer session contain all data necessary for peer to peer +-- communication. data PeerSession = PeerSession { -- | Used as unique 'PeerSession' identifier within one -- 'SwarmSession'. @@ -409,17 +411,6 @@ instance Eq PeerSession where instance Ord PeerSession where compare = comparing connectedPeerAddr -instance (MonadIO m, MonadReader PeerSession m) - => MonadState SessionState m where - get = do - ref <- asks sessionState - st <- liftIO (readIORef ref) - liftIO $ print (completeness (_bitfield st)) - return st - - put !s = asks sessionState >>= \ref -> liftIO $ writeIORef ref s - - -- | Exceptions used to interrupt the current P2P session. This -- exceptions will NOT affect other P2P sessions, DHT, peer <-> -- tracker, or any other session. -- cgit v1.2.3