From 07fb54d4844a7667dcef10527d0d3c010f851768 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sat, 13 Jul 2013 22:10:23 +0400 Subject: ~ Remove import Internal from Storage. --- src/Network/BitTorrent.hs | 9 +------ src/Network/BitTorrent/Internal.lhs | 12 ++++----- src/System/Torrent/Storage.hs | 54 ++++++++++++++++++------------------- 3 files changed, 32 insertions(+), 43 deletions(-) (limited to 'src') diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs index 06df77dd..acb3700c 100644 --- a/src/Network/BitTorrent.hs +++ b/src/Network/BitTorrent.hs @@ -37,13 +37,6 @@ module Network.BitTorrent , SessionCount , getSessionCount - -- * Storage - , Storage - , ppStorage - - , bindTo - , unbind - -- * Discovery , discover , exchange @@ -132,7 +125,7 @@ addTorrent clientSession loc @ TorrentLoc {..} = do -- when (bf is not full) swarm <- newLeecher clientSession torrent - storage <- swarm `bindTo` dataDirPath + storage <- openStorage (torrentMeta swarm) dataDirPath forkIO $ discover swarm $ do liftIO $ putStrLn "connected to peer" forever $ do diff --git a/src/Network/BitTorrent/Internal.lhs b/src/Network/BitTorrent/Internal.lhs index 5f6ad458..d30057f7 100644 --- a/src/Network/BitTorrent/Internal.lhs +++ b/src/Network/BitTorrent/Internal.lhs @@ -59,8 +59,6 @@ > , waitVacancy > , forkThrottle > -> , pieceLength -> > -- * Peer > , PeerSession( PeerSession, connectedPeerAddr > , swarmSession, enabledExtensions @@ -125,6 +123,7 @@ > import Network.BitTorrent.Exchange.Protocol as BT > import Network.BitTorrent.Tracker.Protocol as BT > import Network.BitTorrent.DHT.Protocol as BT +> import System.Torrent.Storage Progress ------------------------------------------------------------------------ @@ -499,6 +498,8 @@ Modify this carefully always updating global progress. > , clientBitfield :: !(TVar Bitfield) +-- > , storage :: Storage + We keep set of the all connected peers for the each particular torrent to prevent duplicated and therefore reduntant TCP connections. For example consider the following very simle and realistic scenario: @@ -576,10 +577,6 @@ INVARIANT: max_sessions_count - sizeof connectedPeers = value vacantPeers > getClientBitfield :: SwarmSession -> IO Bitfield > getClientBitfield = readTVarIO . clientBitfield -> pieceLength :: SwarmSession -> Int -> pieceLength = ciPieceLength . tInfo . torrentMeta -> {-# INLINE pieceLength #-} - > swarmHandshake :: SwarmSession -> Handshake > swarmHandshake SwarmSession {..} = Handshake { > hsProtocol = defaultBTProtocol @@ -857,7 +854,8 @@ messages & events we should send. > mark >> atomically broadcast > where > mark = do -> let bytes = pieceLength se * BF.haveCount bf +> let piLen = ciPieceLength $ tInfo $ torrentMeta +> let bytes = piLen * BF.haveCount bf > atomically $ do > modifyTVar' clientBitfield (BF.union bf) > modifyTVar' (currentProgress clientSession) (downloadedProgress bytes) diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs index 98cccccd..6a748fe3 100644 --- a/src/System/Torrent/Storage.hs +++ b/src/System/Torrent/Storage.hs @@ -23,7 +23,7 @@ module System.Torrent.Storage , ppStorage -- * Construction - , bindTo, unbind, withStorage + , openStorage, closeStorage, withStorage -- * Modification , getBlk, putBlk, selBlk @@ -45,13 +45,12 @@ import System.Directory import Data.Bitfield as BF import Data.Torrent import Network.BitTorrent.Exchange.Protocol -import Network.BitTorrent.Internal import System.IO.MMap.Fixed as Fixed data Storage = Storage { -- | - session :: !SwarmSession + metainfo:: !Torrent -- | , blocks :: !(TVar Bitfield) @@ -76,18 +75,16 @@ ppStorage Storage {..} = pp <$> readTVarIO blocks -----------------------------------------------------------------------} -- TODO doc args -bindTo :: SwarmSession -> FilePath -> IO Storage -bindTo se @ SwarmSession {..} contentPath = do - let contentInfo = tInfo torrentMeta - let content_paths = contentLayout contentPath contentInfo - mapM_ mkDir (L.map fst content_paths) - - let pieceLen = pieceLength se - let blockSize = min defaultBlockSize pieceLen - print $ "content length " ++ show (contentLength contentInfo) - Storage se <$> newTVarIO (haveNone (blockCount blockSize contentInfo)) - <*> pure blockSize - <*> coalesceFiles content_paths +openStorage :: Torrent -> FilePath -> IO Storage +openStorage t @ Torrent {..} contentPath = do + let content_paths = contentLayout contentPath tInfo + mapM_ (mkDir . fst) content_paths + + let blockSize = defaultBlockSize `min` ciPieceLength tInfo + print $ "content length " ++ show (contentLength tInfo) + Storage t <$> newTVarIO (haveNone (blockCount blockSize tInfo)) + <*> pure blockSize + <*> coalesceFiles content_paths where mkDir path = do let dirPath = fst (splitFileName path) @@ -95,12 +92,12 @@ bindTo se @ SwarmSession {..} contentPath = do unless exist $ do createDirectoryIfMissing True dirPath -unbind :: Storage -> IO () -unbind st = error "unmapStorage" +closeStorage :: Storage -> IO () +closeStorage st = error "closeStorage" -withStorage :: SwarmSession -> FilePath -> (Storage -> IO a) -> IO a -withStorage se path = bracket (se `bindTo` path) unbind +withStorage :: Torrent -> FilePath -> (Storage -> IO a) -> IO a +withStorage se path = bracket (openStorage se path) closeStorage {----------------------------------------------------------------------- Modification @@ -120,7 +117,7 @@ selBlk pix st @ Storage {..} mkBix ix = BlockIx pix (blockSize * (ix - offset)) blockSize offset = coeff * pix - coeff = pieceLength session `div` blockSize + coeff = ciPieceLength (tInfo metainfo) `div` blockSize -- -- TODO make global lock map -- otherwise we might get broken pieces @@ -143,14 +140,14 @@ putBlk blk @ Block {..} st @ Storage {..} -- let blkIx = undefined -- bm <- readTVarIO blocks -- unless (member blkIx bm) $ do - writeBytes (blkInterval (pieceLength session) blk) blkData payload + writeBytes (blkInterval (ciPieceLength (tInfo metainfo)) blk) blkData payload markBlock blk st validatePiece blkPiece st markBlock :: Block -> Storage -> IO () markBlock Block {..} Storage {..} = {-# SCC markBlock #-} do - let piLen = pieceLength session + let piLen = ciPieceLength (tInfo metainfo) let glIx = (piLen `div` blockSize) * blkPiece + (blkOffset `div` blockSize) atomically $ modifyTVar' blocks (have glIx) @@ -163,14 +160,15 @@ getBlk :: MonadIO m => BlockIx -> Storage -> m Block getBlk ix @ BlockIx {..} st @ Storage {..} = liftIO $ {-# SCC getBlk #-} do -- TODO check if __piece__ is available - bs <- readBytes (ixInterval (pieceLength session) ix) payload + let piLen = ciPieceLength (tInfo metainfo) + bs <- readBytes (ixInterval piLen ix) payload return $ Block ixPiece ixOffset bs getPiece :: PieceIx -> Storage -> IO ByteString getPiece pix st @ Storage {..} = {-# SCC getPiece #-} do - let pieceLen = pieceLength session - let bix = BlockIx pix 0 (pieceLength session) - let bs = viewBytes (ixInterval pieceLen bix) payload + let piLen = ciPieceLength (tInfo metainfo) + let bix = BlockIx pix 0 piLen + let bs = viewBytes (ixInterval piLen bix) payload return $! Lazy.toStrict bs resetPiece :: PieceIx -> Storage -> IO () @@ -186,7 +184,7 @@ validatePiece pix st @ Storage {..} = {-# SCC validatePiece #-} do else do print $ show pix ++ " downloaded" piece <- getPiece pix st - if checkPiece (tInfo (torrentMeta session)) pix piece + if checkPiece (tInfo metainfo) pix piece then return True else do print $ "----------------------------- invalid " ++ show pix @@ -218,7 +216,7 @@ pieceMask pix Storage {..} = do return $ BF.interval (totalCount bf) offset (offset + coeff - 1) where offset = coeff * pix - coeff = pieceLength session `div` blockSize + coeff = ciPieceLength (tInfo metainfo) `div` blockSize ixInterval :: Int -> BlockIx -> FixedInterval -- cgit v1.2.3