diff options
author | Sam Truzjan <pxqr.sta@gmail.com> | 2013-12-03 16:15:32 +0400 |
---|---|---|
committer | Sam Truzjan <pxqr.sta@gmail.com> | 2013-12-03 16:15:32 +0400 |
commit | d6a0442a56d7b977d5f1d1d162517c9086c413eb (patch) | |
tree | 83a1de6acdd77c7bc1ae60c7418a6f43927251c6 /src | |
parent | 5570963d8b22713d4f6ed9c0e2c7f686d5bc75da (diff) |
New storage
Diffstat (limited to 'src')
-rw-r--r-- | src/Data/Torrent/Layout.hs | 8 | ||||
-rw-r--r-- | src/System/IO/MMap/Fixed.hs | 212 | ||||
-rw-r--r-- | src/System/Torrent/FileMap.hs | 151 | ||||
-rw-r--r-- | src/System/Torrent/Storage.hs | 345 |
4 files changed, 193 insertions, 523 deletions
diff --git a/src/Data/Torrent/Layout.hs b/src/Data/Torrent/Layout.hs index c1e26d48..7ed8679d 100644 --- a/src/Data/Torrent/Layout.hs +++ b/src/Data/Torrent/Layout.hs | |||
@@ -52,7 +52,7 @@ module Data.Torrent.Layout | |||
52 | -- * Flat file layout | 52 | -- * Flat file layout |
53 | , FileLayout | 53 | , FileLayout |
54 | , flatLayout | 54 | , flatLayout |
55 | , accumOffsets | 55 | , accumPositions |
56 | , fileOffset | 56 | , fileOffset |
57 | 57 | ||
58 | -- * Internal | 58 | -- * Internal |
@@ -303,11 +303,11 @@ flatLayout prefixPath MultiFile {..} = L.map mkPath liFiles | |||
303 | </> joinPath (L.map BC.unpack fiName) | 303 | </> joinPath (L.map BC.unpack fiName) |
304 | 304 | ||
305 | -- | Calculate offset of each file based on its length, incrementally. | 305 | -- | Calculate offset of each file based on its length, incrementally. |
306 | accumOffsets :: FileLayout FileSize -> FileLayout FileOffset | 306 | accumPositions :: FileLayout FileSize -> FileLayout (FileOffset, FileSize) |
307 | accumOffsets = go 0 | 307 | accumPositions = go 0 |
308 | where | 308 | where |
309 | go !_ [] = [] | 309 | go !_ [] = [] |
310 | go !offset ((n, s) : xs) = (n, offset) : go (offset + s) xs | 310 | go !offset ((n, s) : xs) = (n, (offset, s)) : go (offset + s) xs |
311 | 311 | ||
312 | -- | Gives global offset of a content file for a given full path. | 312 | -- | Gives global offset of a content file for a given full path. |
313 | fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset | 313 | fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset |
diff --git a/src/System/IO/MMap/Fixed.hs b/src/System/IO/MMap/Fixed.hs deleted file mode 100644 index 1e83c350..00000000 --- a/src/System/IO/MMap/Fixed.hs +++ /dev/null | |||
@@ -1,212 +0,0 @@ | |||
1 | -- TODO pprint | ||
2 | -- TODO see if this IntervalMap is overkill: Interval dataty have 4 constrs | ||
3 | -- TODO clarify lifetime in docs | ||
4 | -- TODO use madvise | ||
5 | -- TODO unmap selected interval | ||
6 | -- TODO tests | ||
7 | -- TODO benchmarks | ||
8 | -- TODO unmap overlapped regions | ||
9 | -- [A] TODO lazy mapping for 32 bit arch; | ||
10 | -- we need tricky algorithm and a lot of perf tests | ||
11 | -- TODO use memmove in write bytes | ||
12 | -- TODO write elem, write byte, read byte | ||
13 | -- | | ||
14 | -- Copyright : (c) Sam T. 2013 | ||
15 | -- License : MIT | ||
16 | -- Maintainer : pxqr.sta@gmail.com | ||
17 | -- Stability : experimental | ||
18 | -- Portability : portable | ||
19 | -- | ||
20 | -- This library provides mechanism to mmap files to fixed address | ||
21 | -- with fine-grained control. Hovewer, instead of using MAP_FIXED we | ||
22 | -- create our own address space upon virtual address space. If you | ||
23 | -- would like you could call this space as "fixed address space". | ||
24 | -- | ||
25 | -- This solves a few problems: | ||
26 | -- | ||
27 | -- * Page already in use. If you mmap one file at 0..x addresses and | ||
28 | -- want to map second file to x..y addresses using MAP_FIXED you | ||
29 | -- can get in troubles: page might be mapped already. Raw call to | ||
30 | -- mmap will silently unmap x..y addresses and then mmap our second | ||
31 | -- file. So here we have extra unmap we would like to avoid. | ||
32 | -- | ||
33 | -- * Page boundaries. If you mmap one file at x..x+1 you could | ||
34 | -- not map next file to say addresses x+1..x+2. | ||
35 | -- | ||
36 | -- Internally we make ordinary call to mmap to map a file and then | ||
37 | -- using /interval map/ we map fixed address space to virtual | ||
38 | -- address space. It takes TODO time in TODO cases. | ||
39 | -- | ||
40 | -- Basically this library could be used when we need coalesce | ||
41 | -- several files in arbitrary way. We could map at any position as | ||
42 | -- long as offset + size fit in 'Int'. | ||
43 | -- | ||
44 | -- For other details see: | ||
45 | -- | ||
46 | -- > http://hackage.haskell.org/package/mmap | ||
47 | -- > man mmap | ||
48 | -- | ||
49 | {-# LANGUAGE RecordWildCards #-} | ||
50 | module System.IO.MMap.Fixed | ||
51 | ( -- * Intervals | ||
52 | FixedOffset, FileOffset, FixedInterval, FileInterval | ||
53 | , interval, fileInterval | ||
54 | |||
55 | -- * Construction | ||
56 | , Fixed, Bytes | ||
57 | , System.IO.MMap.Fixed.empty, insertTo | ||
58 | , coalesceFiles | ||
59 | |||
60 | -- ** Specialized 'insertTo' | ||
61 | , mmapTo, mallocTo | ||
62 | , lookupRegion | ||
63 | |||
64 | -- * Query | ||
65 | , upperAddr | ||
66 | |||
67 | -- * Access | ||
68 | , viewBytes, readBytes, writeBytes | ||
69 | , readElem, writeElem | ||
70 | ) where | ||
71 | |||
72 | import Data.ByteString.Lazy as Lazy | ||
73 | import Data.ByteString.Lazy.Internal as Lazy | ||
74 | import Data.ByteString.Internal as B | ||
75 | import Data.List as L | ||
76 | import Data.Int | ||
77 | import Data.IntervalMap.Strict as M | ||
78 | import Data.IntervalMap.Interval | ||
79 | import System.IO.MMap | ||
80 | import Foreign | ||
81 | |||
82 | |||
83 | type FixedOffset = Int | ||
84 | type FileOffset = Int64 | ||
85 | type Size = Int | ||
86 | |||
87 | |||
88 | type FileInterval = (FileOffset, Size) | ||
89 | type FixedInterval = Interval FixedOffset | ||
90 | |||
91 | |||
92 | interval :: FixedOffset -> Size -> FixedInterval | ||
93 | interval off s = IntervalCO off (off + fromIntegral (max 0 s)) | ||
94 | {-# INLINE interval #-} | ||
95 | |||
96 | fileInterval :: FileOffset -> Size -> FileInterval | ||
97 | fileInterval off s = (off, s) | ||
98 | {-# INLINE fileInterval #-} | ||
99 | |||
100 | intervalSize :: FixedInterval -> Size | ||
101 | intervalSize i = upperBound i - lowerBound i | ||
102 | {-# INLINE intervalSize #-} | ||
103 | |||
104 | |||
105 | type Bytes = (ForeignPtr Word8, Size) | ||
106 | |||
107 | type FixedMap = IntervalMap FixedOffset Bytes | ||
108 | |||
109 | newtype Fixed = Fixed { imap :: FixedMap } | ||
110 | |||
111 | instance Show Fixed where | ||
112 | show = show . M.toList . imap | ||
113 | |||
114 | |||
115 | mapIM :: (FixedMap -> FixedMap) -> Fixed -> Fixed | ||
116 | mapIM f s = s { imap = f (imap s) } | ||
117 | |||
118 | empty :: Fixed | ||
119 | empty = Fixed M.empty | ||
120 | |||
121 | coalesceFiles :: [(FilePath, Int)] -> IO Fixed | ||
122 | coalesceFiles = go 0 System.IO.MMap.Fixed.empty | ||
123 | where | ||
124 | go _ s [] = return s | ||
125 | go offset s ((path, bsize) : xs) = do | ||
126 | s' <- mmapTo path (0, bsize) offset s | ||
127 | go (offset + bsize) s' xs | ||
128 | |||
129 | upperAddr :: Fixed -> FixedOffset | ||
130 | upperAddr = upperBound . fst . findLast . imap | ||
131 | |||
132 | insertTo :: FixedInterval -> Bytes -> Fixed -> Fixed | ||
133 | insertTo fi mm = mapIM (M.insert fi mm) | ||
134 | {-# INLINE insertTo #-} | ||
135 | |||
136 | mmapTo :: FilePath -> FileInterval -> FixedOffset -> Fixed -> IO Fixed | ||
137 | mmapTo path mrange to s = do | ||
138 | (fptr, offset, fsize) <- mmapFileForeignPtr path ReadWriteEx (Just mrange) | ||
139 | |||
140 | let fixed = interval to fsize | ||
141 | let mmaped = (fptr, offset) | ||
142 | |||
143 | return $ insertTo fixed mmaped s | ||
144 | |||
145 | mallocTo :: FixedInterval -> Fixed -> IO Fixed | ||
146 | mallocTo fi s = do | ||
147 | let bsize = intervalSize fi | ||
148 | fptr <- mallocForeignPtrBytes bsize | ||
149 | return (insertTo fi (fptr, 0) s) | ||
150 | |||
151 | lookupRegion :: FixedOffset -> Fixed -> Maybe B.ByteString | ||
152 | lookupRegion offset Fixed {..} = | ||
153 | case intersecting imap $ IntervalCO offset (succ offset) of | ||
154 | [(i, (fptr, off))] -> let s = upperBound i - lowerBound i | ||
155 | in Just $ fromForeignPtr fptr off (max 0 s) | ||
156 | _ -> Nothing | ||
157 | |||
158 | -- | Note: this is unsafe operation. | ||
159 | viewBytes :: FixedInterval -> Fixed -> Lazy.ByteString | ||
160 | viewBytes fi s = fromChunks $ L.map mk $ (imap s `intersecting` fi) | ||
161 | where | ||
162 | mk (i, (fptr, offset)) = | ||
163 | let dropB = max 0 (lowerBound fi - lowerBound i) | ||
164 | dropT = max 0 (upperBound i - upperBound fi) | ||
165 | bsize = intervalSize i - (dropT + dropB) | ||
166 | in fromForeignPtr fptr (offset + dropB) bsize | ||
167 | |||
168 | |||
169 | readBytes :: FixedInterval -> Fixed -> IO Lazy.ByteString | ||
170 | readBytes fi s = let c = Lazy.copy (viewBytes fi s) in mkCopy c >> return c | ||
171 | {-# INLINE readBytes #-} | ||
172 | |||
173 | writeBytes :: FixedInterval -> Lazy.ByteString -> Fixed -> IO () | ||
174 | writeBytes fi bs s = bscpy (viewBytes fi s) bs | ||
175 | {-# INLINE writeBytes #-} | ||
176 | |||
177 | -- | Note: this operation takes O(log(files count)) time, if possible | ||
178 | -- use readBytes. | ||
179 | readElem :: Storable a => Fixed -> FixedOffset -> IO a | ||
180 | readElem s offset = go undefined | ||
181 | where | ||
182 | go :: Storable a => a -> IO a | ||
183 | go dont_touch = do | ||
184 | let bsize = sizeOf dont_touch | ||
185 | let PS fptr off _ = Lazy.toStrict (viewBytes (interval offset bsize) s) | ||
186 | withForeignPtr fptr $ \ ptr -> peekByteOff ptr off | ||
187 | |||
188 | writeElem :: Storable a => Fixed -> FixedOffset -> a -> IO () | ||
189 | writeElem s offset x = do | ||
190 | let bsize = sizeOf x | ||
191 | let PS fptr off _ = Lazy.toStrict (viewBytes (interval offset bsize) s) | ||
192 | withForeignPtr fptr $ \ptr -> pokeByteOff ptr off x | ||
193 | |||
194 | |||
195 | mkCopy :: Lazy.ByteString -> IO () | ||
196 | mkCopy Empty = return () | ||
197 | mkCopy (Chunk _ x) = mkCopy x | ||
198 | |||
199 | bscpy :: Lazy.ByteString -> Lazy.ByteString -> IO () | ||
200 | bscpy (PS _ _ 0 `Chunk` dest_rest) src = bscpy dest_rest src | ||
201 | bscpy dest (PS _ _ 0 `Chunk` src_rest) = bscpy dest src_rest | ||
202 | bscpy (PS dest_fptr dest_off dest_size `Chunk` dest_rest) | ||
203 | (PS src_fptr src_off src_size `Chunk` src_rest) | ||
204 | = do let csize = min dest_size src_size | ||
205 | withForeignPtr dest_fptr $ \dest_ptr -> | ||
206 | withForeignPtr src_fptr $ \src_ptr -> | ||
207 | memcpy (dest_ptr `advancePtr` dest_off) | ||
208 | (src_ptr `advancePtr` src_off) | ||
209 | (fromIntegral csize) -- TODO memmove? | ||
210 | bscpy (PS dest_fptr (dest_off + csize) (dest_size - csize) `Chunk` dest_rest) | ||
211 | (PS src_fptr (src_off + csize) (src_size - csize) `Chunk` src_rest) | ||
212 | bscpy _ _ = return () \ No newline at end of file | ||
diff --git a/src/System/Torrent/FileMap.hs b/src/System/Torrent/FileMap.hs new file mode 100644 index 00000000..80907a30 --- /dev/null +++ b/src/System/Torrent/FileMap.hs | |||
@@ -0,0 +1,151 @@ | |||
1 | {-# LANGUAGE RecordWildCards #-} | ||
2 | {-# LANGUAGE ViewPatterns #-} | ||
3 | {-# OPTIONS -fno-warn-orphans #-} | ||
4 | module System.Torrent.FileMap | ||
5 | ( FileMap | ||
6 | |||
7 | -- * Construction | ||
8 | , Mode (..) | ||
9 | , def | ||
10 | , mmapFiles | ||
11 | , unmapFiles | ||
12 | |||
13 | -- * Query | ||
14 | , System.Torrent.FileMap.size | ||
15 | |||
16 | -- * Modification | ||
17 | , readBytes | ||
18 | , writeBytes | ||
19 | , unsafeReadBytes | ||
20 | |||
21 | -- * Unsafe conversions | ||
22 | , fromLazyByteString | ||
23 | , toLazyByteString | ||
24 | ) where | ||
25 | |||
26 | import Control.Applicative | ||
27 | import Control.Monad as L | ||
28 | import Data.ByteString as BS | ||
29 | import Data.ByteString.Internal as BS | ||
30 | import Data.ByteString.Lazy as BL | ||
31 | import Data.ByteString.Lazy.Internal as BL | ||
32 | import Data.Default | ||
33 | import Data.Vector as V -- TODO use unboxed vector | ||
34 | import Foreign | ||
35 | import System.IO.MMap | ||
36 | |||
37 | import Data.Torrent.Layout | ||
38 | |||
39 | |||
40 | data FileEntry = FileEntry | ||
41 | { filePosition :: {-# UNPACK #-} !FileOffset | ||
42 | , fileBytes :: {-# UNPACK #-} !BS.ByteString | ||
43 | } deriving (Show, Eq) | ||
44 | |||
45 | type FileMap = Vector FileEntry | ||
46 | |||
47 | instance Default Mode where | ||
48 | def = ReadWriteEx | ||
49 | |||
50 | mmapFiles :: Mode -> FileLayout FileSize -> IO FileMap | ||
51 | mmapFiles mode layout = V.fromList <$> L.mapM mkEntry (accumPositions layout) | ||
52 | where | ||
53 | mkEntry (path, (pos, expectedSize)) = do | ||
54 | let esize = fromIntegral expectedSize -- FIXME does this safe? | ||
55 | (fptr, moff, msize) <- mmapFileForeignPtr path mode $ Just (0, esize) | ||
56 | if msize /= esize | ||
57 | then error "mmapFiles" -- TODO unmap mapped files on exception | ||
58 | else return $ FileEntry pos (PS fptr moff msize) | ||
59 | |||
60 | unmapFiles :: FileMap -> IO () | ||
61 | unmapFiles = V.mapM_ unmapEntry | ||
62 | where | ||
63 | unmapEntry (FileEntry _ (PS fptr _ _)) = finalizeForeignPtr fptr | ||
64 | |||
65 | fromLazyByteString :: BL.ByteString -> FileMap | ||
66 | fromLazyByteString lbs = V.unfoldr f (0, lbs) | ||
67 | where | ||
68 | f (_, Empty ) = Nothing | ||
69 | f (pos, Chunk x xs) = Just (FileEntry pos x, ((pos + chunkSize), xs)) | ||
70 | where chunkSize = fromIntegral $ BS.length x | ||
71 | |||
72 | -- | /O(n)/. | ||
73 | toLazyByteString :: FileMap -> BL.ByteString | ||
74 | toLazyByteString = V.foldr f Empty | ||
75 | where | ||
76 | f FileEntry {..} bs = Chunk fileBytes bs | ||
77 | |||
78 | -- | /O(1)/. | ||
79 | size :: FileMap -> FileOffset | ||
80 | size m | ||
81 | | V.null m = 0 | ||
82 | | FileEntry {..} <- V.unsafeLast m | ||
83 | = filePosition + fromIntegral (BS.length fileBytes) | ||
84 | |||
85 | bsearch :: FileOffset -> FileMap -> Maybe Int | ||
86 | bsearch x m | ||
87 | | V.null m = Nothing | ||
88 | | otherwise = branch (V.length m `div` 2) | ||
89 | where | ||
90 | branch c @ ((m !) -> FileEntry {..}) | ||
91 | | x < filePosition = bsearch x (V.take c m) | ||
92 | | x >= filePosition + fileSize = do | ||
93 | ix <- bsearch x (V.drop (succ c) m) | ||
94 | return $ succ c + ix | ||
95 | | otherwise = Just c | ||
96 | where | ||
97 | fileSize = fromIntegral (BS.length fileBytes) | ||
98 | |||
99 | -- | /O(log n)/. | ||
100 | drop :: FileOffset -> FileMap -> (FileSize, FileMap) | ||
101 | drop off m | ||
102 | | Just ix <- bsearch off m | ||
103 | , FileEntry {..} <- m ! ix = (off - filePosition, V.drop ix m) | ||
104 | | otherwise = (0 , V.empty) | ||
105 | |||
106 | -- | /O(log n)/. | ||
107 | take :: FileSize -> FileMap -> (FileMap, FileSize) | ||
108 | take len m | ||
109 | | len >= s = (m , 0) | ||
110 | | Just ix <- bsearch (pred len) m = let m' = V.take (succ ix) m | ||
111 | in (m', System.Torrent.FileMap.size m' - len) | ||
112 | | otherwise = (V.empty , 0) | ||
113 | where | ||
114 | s = System.Torrent.FileMap.size m | ||
115 | |||
116 | -- | /O(log n + m)/. Do not use this function with 'unmapFiles'. | ||
117 | unsafeReadBytes :: FileOffset -> FileSize -> FileMap -> BL.ByteString | ||
118 | unsafeReadBytes off s m | ||
119 | | (l , m') <- System.Torrent.FileMap.drop off m | ||
120 | , (m'', _ ) <- System.Torrent.FileMap.take (off + s) m' | ||
121 | = BL.take (fromIntegral s) $ BL.drop (fromIntegral l) $ toLazyByteString m'' | ||
122 | |||
123 | readBytes :: FileOffset -> FileSize -> FileMap -> IO BL.ByteString | ||
124 | readBytes off s m = do | ||
125 | let bs_copy = BL.copy $ unsafeReadBytes off s m | ||
126 | forceLBS bs_copy | ||
127 | return bs_copy | ||
128 | where | ||
129 | forceLBS Empty = return () | ||
130 | forceLBS (Chunk _ x) = forceLBS x | ||
131 | |||
132 | bscpy :: BL.ByteString -> BL.ByteString -> IO () | ||
133 | bscpy (PS _ _ 0 `Chunk` dest_rest) src = bscpy dest_rest src | ||
134 | bscpy dest (PS _ _ 0 `Chunk` src_rest) = bscpy dest src_rest | ||
135 | bscpy (PS dest_fptr dest_off dest_size `Chunk` dest_rest) | ||
136 | (PS src_fptr src_off src_size `Chunk` src_rest) | ||
137 | = do let csize = min dest_size src_size | ||
138 | withForeignPtr dest_fptr $ \dest_ptr -> | ||
139 | withForeignPtr src_fptr $ \src_ptr -> | ||
140 | memcpy (dest_ptr `advancePtr` dest_off) | ||
141 | (src_ptr `advancePtr` src_off) | ||
142 | (fromIntegral csize) -- TODO memmove? | ||
143 | bscpy (PS dest_fptr (dest_off + csize) (dest_size - csize) `Chunk` dest_rest) | ||
144 | (PS src_fptr (src_off + csize) (src_size - csize) `Chunk` src_rest) | ||
145 | bscpy _ _ = return () | ||
146 | |||
147 | writeBytes :: FileOffset -> BL.ByteString -> FileMap -> IO () | ||
148 | writeBytes off lbs m = bscpy dest src | ||
149 | where | ||
150 | src = BL.take (fromIntegral (BL.length dest)) lbs | ||
151 | dest = unsafeReadBytes off (fromIntegral (BL.length lbs)) m \ No newline at end of file | ||
diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs index 2225b0a3..bb6c5d2e 100644 --- a/src/System/Torrent/Storage.hs +++ b/src/System/Torrent/Storage.hs | |||
@@ -1,11 +1,11 @@ | |||
1 | -- | | 1 | -- | |
2 | -- Copyright : (c) Sam T. 2013 | 2 | -- Copyright : (c) Sam Truzjan 2013 |
3 | -- License : MIT | 3 | -- License : BSD3 |
4 | -- Maintainer : pxqr.sta@gmail.com | 4 | -- Maintainer : pxqr.sta@gmail.com |
5 | -- Stability : experimental | 5 | -- Stability : experimental |
6 | -- Portability : non-portable | 6 | -- Portability : portable |
7 | -- | 7 | -- |
8 | -- This module implements mapping from single continious block space | 8 | -- This module implements mapping from single continious piece space |
9 | -- to file storage. Storage can be used in two modes: | 9 | -- to file storage. Storage can be used in two modes: |
10 | -- | 10 | -- |
11 | -- * As in memory storage - in this case we don't touch filesystem. | 11 | -- * As in memory storage - in this case we don't touch filesystem. |
@@ -13,324 +13,55 @@ | |||
13 | -- * As ordinary mmaped file storage - when we need to store | 13 | -- * As ordinary mmaped file storage - when we need to store |
14 | -- data in the filesystem. | 14 | -- data in the filesystem. |
15 | -- | 15 | -- |
16 | {-# LANGUAGE DoAndIfThenElse #-} | 16 | {-# LANGUAGE RecordWildCards #-} |
17 | {-# LANGUAGE NamedFieldPuns #-} | ||
18 | {-# LANGUAGE RecordWildCards #-} | ||
19 | module System.Torrent.Storage | 17 | module System.Torrent.Storage |
20 | ( Storage (metainfo) | 18 | ( Storage |
21 | , ppStorage | ||
22 | 19 | ||
23 | -- * Construction | 20 | -- * Construction |
24 | , openStorage, closeStorage, withStorage | 21 | , Mode (..) |
25 | , getCompleteBitfield | 22 | , def |
23 | , open | ||
24 | , close | ||
26 | 25 | ||
27 | -- * Modification | 26 | -- * Modification |
28 | , getBlk, putBlk, selBlk | 27 | , writePiece |
29 | , getPiece, validatePiece | 28 | , readPiece |
30 | 29 | , unsafeReadPiece | |
31 | -- * TODO expose only File interface! | ||
32 | -- * File interface | ||
33 | , FD | ||
34 | , openFD, flushFD, closeFD | ||
35 | , readFD, writeFD | ||
36 | ) where | 30 | ) where |
37 | 31 | ||
38 | import Control.Applicative | 32 | import Control.Applicative |
39 | import Control.Concurrent.STM | 33 | import Data.ByteString.Lazy as BL |
40 | import Control.Exception | ||
41 | import Control.Monad | ||
42 | import Control.Monad.Trans | ||
43 | |||
44 | import Data.ByteString as B | ||
45 | import qualified Data.ByteString.Lazy as Lazy | ||
46 | import Text.PrettyPrint | ||
47 | import System.FilePath | ||
48 | import System.Directory | ||
49 | import Foreign.C.Error | ||
50 | |||
51 | import Data.Torrent.Bitfield as BF | ||
52 | import Data.Torrent.Block | ||
53 | import Data.Torrent | ||
54 | import System.IO.MMap.Fixed as Fixed | ||
55 | |||
56 | -- TODO merge piece validation and Sessions.available into one transaction. | ||
57 | data Storage = Storage { | ||
58 | -- | | ||
59 | metainfo :: !Torrent | ||
60 | 34 | ||
61 | -- | Bitmask of complete and verified _pieces_. | 35 | import Data.Torrent.Layout |
62 | , complete :: !(TVar Bitfield) | 36 | import Data.Torrent.Piece |
37 | import System.Torrent.FileMap | ||
63 | 38 | ||
64 | -- | Bitmask of complete _blocks_. | ||
65 | , blocks :: !(TVar Bitfield) | ||
66 | -- TODO use bytestring for fast serialization | ||
67 | -- because we need to write this bitmap to disc periodically | ||
68 | 39 | ||
69 | , blockSize :: !Int | 40 | -- TODO validation |
70 | 41 | data Storage = Storage | |
71 | -- | Used to map linear block addresses to disjoint | 42 | { pieceLen :: {-# UNPACK #-} !PieceSize |
72 | -- mallocated/mmaped adresses. | 43 | , fileMap :: {-# UNPACK #-} !FileMap |
73 | , payload :: !Fixed | ||
74 | } | 44 | } |
75 | 45 | ||
76 | ppStorage :: Storage -> IO Doc | 46 | -- ResourceT ? |
77 | ppStorage Storage {..} = pp <$> readTVarIO blocks | 47 | open :: Mode -> PieceSize -> FileLayout FileSize -> IO Storage |
78 | where | 48 | open mode s l = Storage s <$> mmapFiles mode l |
79 | pp bf = int blockSize | ||
80 | |||
81 | getCompleteBitfield :: Storage -> STM Bitfield | ||
82 | getCompleteBitfield Storage {..} = readTVar complete | ||
83 | |||
84 | {----------------------------------------------------------------------- | ||
85 | Construction | ||
86 | -----------------------------------------------------------------------} | ||
87 | 49 | ||
88 | -- TODO doc args | 50 | close :: Storage -> IO () |
89 | openStorage :: Torrent -> FilePath -> Bitfield -> IO Storage | 51 | close Storage {..} = unmapFiles fileMap |
90 | openStorage t @ Torrent {..} contentPath bf = do | ||
91 | let content_paths = contentLayout contentPath tInfo | ||
92 | mapM_ (mkDir . fst) content_paths | ||
93 | 52 | ||
94 | let blockSize = defaultBlockSize `min` ciPieceLength tInfo | 53 | writePiece :: Piece BL.ByteString -> Storage -> IO () |
95 | Storage t <$> newTVarIO bf | 54 | writePiece Piece {..} Storage {..} = do |
96 | <*> newTVarIO (haveNone (blockCount blockSize tInfo)) | 55 | writeBytes (fromIntegral (pieceIndex * pieceLen)) pieceData fileMap |
97 | <*> pure blockSize | ||
98 | <*> coalesceFiles content_paths | ||
99 | where | ||
100 | mkDir path = do | ||
101 | let dirPath = fst (splitFileName path) | ||
102 | exist <- doesDirectoryExist dirPath | ||
103 | unless exist $ do | ||
104 | createDirectoryIfMissing True dirPath | ||
105 | |||
106 | -- TODO | ||
107 | closeStorage :: Storage -> IO () | ||
108 | closeStorage st = return () | ||
109 | |||
110 | |||
111 | withStorage :: Torrent -> FilePath -> Bitfield -> (Storage -> IO a) -> IO a | ||
112 | withStorage se path bf = bracket (openStorage se path bf) closeStorage | ||
113 | 56 | ||
114 | {----------------------------------------------------------------------- | 57 | readPiece :: PieceIx -> Storage -> IO (Piece BL.ByteString) |
115 | Modification | 58 | readPiece pix Storage {..} = do |
116 | -----------------------------------------------------------------------} | 59 | bs <- readBytes (fromIntegral (pix * pieceLen)) |
60 | (fromIntegral pieceLen) fileMap | ||
61 | return $ Piece pix bs | ||
117 | 62 | ||
118 | -- TODO to avoid races we might need to try Control.Concurrent.yield | 63 | unsafeReadPiece :: PieceIx -> Storage -> IO (Piece BL.ByteString) |
119 | -- TODO make block_payload :: Lazy.ByteString | 64 | unsafeReadPiece pix Storage {..} = return $ Piece pix lbs |
120 | |||
121 | selBlk :: MonadIO m => PieceIx -> Storage -> m [BlockIx] | ||
122 | selBlk pix st @ Storage {..} | ||
123 | = liftIO $ {-# SCC selBlk #-} atomically $ do | ||
124 | mask <- pieceMask pix st | ||
125 | select mask <$> readTVar blocks | ||
126 | where | 65 | where |
127 | select mask = fmap mkBix . toList . difference mask | 66 | lbs = unsafeReadBytes (fromIntegral (pix * pieceLen)) |
128 | -- TODO clip upper bound of block index | 67 | (fromIntegral pieceLen) fileMap |
129 | mkBix ix = BlockIx pix (blockSize * (ix - offset)) blockSize | ||
130 | |||
131 | offset = coeff * pix | ||
132 | coeff = ciPieceLength (tInfo metainfo) `div` blockSize | ||
133 | |||
134 | -- | ||
135 | -- TODO make global lock map -- otherwise we might get broken pieces | ||
136 | -- | ||
137 | -- imagine the following situation: | ||
138 | -- | ||
139 | -- thread1: write | ||
140 | -- thread1: mark | ||
141 | -- | ||
142 | -- this let us avoid races as well | ||
143 | -- | ||
144 | |||
145 | -- | Write a block to the storage. If block out of range then block is clipped. | ||
146 | -- | ||
147 | -- | ||
148 | -- | ||
149 | putBlk :: MonadIO m => Block -> Storage -> m Bool | ||
150 | putBlk blk @ Block {..} st @ Storage {..} | ||
151 | = liftIO $ {-# SCC putBlk #-} do | ||
152 | -- let blkIx = undefined | ||
153 | -- bm <- readTVarIO blocks | ||
154 | -- unless (member blkIx bm) $ do | ||
155 | writeBytes (blkInterval (ciPieceLength (tInfo metainfo)) blk) blkData payload | ||
156 | |||
157 | markBlock blk st | ||
158 | completePiece blkPiece st | ||
159 | |||
160 | markBlock :: Block -> Storage -> IO () | ||
161 | markBlock Block {..} Storage {..} = {-# SCC markBlock #-} do | ||
162 | let piLen = ciPieceLength (tInfo metainfo) | ||
163 | let glIx = (piLen `div` blockSize) * blkPiece + (blkOffset `div` blockSize) | ||
164 | atomically $ modifyTVar' blocks (have glIx) | ||
165 | |||
166 | -- | Read a block by given block index. If lower or upper bound out of | ||
167 | -- range then index is clipped. | ||
168 | -- | ||
169 | -- Do not block. | ||
170 | -- | ||
171 | getBlk :: MonadIO m => BlockIx -> Storage -> m Block | ||
172 | getBlk ix @ BlockIx {..} st @ Storage {..} | ||
173 | = liftIO $ {-# SCC getBlk #-} do | ||
174 | -- TODO check if __piece__ is available | ||
175 | let piLen = ciPieceLength (tInfo metainfo) | ||
176 | bs <- readBytes (ixInterval piLen ix) payload | ||
177 | return $ Block ixPiece ixOffset bs | ||
178 | |||
179 | getPiece :: PieceIx -> Storage -> IO Lazy.ByteString | ||
180 | getPiece pix st @ Storage {..} = {-# SCC getPiece #-} do | ||
181 | let piLen = ciPieceLength (tInfo metainfo) | ||
182 | let bix = BlockIx pix 0 piLen | ||
183 | let bs = viewBytes (ixInterval piLen bix) payload | ||
184 | return $ bs | ||
185 | |||
186 | resetPiece :: PieceIx -> Storage -> IO () | ||
187 | resetPiece pix st @ Storage {..} | ||
188 | = {-# SCC resetPiece #-} atomically $ do | ||
189 | mask <- pieceMask pix st | ||
190 | modifyTVar' blocks (`difference` mask) | ||
191 | |||
192 | validatePiece :: Storage -> PieceIx -> IO Bool | ||
193 | validatePiece storage pix = do | ||
194 | checkPiece (tInfo (metainfo storage)) pix <$> getPiece pix storage | ||
195 | |||
196 | completePiece :: PieceIx -> Storage -> IO Bool | ||
197 | completePiece pix st @ Storage {..} = {-# SCC completePiece #-} do | ||
198 | downloaded <- atomically $ isDownloaded pix st | ||
199 | if not downloaded then return False | ||
200 | else do | ||
201 | piece <- getPiece pix st | ||
202 | if checkPiece (tInfo metainfo) pix piece | ||
203 | then do | ||
204 | atomically $ modifyTVar' complete (BF.have pix) | ||
205 | return True | ||
206 | else do | ||
207 | print $ "----------------------------- invalid " ++ show pix | ||
208 | -- resetPiece pix st | ||
209 | return True | ||
210 | |||
211 | -- | Check each piece in the storage against content info hash. | ||
212 | -- | ||
213 | -- Note that this function will block until each the entire storage | ||
214 | -- checked. This may take a long time for a big torrents use fork | ||
215 | -- if needed. | ||
216 | -- | ||
217 | validateStorage :: Storage -> IO () | ||
218 | validateStorage st = undefined -- (`validatePiece` st) [0..pieceCount st] | ||
219 | |||
220 | {----------------------------------------------------------------------- | ||
221 | POSIX-like file interface | ||
222 | ------------------------------------------------------------------------ | ||
223 | This is useful for virtual filesystem writers and just for per file | ||
224 | interface. | ||
225 | -----------------------------------------------------------------------} | ||
226 | -- TODO reference counting: storage might be closed before all FDs | ||
227 | -- gets closed! | ||
228 | -- or we can forbid to close storage and use finalizers only? | ||
229 | |||
230 | type Offset = Int | ||
231 | type Size = Int | ||
232 | |||
233 | data FD = FD { | ||
234 | fdData :: ByteString | ||
235 | , fdNoBlock :: Bool | ||
236 | } | ||
237 | |||
238 | |||
239 | -- TODO return "is dir" error | ||
240 | -- | This call correspond to open(2) with the following parameters: | ||
241 | -- | ||
242 | -- * OpenMode = ReadOnly; | ||
243 | -- | ||
244 | -- * OpenFileFlags = O_NONBLOCK. (not true yet) | ||
245 | -- | ||
246 | openFD :: FilePath -> Bool -> Storage -> IO (Either Errno FD) | ||
247 | openFD path nonblock Storage {..} | ||
248 | | Just offset <- fileOffset path (tInfo metainfo) | ||
249 | , Just bs <- lookupRegion (fromIntegral offset) payload | ||
250 | = return $ Right $ FD bs nonblock | ||
251 | | otherwise = return $ Left $ eNOENT | ||
252 | |||
253 | -- | Cancel all enqueued read operations and report any delayed | ||
254 | -- errors. | ||
255 | flushFD :: FD -> IO Errno | ||
256 | flushFD _ = return eOK | ||
257 | |||
258 | -- | This call correspond to close(2). | ||
259 | closeFD :: FD -> IO () | ||
260 | closeFD _ = return () | ||
261 | |||
262 | -- TODO | ||
263 | maskRegion :: FD -> Offset -> Size -> Maybe Size | ||
264 | maskRegion FD {..} offset siz = return siz | ||
265 | |||
266 | -- TODO | ||
267 | isComplete :: FD -> Offset -> Size -> IO Size | ||
268 | isComplete _ _ siz = return siz | ||
269 | |||
270 | -- TODO | ||
271 | enqueueRead :: FD -> Offset -> Size -> IO () | ||
272 | enqueueRead _ _ _ = return () | ||
273 | |||
274 | -- TODO | ||
275 | readAhead :: FD -> Offset -> Size -> IO () | ||
276 | readAhead _ _ _ = return () | ||
277 | |||
278 | -- TODO | ||
279 | waitRegion :: FD -> Offset -> Size -> IO ByteString | ||
280 | waitRegion _ _ _ = return B.empty | ||
281 | |||
282 | -- TODO implement blocking and non blocking modes? | ||
283 | -- TODO check if region completely downloaded | ||
284 | -- TODO if not we could return EAGAIN | ||
285 | -- TODO enqueue read to piece manager | ||
286 | -- | This call correspond to pread(2). | ||
287 | readFD :: FD -> Offset -> Size -> IO (Either Errno ByteString) | ||
288 | readFD fd @ FD {..} offset reqSize = | ||
289 | case maskRegion fd offset reqSize of | ||
290 | Nothing -> return $ Right B.empty | ||
291 | Just expSize -> do | ||
292 | availSize <- isComplete fd offset expSize | ||
293 | if availSize == expSize then haveAllReg expSize else haveSomeReg expSize | ||
294 | where | ||
295 | haveAllReg expSize = do | ||
296 | readAhead fd offset expSize | ||
297 | return $ Right $ slice offset expSize fdData | ||
298 | |||
299 | haveSomeReg expSize | ||
300 | | fdNoBlock = return $ Left $ eAGAIN | ||
301 | | otherwise = do | ||
302 | bs <- waitRegion fd offset expSize | ||
303 | readAhead fd offset expSize | ||
304 | return $ Right bs | ||
305 | |||
306 | -- TODO implement COW; needed for applications which want to change files. | ||
307 | writeFD :: FD -> ByteString -> Offset -> IO () | ||
308 | writeFD FD {..} bs offset = return () | ||
309 | |||
310 | {----------------------------------------------------------------------- | ||
311 | Internal | ||
312 | -----------------------------------------------------------------------} | ||
313 | |||
314 | isDownloaded :: PieceIx -> Storage -> STM Bool | ||
315 | isDownloaded pix st @ Storage {..} = do | ||
316 | bf <- readTVar blocks | ||
317 | mask <- pieceMask pix st | ||
318 | return $ intersection mask bf == mask | ||
319 | |||
320 | pieceMask :: PieceIx -> Storage -> STM Bitfield | ||
321 | pieceMask pix Storage {..} = do | ||
322 | bf <- readTVar blocks | ||
323 | return $ BF.interval (totalCount bf) offset (offset + coeff - 1) | ||
324 | where | ||
325 | offset = coeff * pix | ||
326 | coeff = ciPieceLength (tInfo metainfo) `div` blockSize | ||
327 | |||
328 | |||
329 | ixInterval :: Int -> BlockIx -> FixedInterval | ||
330 | ixInterval pieceSize BlockIx {..} = | ||
331 | Fixed.interval (ixPiece * pieceSize + ixOffset) ixLength | ||
332 | |||
333 | blkInterval :: Int -> Block -> FixedInterval | ||
334 | blkInterval pieceSize Block {..} = | ||
335 | Fixed.interval (blkPiece * pieceSize + blkOffset) | ||
336 | (fromIntegral (Lazy.length blkData)) \ No newline at end of file | ||