summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Data/Torrent/Layout.hs8
-rw-r--r--src/System/IO/MMap/Fixed.hs212
-rw-r--r--src/System/Torrent/FileMap.hs151
-rw-r--r--src/System/Torrent/Storage.hs345
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.
306accumOffsets :: FileLayout FileSize -> FileLayout FileOffset 306accumPositions :: FileLayout FileSize -> FileLayout (FileOffset, FileSize)
307accumOffsets = go 0 307accumPositions = 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.
313fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset 313fileOffset :: 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 #-}
50module 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
72import Data.ByteString.Lazy as Lazy
73import Data.ByteString.Lazy.Internal as Lazy
74import Data.ByteString.Internal as B
75import Data.List as L
76import Data.Int
77import Data.IntervalMap.Strict as M
78import Data.IntervalMap.Interval
79import System.IO.MMap
80import Foreign
81
82
83type FixedOffset = Int
84type FileOffset = Int64
85type Size = Int
86
87
88type FileInterval = (FileOffset, Size)
89type FixedInterval = Interval FixedOffset
90
91
92interval :: FixedOffset -> Size -> FixedInterval
93interval off s = IntervalCO off (off + fromIntegral (max 0 s))
94{-# INLINE interval #-}
95
96fileInterval :: FileOffset -> Size -> FileInterval
97fileInterval off s = (off, s)
98{-# INLINE fileInterval #-}
99
100intervalSize :: FixedInterval -> Size
101intervalSize i = upperBound i - lowerBound i
102{-# INLINE intervalSize #-}
103
104
105type Bytes = (ForeignPtr Word8, Size)
106
107type FixedMap = IntervalMap FixedOffset Bytes
108
109newtype Fixed = Fixed { imap :: FixedMap }
110
111instance Show Fixed where
112 show = show . M.toList . imap
113
114
115mapIM :: (FixedMap -> FixedMap) -> Fixed -> Fixed
116mapIM f s = s { imap = f (imap s) }
117
118empty :: Fixed
119empty = Fixed M.empty
120
121coalesceFiles :: [(FilePath, Int)] -> IO Fixed
122coalesceFiles = 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
129upperAddr :: Fixed -> FixedOffset
130upperAddr = upperBound . fst . findLast . imap
131
132insertTo :: FixedInterval -> Bytes -> Fixed -> Fixed
133insertTo fi mm = mapIM (M.insert fi mm)
134{-# INLINE insertTo #-}
135
136mmapTo :: FilePath -> FileInterval -> FixedOffset -> Fixed -> IO Fixed
137mmapTo 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
145mallocTo :: FixedInterval -> Fixed -> IO Fixed
146mallocTo fi s = do
147 let bsize = intervalSize fi
148 fptr <- mallocForeignPtrBytes bsize
149 return (insertTo fi (fptr, 0) s)
150
151lookupRegion :: FixedOffset -> Fixed -> Maybe B.ByteString
152lookupRegion 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.
159viewBytes :: FixedInterval -> Fixed -> Lazy.ByteString
160viewBytes 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
169readBytes :: FixedInterval -> Fixed -> IO Lazy.ByteString
170readBytes fi s = let c = Lazy.copy (viewBytes fi s) in mkCopy c >> return c
171{-# INLINE readBytes #-}
172
173writeBytes :: FixedInterval -> Lazy.ByteString -> Fixed -> IO ()
174writeBytes 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.
179readElem :: Storable a => Fixed -> FixedOffset -> IO a
180readElem 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
188writeElem :: Storable a => Fixed -> FixedOffset -> a -> IO ()
189writeElem 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
195mkCopy :: Lazy.ByteString -> IO ()
196mkCopy Empty = return ()
197mkCopy (Chunk _ x) = mkCopy x
198
199bscpy :: Lazy.ByteString -> Lazy.ByteString -> IO ()
200bscpy (PS _ _ 0 `Chunk` dest_rest) src = bscpy dest_rest src
201bscpy dest (PS _ _ 0 `Chunk` src_rest) = bscpy dest src_rest
202bscpy (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)
212bscpy _ _ = 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 #-}
4module 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
26import Control.Applicative
27import Control.Monad as L
28import Data.ByteString as BS
29import Data.ByteString.Internal as BS
30import Data.ByteString.Lazy as BL
31import Data.ByteString.Lazy.Internal as BL
32import Data.Default
33import Data.Vector as V -- TODO use unboxed vector
34import Foreign
35import System.IO.MMap
36
37import Data.Torrent.Layout
38
39
40data FileEntry = FileEntry
41 { filePosition :: {-# UNPACK #-} !FileOffset
42 , fileBytes :: {-# UNPACK #-} !BS.ByteString
43 } deriving (Show, Eq)
44
45type FileMap = Vector FileEntry
46
47instance Default Mode where
48 def = ReadWriteEx
49
50mmapFiles :: Mode -> FileLayout FileSize -> IO FileMap
51mmapFiles 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
60unmapFiles :: FileMap -> IO ()
61unmapFiles = V.mapM_ unmapEntry
62 where
63 unmapEntry (FileEntry _ (PS fptr _ _)) = finalizeForeignPtr fptr
64
65fromLazyByteString :: BL.ByteString -> FileMap
66fromLazyByteString 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)/.
73toLazyByteString :: FileMap -> BL.ByteString
74toLazyByteString = V.foldr f Empty
75 where
76 f FileEntry {..} bs = Chunk fileBytes bs
77
78-- | /O(1)/.
79size :: FileMap -> FileOffset
80size m
81 | V.null m = 0
82 | FileEntry {..} <- V.unsafeLast m
83 = filePosition + fromIntegral (BS.length fileBytes)
84
85bsearch :: FileOffset -> FileMap -> Maybe Int
86bsearch 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)/.
100drop :: FileOffset -> FileMap -> (FileSize, FileMap)
101drop 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)/.
107take :: FileSize -> FileMap -> (FileMap, FileSize)
108take 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'.
117unsafeReadBytes :: FileOffset -> FileSize -> FileMap -> BL.ByteString
118unsafeReadBytes 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
123readBytes :: FileOffset -> FileSize -> FileMap -> IO BL.ByteString
124readBytes 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
132bscpy :: BL.ByteString -> BL.ByteString -> IO ()
133bscpy (PS _ _ 0 `Chunk` dest_rest) src = bscpy dest_rest src
134bscpy dest (PS _ _ 0 `Chunk` src_rest) = bscpy dest src_rest
135bscpy (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)
145bscpy _ _ = return ()
146
147writeBytes :: FileOffset -> BL.ByteString -> FileMap -> IO ()
148writeBytes 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 #-}
19module System.Torrent.Storage 17module 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
38import Control.Applicative 32import Control.Applicative
39import Control.Concurrent.STM 33import Data.ByteString.Lazy as BL
40import Control.Exception
41import Control.Monad
42import Control.Monad.Trans
43
44import Data.ByteString as B
45import qualified Data.ByteString.Lazy as Lazy
46import Text.PrettyPrint
47import System.FilePath
48import System.Directory
49import Foreign.C.Error
50
51import Data.Torrent.Bitfield as BF
52import Data.Torrent.Block
53import Data.Torrent
54import System.IO.MMap.Fixed as Fixed
55
56-- TODO merge piece validation and Sessions.available into one transaction.
57data Storage = Storage {
58 -- |
59 metainfo :: !Torrent
60 34
61 -- | Bitmask of complete and verified _pieces_. 35import Data.Torrent.Layout
62 , complete :: !(TVar Bitfield) 36import Data.Torrent.Piece
37import 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 41data 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
76ppStorage :: Storage -> IO Doc 46-- ResourceT ?
77ppStorage Storage {..} = pp <$> readTVarIO blocks 47open :: Mode -> PieceSize -> FileLayout FileSize -> IO Storage
78 where 48open mode s l = Storage s <$> mmapFiles mode l
79 pp bf = int blockSize
80
81getCompleteBitfield :: Storage -> STM Bitfield
82getCompleteBitfield Storage {..} = readTVar complete
83
84{-----------------------------------------------------------------------
85 Construction
86-----------------------------------------------------------------------}
87 49
88-- TODO doc args 50close :: Storage -> IO ()
89openStorage :: Torrent -> FilePath -> Bitfield -> IO Storage 51close Storage {..} = unmapFiles fileMap
90openStorage 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 53writePiece :: Piece BL.ByteString -> Storage -> IO ()
95 Storage t <$> newTVarIO bf 54writePiece 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
107closeStorage :: Storage -> IO ()
108closeStorage st = return ()
109
110
111withStorage :: Torrent -> FilePath -> Bitfield -> (Storage -> IO a) -> IO a
112withStorage se path bf = bracket (openStorage se path bf) closeStorage
113 56
114{----------------------------------------------------------------------- 57readPiece :: PieceIx -> Storage -> IO (Piece BL.ByteString)
115 Modification 58readPiece 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 63unsafeReadPiece :: PieceIx -> Storage -> IO (Piece BL.ByteString)
119-- TODO make block_payload :: Lazy.ByteString 64unsafeReadPiece pix Storage {..} = return $ Piece pix lbs
120
121selBlk :: MonadIO m => PieceIx -> Storage -> m [BlockIx]
122selBlk 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--
149putBlk :: MonadIO m => Block -> Storage -> m Bool
150putBlk 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
160markBlock :: Block -> Storage -> IO ()
161markBlock 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--
171getBlk :: MonadIO m => BlockIx -> Storage -> m Block
172getBlk 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
179getPiece :: PieceIx -> Storage -> IO Lazy.ByteString
180getPiece 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
186resetPiece :: PieceIx -> Storage -> IO ()
187resetPiece pix st @ Storage {..}
188 = {-# SCC resetPiece #-} atomically $ do
189 mask <- pieceMask pix st
190 modifyTVar' blocks (`difference` mask)
191
192validatePiece :: Storage -> PieceIx -> IO Bool
193validatePiece storage pix = do
194 checkPiece (tInfo (metainfo storage)) pix <$> getPiece pix storage
195
196completePiece :: PieceIx -> Storage -> IO Bool
197completePiece 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--
217validateStorage :: Storage -> IO ()
218validateStorage st = undefined -- (`validatePiece` st) [0..pieceCount st]
219
220{-----------------------------------------------------------------------
221 POSIX-like file interface
222------------------------------------------------------------------------
223This is useful for virtual filesystem writers and just for per file
224interface.
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
230type Offset = Int
231type Size = Int
232
233data 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--
246openFD :: FilePath -> Bool -> Storage -> IO (Either Errno FD)
247openFD 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.
255flushFD :: FD -> IO Errno
256flushFD _ = return eOK
257
258-- | This call correspond to close(2).
259closeFD :: FD -> IO ()
260closeFD _ = return ()
261
262-- TODO
263maskRegion :: FD -> Offset -> Size -> Maybe Size
264maskRegion FD {..} offset siz = return siz
265
266-- TODO
267isComplete :: FD -> Offset -> Size -> IO Size
268isComplete _ _ siz = return siz
269
270-- TODO
271enqueueRead :: FD -> Offset -> Size -> IO ()
272enqueueRead _ _ _ = return ()
273
274-- TODO
275readAhead :: FD -> Offset -> Size -> IO ()
276readAhead _ _ _ = return ()
277
278-- TODO
279waitRegion :: FD -> Offset -> Size -> IO ByteString
280waitRegion _ _ _ = 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).
287readFD :: FD -> Offset -> Size -> IO (Either Errno ByteString)
288readFD 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.
307writeFD :: FD -> ByteString -> Offset -> IO ()
308writeFD FD {..} bs offset = return ()
309
310{-----------------------------------------------------------------------
311 Internal
312-----------------------------------------------------------------------}
313
314isDownloaded :: PieceIx -> Storage -> STM Bool
315isDownloaded pix st @ Storage {..} = do
316 bf <- readTVar blocks
317 mask <- pieceMask pix st
318 return $ intersection mask bf == mask
319
320pieceMask :: PieceIx -> Storage -> STM Bitfield
321pieceMask 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
329ixInterval :: Int -> BlockIx -> FixedInterval
330ixInterval pieceSize BlockIx {..} =
331 Fixed.interval (ixPiece * pieceSize + ixOffset) ixLength
332
333blkInterval :: Int -> Block -> FixedInterval
334blkInterval pieceSize Block {..} =
335 Fixed.interval (blkPiece * pieceSize + blkOffset)
336 (fromIntegral (Lazy.length blkData)) \ No newline at end of file
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 17:51:28 +0000