diff options
Diffstat (limited to 'src/System/Torrent/Storage.hs')
-rw-r--r-- | src/System/Torrent/Storage.hs | 66 |
1 files changed, 24 insertions, 42 deletions
diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs index c00f770a..f73f1a55 100644 --- a/src/System/Torrent/Storage.hs +++ b/src/System/Torrent/Storage.hs | |||
@@ -14,14 +14,15 @@ | |||
14 | -- data in the filesystem. | 14 | -- data in the filesystem. |
15 | -- | 15 | -- |
16 | -- | 16 | -- |
17 | -- | ||
17 | {-# LANGUAGE DoAndIfThenElse #-} | 18 | {-# LANGUAGE DoAndIfThenElse #-} |
18 | {-# LANGUAGE NamedFieldPuns #-} | 19 | {-# LANGUAGE NamedFieldPuns #-} |
19 | {-# LANGUAGE RecordWildCards #-} | 20 | {-# LANGUAGE RecordWildCards #-} |
20 | module Cobit.Storage | 21 | module System.Torrent.Storage |
21 | ( Storage | 22 | ( Storage |
22 | 23 | ||
23 | -- * Construction | 24 | -- * Construction |
24 | , mapStorage, unmapStorage, withStorage | 25 | , bindTo, unbind, withStorage |
25 | 26 | ||
26 | -- * Modification | 27 | -- * Modification |
27 | , getBlk, putBlk | 28 | , getBlk, putBlk |
@@ -37,71 +38,52 @@ import System.FilePath | |||
37 | import System.Directory | 38 | import System.Directory |
38 | 39 | ||
39 | import Data.Torrent | 40 | import Data.Torrent |
40 | import Network.BitTorrent | 41 | import Network.BitTorrent.Exchange.Protocol |
42 | import Network.BitTorrent.Internal | ||
41 | import System.IO.MMap.Fixed | 43 | import System.IO.MMap.Fixed |
42 | 44 | ||
43 | 45 | ||
44 | data Storage = Storage { | 46 | data Storage = Storage { |
45 | session :: SwarmSession | 47 | -- | |
48 | session :: !SwarmSession | ||
46 | 49 | ||
47 | -- | Used to map linear block addresses to disjoint mallocated/mmaped adresses. | 50 | -- | Used to map linear block addresses to disjoint mallocated/mmaped adresses. |
48 | , stPayload :: Fixed | 51 | , payload :: !Fixed |
49 | |||
50 | -- | Used to find out block offsets. | ||
51 | , stPieceSize :: Int | ||
52 | |||
53 | -- | Used to verify pieces and set finally mark piece as verified. | ||
54 | , stHashes :: ByteString | ||
55 | } | 52 | } |
56 | 53 | ||
54 | pieceSize :: Storage -> Int | ||
55 | pieceSize = ciPieceLength . tInfo . torrentMeta . session | ||
56 | |||
57 | -- TODO doc args | 57 | -- TODO doc args |
58 | mapStorage :: Int -> Maybe FilePath -> FilePath -> ContentInfo -> IO Storage | 58 | bindTo :: SwarmSession -> FilePath -> IO Storage |
59 | mapStorage blkSize statusPath contentPath ci = do | 59 | bindTo se @ SwarmSession {..} contentPath = do |
60 | let content_paths = contentLayout contentPath ci | 60 | let content_paths = contentLayout contentPath (tInfo torrentMeta) |
61 | mapM_ mkDir (L.map fst content_paths) | 61 | mapM_ mkDir (L.map fst content_paths) |
62 | Storage <$> coalesceFiles content_paths | 62 | Storage se <$> coalesceFiles content_paths |
63 | <*> getAllocator statusPath (pieceCount ci) (blockCount blkSize ci) | ||
64 | <*> pure (ciPieceLength ci) | ||
65 | <*> pure (ciPieces ci) | ||
66 | where | 63 | where |
67 | getAllocator (Just path) = error "getAllocator" | ||
68 | getAllocator Nothing = error "getAllocator" | ||
69 | |||
70 | mkDir path = do | 64 | mkDir path = do |
71 | let dirPath = fst (splitFileName path) | 65 | let dirPath = fst (splitFileName path) |
72 | exist <- doesDirectoryExist dirPath | 66 | exist <- doesDirectoryExist dirPath |
73 | unless exist $ do | 67 | unless exist $ do |
74 | createDirectoryIfMissing True dirPath | 68 | createDirectoryIfMissing True dirPath |
75 | 69 | ||
76 | unmapStorage :: Storage -> IO () | 70 | unbind :: Storage -> IO () |
77 | unmapStorage st = error "unmapStorage" | 71 | unbind st = error "unmapStorage" |
78 | |||
79 | 72 | ||
80 | withStorage :: Int -> Maybe FilePath -> FilePath -> ContentInfo | ||
81 | -> (Storage -> IO a) | ||
82 | -> IO a | ||
83 | withStorage blkSize statusPath contentPath t = | ||
84 | bracket (mapStorage blkSize statusPath contentPath t) unmapStorage | ||
85 | 73 | ||
86 | isAvailable :: BlockIx -> Storage -> IO Bool | 74 | withStorage :: SwarmSession -> FilePath -> (Storage -> IO a) -> IO a |
87 | isAvailable ix Storage {..} = error "isAvailable" | 75 | withStorage se path = bracket (se `bindTo` path) unbind |
88 | 76 | ||
89 | 77 | ||
90 | putBlk :: Block -> Storage -> IO () | 78 | putBlk :: Block -> Storage -> IO () |
91 | putBlk blk @ Block {..} st @ Storage {..} = do | 79 | putBlk blk @ Block {..} st @ Storage {..} = do |
92 | available <- isAvailable (blockIx blk) st | 80 | writeBytes (blkInterval (pieceSize st) blk) (Lazy.fromChunks [blkData]) payload |
93 | unless available $ | ||
94 | writeBytes (blkInterval stPieceSize blk) (Lazy.fromChunks [blkData]) stPayload | ||
95 | 81 | ||
96 | -- TODO | 82 | -- TODO |
97 | getBlk :: BlockIx -> Storage -> IO (Maybe Block) | 83 | getBlk :: BlockIx -> Storage -> IO Block |
98 | getBlk ix @ BlockIx {..} st @ Storage {..} = do | 84 | getBlk ix @ BlockIx {..} st @ Storage {..} = do |
99 | available <- isAvailable ix st | 85 | bs <- readBytes (ixInterval (pieceSize st) ix) payload |
100 | if available | 86 | return $ Block ixPiece ixOffset (Lazy.toStrict bs) |
101 | then Just <$> do | ||
102 | bs <- readBytes (ixInterval stPieceSize ix) stPayload | ||
103 | return $ Block ixPiece ixOffset (Lazy.toStrict bs) | ||
104 | else return Nothing | ||
105 | 87 | ||
106 | ixInterval :: Int -> BlockIx -> FixedInterval | 88 | ixInterval :: Int -> BlockIx -> FixedInterval |
107 | ixInterval pieceSize BlockIx {..} = | 89 | ixInterval pieceSize BlockIx {..} = |