summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Network/BitTorrent.hs9
-rw-r--r--src/Network/BitTorrent/Internal.lhs12
-rw-r--r--src/System/Torrent/Storage.hs54
3 files changed, 32 insertions, 43 deletions
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
37 , SessionCount 37 , SessionCount
38 , getSessionCount 38 , getSessionCount
39 39
40 -- * Storage
41 , Storage
42 , ppStorage
43
44 , bindTo
45 , unbind
46
47 -- * Discovery 40 -- * Discovery
48 , discover 41 , discover
49 , exchange 42 , exchange
@@ -132,7 +125,7 @@ addTorrent clientSession loc @ TorrentLoc {..} = do
132-- when (bf is not full) 125-- when (bf is not full)
133 126
134 swarm <- newLeecher clientSession torrent 127 swarm <- newLeecher clientSession torrent
135 storage <- swarm `bindTo` dataDirPath 128 storage <- openStorage (torrentMeta swarm) dataDirPath
136 forkIO $ discover swarm $ do 129 forkIO $ discover swarm $ do
137 liftIO $ putStrLn "connected to peer" 130 liftIO $ putStrLn "connected to peer"
138 forever $ do 131 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 @@
59> , waitVacancy 59> , waitVacancy
60> , forkThrottle 60> , forkThrottle
61> 61>
62> , pieceLength
63>
64> -- * Peer 62> -- * Peer
65> , PeerSession( PeerSession, connectedPeerAddr 63> , PeerSession( PeerSession, connectedPeerAddr
66> , swarmSession, enabledExtensions 64> , swarmSession, enabledExtensions
@@ -125,6 +123,7 @@
125> import Network.BitTorrent.Exchange.Protocol as BT 123> import Network.BitTorrent.Exchange.Protocol as BT
126> import Network.BitTorrent.Tracker.Protocol as BT 124> import Network.BitTorrent.Tracker.Protocol as BT
127> import Network.BitTorrent.DHT.Protocol as BT 125> import Network.BitTorrent.DHT.Protocol as BT
126> import System.Torrent.Storage
128 127
129Progress 128Progress
130------------------------------------------------------------------------ 129------------------------------------------------------------------------
@@ -499,6 +498,8 @@ Modify this carefully always updating global progress.
499 498
500> , clientBitfield :: !(TVar Bitfield) 499> , clientBitfield :: !(TVar Bitfield)
501 500
501-- > , storage :: Storage
502
502We keep set of the all connected peers for the each particular torrent 503We keep set of the all connected peers for the each particular torrent
503to prevent duplicated and therefore reduntant TCP connections. For 504to prevent duplicated and therefore reduntant TCP connections. For
504example consider the following very simle and realistic scenario: 505example consider the following very simle and realistic scenario:
@@ -576,10 +577,6 @@ INVARIANT: max_sessions_count - sizeof connectedPeers = value vacantPeers
576> getClientBitfield :: SwarmSession -> IO Bitfield 577> getClientBitfield :: SwarmSession -> IO Bitfield
577> getClientBitfield = readTVarIO . clientBitfield 578> getClientBitfield = readTVarIO . clientBitfield
578 579
579> pieceLength :: SwarmSession -> Int
580> pieceLength = ciPieceLength . tInfo . torrentMeta
581> {-# INLINE pieceLength #-}
582
583> swarmHandshake :: SwarmSession -> Handshake 580> swarmHandshake :: SwarmSession -> Handshake
584> swarmHandshake SwarmSession {..} = Handshake { 581> swarmHandshake SwarmSession {..} = Handshake {
585> hsProtocol = defaultBTProtocol 582> hsProtocol = defaultBTProtocol
@@ -857,7 +854,8 @@ messages & events we should send.
857> mark >> atomically broadcast 854> mark >> atomically broadcast
858> where 855> where
859> mark = do 856> mark = do
860> let bytes = pieceLength se * BF.haveCount bf 857> let piLen = ciPieceLength $ tInfo $ torrentMeta
858> let bytes = piLen * BF.haveCount bf
861> atomically $ do 859> atomically $ do
862> modifyTVar' clientBitfield (BF.union bf) 860> modifyTVar' clientBitfield (BF.union bf)
863> modifyTVar' (currentProgress clientSession) (downloadedProgress bytes) 861> 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
23 , ppStorage 23 , ppStorage
24 24
25 -- * Construction 25 -- * Construction
26 , bindTo, unbind, withStorage 26 , openStorage, closeStorage, withStorage
27 27
28 -- * Modification 28 -- * Modification
29 , getBlk, putBlk, selBlk 29 , getBlk, putBlk, selBlk
@@ -45,13 +45,12 @@ import System.Directory
45import Data.Bitfield as BF 45import Data.Bitfield as BF
46import Data.Torrent 46import Data.Torrent
47import Network.BitTorrent.Exchange.Protocol 47import Network.BitTorrent.Exchange.Protocol
48import Network.BitTorrent.Internal
49import System.IO.MMap.Fixed as Fixed 48import System.IO.MMap.Fixed as Fixed
50 49
51 50
52data Storage = Storage { 51data Storage = Storage {
53 -- | 52 -- |
54 session :: !SwarmSession 53 metainfo:: !Torrent
55 54
56 -- | 55 -- |
57 , blocks :: !(TVar Bitfield) 56 , blocks :: !(TVar Bitfield)
@@ -76,18 +75,16 @@ ppStorage Storage {..} = pp <$> readTVarIO blocks
76-----------------------------------------------------------------------} 75-----------------------------------------------------------------------}
77 76
78-- TODO doc args 77-- TODO doc args
79bindTo :: SwarmSession -> FilePath -> IO Storage 78openStorage :: Torrent -> FilePath -> IO Storage
80bindTo se @ SwarmSession {..} contentPath = do 79openStorage t @ Torrent {..} contentPath = do
81 let contentInfo = tInfo torrentMeta 80 let content_paths = contentLayout contentPath tInfo
82 let content_paths = contentLayout contentPath contentInfo 81 mapM_ (mkDir . fst) content_paths
83 mapM_ mkDir (L.map fst content_paths) 82
84 83 let blockSize = defaultBlockSize `min` ciPieceLength tInfo
85 let pieceLen = pieceLength se 84 print $ "content length " ++ show (contentLength tInfo)
86 let blockSize = min defaultBlockSize pieceLen 85 Storage t <$> newTVarIO (haveNone (blockCount blockSize tInfo))
87 print $ "content length " ++ show (contentLength contentInfo) 86 <*> pure blockSize
88 Storage se <$> newTVarIO (haveNone (blockCount blockSize contentInfo)) 87 <*> coalesceFiles content_paths
89 <*> pure blockSize
90 <*> coalesceFiles content_paths
91 where 88 where
92 mkDir path = do 89 mkDir path = do
93 let dirPath = fst (splitFileName path) 90 let dirPath = fst (splitFileName path)
@@ -95,12 +92,12 @@ bindTo se @ SwarmSession {..} contentPath = do
95 unless exist $ do 92 unless exist $ do
96 createDirectoryIfMissing True dirPath 93 createDirectoryIfMissing True dirPath
97 94
98unbind :: Storage -> IO () 95closeStorage :: Storage -> IO ()
99unbind st = error "unmapStorage" 96closeStorage st = error "closeStorage"
100 97
101 98
102withStorage :: SwarmSession -> FilePath -> (Storage -> IO a) -> IO a 99withStorage :: Torrent -> FilePath -> (Storage -> IO a) -> IO a
103withStorage se path = bracket (se `bindTo` path) unbind 100withStorage se path = bracket (openStorage se path) closeStorage
104 101
105{----------------------------------------------------------------------- 102{-----------------------------------------------------------------------
106 Modification 103 Modification
@@ -120,7 +117,7 @@ selBlk pix st @ Storage {..}
120 mkBix ix = BlockIx pix (blockSize * (ix - offset)) blockSize 117 mkBix ix = BlockIx pix (blockSize * (ix - offset)) blockSize
121 118
122 offset = coeff * pix 119 offset = coeff * pix
123 coeff = pieceLength session `div` blockSize 120 coeff = ciPieceLength (tInfo metainfo) `div` blockSize
124 121
125-- 122--
126-- TODO make global lock map -- otherwise we might get broken pieces 123-- TODO make global lock map -- otherwise we might get broken pieces
@@ -143,14 +140,14 @@ putBlk blk @ Block {..} st @ Storage {..}
143-- let blkIx = undefined 140-- let blkIx = undefined
144-- bm <- readTVarIO blocks 141-- bm <- readTVarIO blocks
145-- unless (member blkIx bm) $ do 142-- unless (member blkIx bm) $ do
146 writeBytes (blkInterval (pieceLength session) blk) blkData payload 143 writeBytes (blkInterval (ciPieceLength (tInfo metainfo)) blk) blkData payload
147 144
148 markBlock blk st 145 markBlock blk st
149 validatePiece blkPiece st 146 validatePiece blkPiece st
150 147
151markBlock :: Block -> Storage -> IO () 148markBlock :: Block -> Storage -> IO ()
152markBlock Block {..} Storage {..} = {-# SCC markBlock #-} do 149markBlock Block {..} Storage {..} = {-# SCC markBlock #-} do
153 let piLen = pieceLength session 150 let piLen = ciPieceLength (tInfo metainfo)
154 let glIx = (piLen `div` blockSize) * blkPiece + (blkOffset `div` blockSize) 151 let glIx = (piLen `div` blockSize) * blkPiece + (blkOffset `div` blockSize)
155 atomically $ modifyTVar' blocks (have glIx) 152 atomically $ modifyTVar' blocks (have glIx)
156 153
@@ -163,14 +160,15 @@ getBlk :: MonadIO m => BlockIx -> Storage -> m Block
163getBlk ix @ BlockIx {..} st @ Storage {..} 160getBlk ix @ BlockIx {..} st @ Storage {..}
164 = liftIO $ {-# SCC getBlk #-} do 161 = liftIO $ {-# SCC getBlk #-} do
165 -- TODO check if __piece__ is available 162 -- TODO check if __piece__ is available
166 bs <- readBytes (ixInterval (pieceLength session) ix) payload 163 let piLen = ciPieceLength (tInfo metainfo)
164 bs <- readBytes (ixInterval piLen ix) payload
167 return $ Block ixPiece ixOffset bs 165 return $ Block ixPiece ixOffset bs
168 166
169getPiece :: PieceIx -> Storage -> IO ByteString 167getPiece :: PieceIx -> Storage -> IO ByteString
170getPiece pix st @ Storage {..} = {-# SCC getPiece #-} do 168getPiece pix st @ Storage {..} = {-# SCC getPiece #-} do
171 let pieceLen = pieceLength session 169 let piLen = ciPieceLength (tInfo metainfo)
172 let bix = BlockIx pix 0 (pieceLength session) 170 let bix = BlockIx pix 0 piLen
173 let bs = viewBytes (ixInterval pieceLen bix) payload 171 let bs = viewBytes (ixInterval piLen bix) payload
174 return $! Lazy.toStrict bs 172 return $! Lazy.toStrict bs
175 173
176resetPiece :: PieceIx -> Storage -> IO () 174resetPiece :: PieceIx -> Storage -> IO ()
@@ -186,7 +184,7 @@ validatePiece pix st @ Storage {..} = {-# SCC validatePiece #-} do
186 else do 184 else do
187 print $ show pix ++ " downloaded" 185 print $ show pix ++ " downloaded"
188 piece <- getPiece pix st 186 piece <- getPiece pix st
189 if checkPiece (tInfo (torrentMeta session)) pix piece 187 if checkPiece (tInfo metainfo) pix piece
190 then return True 188 then return True
191 else do 189 else do
192 print $ "----------------------------- invalid " ++ show pix 190 print $ "----------------------------- invalid " ++ show pix
@@ -218,7 +216,7 @@ pieceMask pix Storage {..} = do
218 return $ BF.interval (totalCount bf) offset (offset + coeff - 1) 216 return $ BF.interval (totalCount bf) offset (offset + coeff - 1)
219 where 217 where
220 offset = coeff * pix 218 offset = coeff * pix
221 coeff = pieceLength session `div` blockSize 219 coeff = ciPieceLength (tInfo metainfo) `div` blockSize
222 220
223 221
224ixInterval :: Int -> BlockIx -> FixedInterval 222ixInterval :: Int -> BlockIx -> FixedInterval