diff options
Diffstat (limited to 'src/System/Torrent/Storage.hs')
-rw-r--r-- | src/System/Torrent/Storage.hs | 18 |
1 files changed, 11 insertions, 7 deletions
diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs index cb0494e8..8a884196 100644 --- a/src/System/Torrent/Storage.hs +++ b/src/System/Torrent/Storage.hs | |||
@@ -110,7 +110,8 @@ withStorage se path = bracket (se `bindTo` path) unbind | |||
110 | -- TODO make block_payload :: Lazy.ByteString | 110 | -- TODO make block_payload :: Lazy.ByteString |
111 | 111 | ||
112 | selBlk :: MonadIO m => PieceIx -> Storage -> m [BlockIx] | 112 | selBlk :: MonadIO m => PieceIx -> Storage -> m [BlockIx] |
113 | selBlk pix st @ Storage {..} = liftIO $ atomically $ do | 113 | selBlk pix st @ Storage {..} |
114 | = liftIO $ {-# SCC selBlk #-} atomically $ do | ||
114 | mask <- pieceMask pix st | 115 | mask <- pieceMask pix st |
115 | select mask <$> readTVar blocks | 116 | select mask <$> readTVar blocks |
116 | where | 117 | where |
@@ -137,7 +138,8 @@ selBlk pix st @ Storage {..} = liftIO $ atomically $ do | |||
137 | -- | 138 | -- |
138 | -- | 139 | -- |
139 | putBlk :: MonadIO m => Block -> Storage -> m Bool | 140 | putBlk :: MonadIO m => Block -> Storage -> m Bool |
140 | putBlk blk @ Block {..} st @ Storage {..} = liftIO $ do | 141 | putBlk blk @ Block {..} st @ Storage {..} |
142 | = liftIO $ {-# SCC putBlk #-} do | ||
141 | -- let blkIx = undefined | 143 | -- let blkIx = undefined |
142 | -- bm <- readTVarIO blocks | 144 | -- bm <- readTVarIO blocks |
143 | -- unless (member blkIx bm) $ do | 145 | -- unless (member blkIx bm) $ do |
@@ -149,7 +151,7 @@ putBlk blk @ Block {..} st @ Storage {..} = liftIO $ do | |||
149 | validatePiece blkPiece st | 151 | validatePiece blkPiece st |
150 | 152 | ||
151 | markBlock :: Block -> Storage -> IO () | 153 | markBlock :: Block -> Storage -> IO () |
152 | markBlock Block {..} Storage {..} = do | 154 | markBlock Block {..} Storage {..} = {-# SCC markBlock #-} do |
153 | let piLen = pieceLength session | 155 | let piLen = pieceLength session |
154 | let glIx = (piLen `div` blockSize) * blkPiece + (blkOffset `div` blockSize) | 156 | let glIx = (piLen `div` blockSize) * blkPiece + (blkOffset `div` blockSize) |
155 | atomically $ modifyTVar' blocks (have glIx) | 157 | atomically $ modifyTVar' blocks (have glIx) |
@@ -160,25 +162,27 @@ markBlock Block {..} Storage {..} = do | |||
160 | -- Do not block. | 162 | -- Do not block. |
161 | -- | 163 | -- |
162 | getBlk :: MonadIO m => BlockIx -> Storage -> m Block | 164 | getBlk :: MonadIO m => BlockIx -> Storage -> m Block |
163 | getBlk ix @ BlockIx {..} st @ Storage {..} = liftIO $ do | 165 | getBlk ix @ BlockIx {..} st @ Storage {..} |
166 | = liftIO $ {-# SCC getBlk #-} do | ||
164 | -- TODO check if __piece__ is available | 167 | -- TODO check if __piece__ is available |
165 | bs <- readBytes (ixInterval (pieceLength session) ix) payload | 168 | bs <- readBytes (ixInterval (pieceLength session) ix) payload |
166 | return $ Block ixPiece ixOffset (Lazy.toStrict bs) | 169 | return $ Block ixPiece ixOffset (Lazy.toStrict bs) |
167 | 170 | ||
168 | getPiece :: PieceIx -> Storage -> IO ByteString | 171 | getPiece :: PieceIx -> Storage -> IO ByteString |
169 | getPiece pix st @ Storage {..} = do | 172 | getPiece pix st @ Storage {..} = {-# SCC getPiece #-} do |
170 | let pieceLen = pieceLength session | 173 | let pieceLen = pieceLength session |
171 | let bix = BlockIx pix 0 (pieceLength session) | 174 | let bix = BlockIx pix 0 (pieceLength session) |
172 | bs <- readBytes (ixInterval pieceLen bix) payload | 175 | bs <- readBytes (ixInterval pieceLen bix) payload |
173 | return (Lazy.toStrict bs) | 176 | return (Lazy.toStrict bs) |
174 | 177 | ||
175 | resetPiece :: PieceIx -> Storage -> IO () | 178 | resetPiece :: PieceIx -> Storage -> IO () |
176 | resetPiece pix st @ Storage {..} = atomically $ do | 179 | resetPiece pix st @ Storage {..} |
180 | = {-# SCC resetPiece #-} atomically $ do | ||
177 | mask <- pieceMask pix st | 181 | mask <- pieceMask pix st |
178 | modifyTVar' blocks (`difference` mask) | 182 | modifyTVar' blocks (`difference` mask) |
179 | 183 | ||
180 | validatePiece :: PieceIx -> Storage -> IO Bool | 184 | validatePiece :: PieceIx -> Storage -> IO Bool |
181 | validatePiece pix st @ Storage {..} = do | 185 | validatePiece pix st @ Storage {..} = {-# SCC validatePiece #-} do |
182 | downloaded <- atomically $ isDownloaded pix st | 186 | downloaded <- atomically $ isDownloaded pix st |
183 | if not downloaded then return False | 187 | if not downloaded then return False |
184 | else do | 188 | else do |