Move some modules from torrent-content

7 files changed, 995 insertions, 4 deletions

diff --git a/.ghci b/.ghci
index 09a3d5f6..c5d93fc0 100644
--- a/.ghci
+++ b/.ghci
@@ -3,3 +3,5 @@ import Data.Serialize as S
 import Network
 import Network.Socket hiding (send, sendTo, recv, recvFrom)
 import Network.Socket.ByteString
+
+import Network.BitTorrent.DHT.Protocol
\ No newline at end of file
diff --git a/src/Data/Torrent/Bitfield.hs b/src/Data/Torrent/Bitfield.hs
new file mode 100644
index 00000000..f7e036d5
--- /dev/null
+++ b/src/Data/Torrent/Bitfield.hs
@@ -0,0 +1,359 @@
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   This modules provides all necessary machinery to work with
+--   bitfields. Bitfields are used to keep track indices of complete
+--   pieces either peer have or client have.
+--
+--   There are also commonly used piece seletion algorithms
+--   which used to find out which one next piece to download.
+--   Selectors considered to be used in the following order:
+--
+--     * Random first - at the start.
+--
+--     * Rarest first selection - performed to avoid situation when
+--     rarest piece is unaccessible.
+--
+--     * _End game_ seletion - performed after a peer has requested all
+--     the subpieces of the content.
+--
+--   Note that BitTorrent applies the strict priority policy for
+--   /subpiece/ or /blocks/ selection.
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Data.Torrent.Bitfield
+       ( PieceIx, PieceCount, Bitfield
+
+         -- * Construction
+       , haveAll, haveNone, have, singleton
+       , interval
+       , adjustSize
+
+         -- * Query
+       , Data.Torrent.Bitfield.null
+       , haveCount, totalCount, completeness
+
+       , member, notMember
+       , findMin, findMax
+
+       , isSubsetOf
+
+       , Frequency, frequencies, rarest
+
+         -- * Combine
+       , union
+       , intersection
+       , difference
+
+         -- * Serialization
+       , fromBitmap, toBitmap
+       , toList
+
+         -- * Selection
+       , Selector
+       , selector, strategyClass
+
+       , strictFirst, strictLast
+       , rarestFirst, randomFirst, endGame
+
+#if  defined (TESTING)
+         -- * Debug
+       , mkBitfield
+#endif
+       ) where
+
+import Control.Monad
+import Control.Monad.ST
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as Lazy
+import           Data.Vector.Unboxed (Vector)
+import qualified Data.Vector.Unboxed as V
+import qualified Data.Vector.Unboxed.Mutable as VM
+import           Data.IntervalSet (IntSet)
+import qualified Data.IntervalSet as S
+import qualified  Data.IntervalSet.ByteString as S
+import           Data.List (foldl')
+import           Data.Monoid
+import           Data.Ratio
+
+
+-- | Pieces indexed from zero up to 'PieceCount' value.
+type PieceIx = Int
+
+-- | Used to represent max set bound. Min set bound is always set to
+-- zero.
+type PieceCount = Int
+
+-- TODO cache some operations
+
+-- | Bitfields are represented just as integer sets but with
+-- restriction: the each set should be within given interval (or
+-- subset of the specified interval). Size is used to specify
+-- interval, so bitfield of size 10 might contain only indices in
+-- interval [0..9].
+--
+data Bitfield = Bitfield {
+    bfSize :: !PieceCount
+  , bfSet  :: !IntSet
+  } deriving (Show, Read, Eq)
+
+-- Invariants: all elements of bfSet lie in [0..bfSize - 1];
+
+instance Monoid Bitfield where
+  {-# SPECIALIZE instance Monoid Bitfield #-}
+  mempty  = haveNone 0
+  mappend = union
+  mconcat = unions
+
+{-----------------------------------------------------------------------
+    Construction
+-----------------------------------------------------------------------}
+
+-- | The empty bitfield of the given size.
+haveNone :: PieceCount -> Bitfield
+haveNone s = Bitfield s S.empty
+
+-- | The full bitfield containing all piece indices for the given size.
+haveAll :: PieceCount -> Bitfield
+haveAll s = Bitfield s (S.interval 0 (s - 1))
+
+-- | Insert the index in the set ignoring out of range indices.
+have :: PieceIx -> Bitfield -> Bitfield
+have ix Bitfield {..}
+  | 0 <= ix && ix < bfSize = Bitfield bfSize (S.insert ix bfSet)
+  |      otherwise         = Bitfield bfSize bfSet
+
+singleton :: PieceIx -> PieceCount -> Bitfield
+singleton ix pc = have ix (haveNone pc)
+
+-- | Assign new size to bitfield. FIXME Normally, size should be only
+-- decreased, otherwise exception raised.
+adjustSize :: PieceCount -> Bitfield -> Bitfield
+adjustSize s Bitfield {..} = Bitfield s bfSet
+
+-- | NOTE: for internal use only
+interval :: PieceCount -> PieceIx -> PieceIx -> Bitfield
+interval pc a b = Bitfield pc (S.interval a b)
+
+{-----------------------------------------------------------------------
+    Query
+-----------------------------------------------------------------------}
+
+-- | Test if bitifield have no one index: peer do not have anything.
+null :: Bitfield -> Bool
+null Bitfield {..} = S.null bfSet
+
+-- | Count of peer have pieces.
+haveCount :: Bitfield -> PieceCount
+haveCount = S.size . bfSet
+
+-- | Total count of pieces and its indices.
+totalCount :: Bitfield -> PieceCount
+totalCount = bfSize
+
+-- | Ratio of /have/ piece count to the /total/ piece count.
+--
+--   > forall bf. 0 <= completeness bf <= 1
+--
+completeness :: Bitfield -> Ratio PieceCount
+completeness b = haveCount b % totalCount b
+
+inRange :: PieceIx -> Bitfield -> Bool
+inRange ix Bitfield {..} = 0 <= ix && ix < bfSize
+
+member :: PieceIx -> Bitfield -> Bool
+member ix bf @ Bitfield {..}
+  | ix `inRange` bf = ix `S.member` bfSet
+  |     otherwise   = False
+
+notMember :: PieceIx -> Bitfield -> Bool
+notMember ix bf @ Bitfield {..}
+  | ix `inRange` bf = ix `S.notMember` bfSet
+  |     otherwise   = True
+
+-- | Find first available piece index.
+findMin :: Bitfield -> PieceIx
+findMin = S.findMin . bfSet
+{-# INLINE findMin #-}
+
+-- | Find last available piece index.
+findMax :: Bitfield -> PieceIx
+findMax = S.findMax . bfSet
+{-# INLINE findMax #-}
+
+isSubsetOf :: Bitfield -> Bitfield -> Bool
+isSubsetOf a b = bfSet a `S.isSubsetOf` bfSet b
+
+-- | Frequencies are needed in piece selection startegies which use
+-- availability quantity to find out the optimal next piece index to
+-- download.
+type Frequency = Int
+
+-- | How many times each piece index occur in the given bitfield set.
+frequencies :: [Bitfield] -> Vector Frequency
+frequencies [] = V.fromList []
+frequencies xs = runST $ do
+    v <- VM.new size
+    VM.set v 0
+    forM_ xs $ \ Bitfield {..} -> do
+      forM_ (S.toList bfSet) $ \ x -> do
+        fr <- VM.read v x
+        VM.write v x (succ fr)
+    V.unsafeFreeze v
+  where
+    size = maximum (map bfSize xs)
+
+-- TODO it seems like this operation is veeery slow
+
+-- | Find least available piece index. If no piece available return
+-- 'Nothing'.
+rarest :: [Bitfield] -> Maybe PieceIx
+rarest xs
+    | V.null freqMap = Nothing
+    |     otherwise
+    = Just $ fst $ V.ifoldr' minIx (0, freqMap V.! 0) freqMap
+  where
+    freqMap = frequencies xs
+
+    minIx ::  PieceIx -> Frequency
+          -> (PieceIx,   Frequency)
+          -> (PieceIx,   Frequency)
+    minIx ix fr acc@(_, fra)
+      | fr < fra && fr > 0 = (ix, fr)
+      |     otherwise      = acc
+
+
+{-----------------------------------------------------------------------
+    Combine
+-----------------------------------------------------------------------}
+
+-- | Find indices at least one peer have.
+union :: Bitfield -> Bitfield -> Bitfield
+union a b = {-# SCC union #-} Bitfield {
+    bfSize = bfSize a `max` bfSize b
+  , bfSet  = bfSet a `S.union` bfSet b
+  }
+
+-- | Find indices both peers have.
+intersection :: Bitfield -> Bitfield -> Bitfield
+intersection a b = {-# SCC intersection #-} Bitfield {
+    bfSize = bfSize a `min` bfSize b
+  , bfSet  = bfSet a `S.intersection` bfSet b
+  }
+
+-- | Find indices which have first peer but do not have the second peer.
+difference :: Bitfield -> Bitfield -> Bitfield
+difference a b = {-# SCC difference #-} Bitfield {
+    bfSize = bfSize a -- FIXME is it reasonable?
+  , bfSet  = bfSet a `S.difference` bfSet b
+  }
+
+-- | Find indices the any of the peers have.
+unions :: [Bitfield] -> Bitfield
+unions = {-# SCC unions #-} foldl' union (haveNone 0)
+
+{-----------------------------------------------------------------------
+    Serialization
+-----------------------------------------------------------------------}
+
+-- | List all have indexes.
+toList :: Bitfield -> [PieceIx]
+toList Bitfield {..} = S.toList bfSet
+
+-- | Unpack 'Bitfield' from tightly packed bit array. Note resulting
+-- size might be more than real bitfield size, use 'adjustSize'.
+fromBitmap :: ByteString -> Bitfield
+fromBitmap bs = {-# SCC fromBitmap #-} Bitfield {
+    bfSize = B.length bs * 8
+  , bfSet  = S.fromByteString bs
+  }
+{-# INLINE fromBitmap #-}
+
+-- | Pack a 'Bitfield' to tightly packed bit array.
+toBitmap :: Bitfield -> Lazy.ByteString
+toBitmap Bitfield {..} = {-# SCC toBitmap #-} Lazy.fromChunks [intsetBM, alignment]
+  where
+    byteSize  = bfSize `div` 8 + if bfSize `mod` 8 == 0 then 0 else 1
+    alignment = B.replicate (byteSize - B.length intsetBM) 0
+    intsetBM  = S.toByteString bfSet
+
+{-----------------------------------------------------------------------
+    Debug
+-----------------------------------------------------------------------}
+
+-- | For internal use only.
+mkBitfield :: PieceCount -> [PieceIx] -> Bitfield
+mkBitfield s ixs = Bitfield {
+    bfSize = s
+  , bfSet  = S.splitGT (-1) $ S.splitLT s $ S.fromList ixs
+  }
+
+{-----------------------------------------------------------------------
+    Selection
+-----------------------------------------------------------------------}
+
+type Selector =  Bitfield      -- ^ Indices of client /have/ pieces.
+             ->  Bitfield      -- ^ Indices of peer /have/ pieces.
+             -> [Bitfield]     -- ^ Indices of other peers /have/ pieces.
+             -> Maybe PieceIx  -- ^ Zero-based index of piece to request
+                               --   to, if any.
+
+selector :: Selector       -- ^ Selector to use at the start.
+         -> Ratio PieceCount
+         -> Selector       -- ^ Selector to use after the client have
+                           -- the C pieces.
+         -> Selector       -- ^ Selector that changes behaviour based
+                           -- on completeness.
+selector start pt ready   h a xs =
+  case strategyClass pt h of
+    SCBeginning -> start h a xs
+    SCReady     -> ready h a xs
+    SCEnd       -> endGame h a xs
+
+data StartegyClass
+  = SCBeginning
+  | SCReady
+  | SCEnd
+    deriving (Show, Eq, Ord, Enum, Bounded)
+
+
+strategyClass :: Ratio PieceCount -> Bitfield -> StartegyClass
+strategyClass threshold = classify . completeness
+  where
+    classify c
+      |        c < threshold       = SCBeginning
+      | c + 1 % numerator c < 1    = SCReady
+    -- FIXME numerator have is not total count
+      |          otherwise         = SCEnd
+
+
+-- | Select the first available piece.
+strictFirst :: Selector
+strictFirst h a _ = Just $ findMin (difference a h)
+
+-- | Select the last available piece.
+strictLast :: Selector
+strictLast h a _ = Just $ findMax (difference a h)
+
+-- |
+rarestFirst :: Selector
+rarestFirst h a xs = rarest (map (intersection want) xs)
+  where
+    want = difference h a
+
+-- | In average random first is faster than rarest first strategy but
+--    only if all pieces are available.
+randomFirst :: Selector
+randomFirst = do
+--  randomIO
+  error "randomFirst"
+
+endGame :: Selector
+endGame = strictLast
diff --git a/src/Network/BitTorrent/DHT/Protocol.hs b/src/Network/BitTorrent/DHT/Protocol.hs
index 73e5fa68..0ac814b7 100644
--- a/src/Network/BitTorrent/DHT/Protocol.hs
+++ b/src/Network/BitTorrent/DHT/Protocol.hs
@@ -42,7 +42,7 @@ import Network.BitTorrent.Exchange.Protocol ()
 
 type NodeId = ByteString
 
--- WARN is the 'system' random suitable for this?
+-- TODO WARN is the 'system' random suitable for this?
 -- | Generate random NodeID used for the entire session.
 --   Distribution of ID's should be as uniform as possible.
 --
@@ -56,9 +56,7 @@ data NodeAddr = NodeAddr {
 
 instance Serialize NodeAddr where
   get = NodeAddr <$> getWord32be <*> get
-  put NodeAddr {..} = do
-    putWord32be nodeIP
-    put         nodePort
+  put NodeAddr {..} = putWord32be nodeIP >> put nodePort
 
 data NodeInfo = NodeInfo {
     nodeID   :: !NodeId
diff --git a/src/Network/BitTorrent/Discovery.hs b/src/Network/BitTorrent/Discovery.hs
new file mode 100644
index 00000000..f26864a7
--- /dev/null
+++ b/src/Network/BitTorrent/Discovery.hs
@@ -0,0 +1,4 @@
+type PeerCount = Int
+
+defaultChanSize :: PeerCount
+defaultChanSize = defaultNumWant * 2
diff --git a/src/System/IO/MMap/Fixed.hs b/src/System/IO/MMap/Fixed.hs
new file mode 100644
index 00000000..1e83c350
--- /dev/null
+++ b/src/System/IO/MMap/Fixed.hs
@@ -0,0 +1,212 @@
+-- TODO pprint
+-- TODO see if this IntervalMap is overkill: Interval dataty have 4 constrs
+-- TODO clarify lifetime in docs
+-- TODO use madvise
+-- TODO unmap selected interval
+-- TODO tests
+-- TODO benchmarks
+-- TODO unmap overlapped regions
+-- [A] TODO lazy mapping for 32 bit arch;
+--          we need tricky algorithm and a lot of perf tests
+-- TODO use memmove in write bytes
+-- TODO write elem, write byte, read byte
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   This library provides mechanism to mmap files to fixed address
+--   with fine-grained control. Hovewer, instead of using MAP_FIXED we
+--   create our own address space upon virtual address space. If you
+--   would like you could call this space as "fixed address space".
+--
+--   This solves a few problems:
+--
+--     * Page already in use. If you mmap one file at 0..x addresses and
+--     want to map second file to x..y addresses using MAP_FIXED you
+--     can get in troubles: page might be mapped already. Raw call to
+--     mmap will silently unmap x..y addresses and then mmap our second
+--     file. So here we have extra unmap we would like to avoid.
+--
+--     * Page boundaries. If you mmap one file at x..x+1 you could
+--     not map next file to say addresses x+1..x+2.
+--
+--   Internally we make ordinary call to mmap to map a file and then
+--   using /interval map/ we map fixed address space to virtual
+--   address space. It takes TODO time in TODO cases.
+--
+--   Basically this library could be used when we need coalesce
+--   several files in arbitrary way. We could map at any position as
+--   long as offset + size fit in 'Int'.
+--
+--   For other details see:
+--
+--   > http://hackage.haskell.org/package/mmap
+--   > man mmap
+--
+{-# LANGUAGE RecordWildCards #-}
+module System.IO.MMap.Fixed
+       ( -- * Intervals
+         FixedOffset, FileOffset, FixedInterval, FileInterval
+       , interval, fileInterval
+
+         -- * Construction
+       , Fixed, Bytes
+       , System.IO.MMap.Fixed.empty, insertTo
+       , coalesceFiles
+
+         -- ** Specialized 'insertTo'
+       , mmapTo, mallocTo
+       , lookupRegion
+
+         -- * Query
+       , upperAddr
+
+         -- * Access
+       , viewBytes, readBytes, writeBytes
+       , readElem, writeElem
+       ) where
+
+import Data.ByteString.Lazy as Lazy
+import Data.ByteString.Lazy.Internal as Lazy
+import Data.ByteString.Internal as B
+import Data.List as L
+import Data.Int
+import Data.IntervalMap.Strict as M
+import Data.IntervalMap.Interval
+import System.IO.MMap
+import Foreign
+
+
+type FixedOffset = Int
+type FileOffset  = Int64
+type Size   = Int
+
+
+type FileInterval  = (FileOffset, Size)
+type FixedInterval = Interval FixedOffset
+
+
+interval :: FixedOffset -> Size -> FixedInterval
+interval off s = IntervalCO off (off + fromIntegral (max 0 s))
+{-# INLINE interval #-}
+
+fileInterval :: FileOffset -> Size -> FileInterval
+fileInterval off s = (off, s)
+{-# INLINE fileInterval #-}
+
+intervalSize :: FixedInterval -> Size
+intervalSize i = upperBound i - lowerBound i
+{-# INLINE intervalSize #-}
+
+
+type Bytes = (ForeignPtr Word8, Size)
+
+type FixedMap = IntervalMap FixedOffset Bytes
+
+newtype Fixed = Fixed { imap :: FixedMap }
+
+instance Show Fixed where
+  show = show . M.toList . imap
+
+
+mapIM :: (FixedMap -> FixedMap) -> Fixed -> Fixed
+mapIM f s = s { imap = f (imap s) }
+
+empty :: Fixed
+empty = Fixed M.empty
+
+coalesceFiles :: [(FilePath, Int)] -> IO Fixed
+coalesceFiles = go 0 System.IO.MMap.Fixed.empty
+  where
+    go _      s []       = return s
+    go offset s ((path, bsize) : xs) = do
+      s' <- mmapTo path (0, bsize) offset s
+      go (offset + bsize) s' xs
+
+upperAddr :: Fixed -> FixedOffset
+upperAddr = upperBound . fst . findLast . imap
+
+insertTo :: FixedInterval -> Bytes -> Fixed -> Fixed
+insertTo fi mm = mapIM (M.insert fi mm)
+{-# INLINE insertTo #-}
+
+mmapTo :: FilePath -> FileInterval -> FixedOffset -> Fixed -> IO Fixed
+mmapTo path mrange to s = do
+  (fptr, offset, fsize) <- mmapFileForeignPtr path ReadWriteEx (Just mrange)
+
+  let fixed  = interval to fsize
+  let mmaped = (fptr, offset)
+
+  return $ insertTo fixed mmaped s
+
+mallocTo :: FixedInterval -> Fixed -> IO Fixed
+mallocTo fi s = do
+  let bsize = intervalSize fi
+  fptr <- mallocForeignPtrBytes bsize
+  return (insertTo fi (fptr, 0) s)
+
+lookupRegion :: FixedOffset -> Fixed -> Maybe B.ByteString
+lookupRegion offset Fixed {..} =
+  case intersecting imap $ IntervalCO offset (succ offset) of
+    [(i, (fptr, off))] -> let s = upperBound i - lowerBound i
+                          in  Just $ fromForeignPtr fptr off (max 0 s)
+    _         -> Nothing
+
+-- | Note: this is unsafe operation.
+viewBytes :: FixedInterval -> Fixed -> Lazy.ByteString
+viewBytes fi s = fromChunks $ L.map mk $ (imap s `intersecting` fi)
+  where
+   mk (i, (fptr, offset)) =
+     let dropB = max 0 (lowerBound fi - lowerBound i)
+         dropT = max 0 (upperBound i  - upperBound fi)
+         bsize = intervalSize i - (dropT + dropB)
+     in fromForeignPtr fptr (offset + dropB) bsize
+
+
+readBytes :: FixedInterval -> Fixed -> IO Lazy.ByteString
+readBytes fi s = let c = Lazy.copy (viewBytes fi s) in mkCopy c >> return c
+{-# INLINE readBytes #-}
+
+writeBytes :: FixedInterval -> Lazy.ByteString -> Fixed -> IO ()
+writeBytes fi bs s = bscpy (viewBytes fi s) bs
+{-# INLINE writeBytes #-}
+
+-- | Note: this operation takes O(log(files count)) time, if possible
+-- use readBytes.
+readElem :: Storable a => Fixed -> FixedOffset -> IO a
+readElem s offset = go undefined
+  where
+    go :: Storable a => a -> IO a
+    go dont_touch = do
+      let bsize = sizeOf dont_touch
+      let PS fptr off _ = Lazy.toStrict (viewBytes (interval offset bsize) s)
+      withForeignPtr fptr $ \ ptr -> peekByteOff ptr off
+
+writeElem :: Storable a => Fixed -> FixedOffset -> a -> IO ()
+writeElem s offset x = do
+  let bsize = sizeOf x
+  let PS fptr off _ = Lazy.toStrict (viewBytes (interval offset bsize) s)
+  withForeignPtr fptr $ \ptr -> pokeByteOff ptr off x
+
+
+mkCopy :: Lazy.ByteString -> IO ()
+mkCopy Empty = return ()
+mkCopy (Chunk _ x) = mkCopy x
+
+bscpy :: Lazy.ByteString -> Lazy.ByteString -> IO ()
+bscpy (PS _ _ 0 `Chunk` dest_rest) src                         = bscpy dest_rest src
+bscpy dest                         (PS _ _ 0 `Chunk` src_rest) = bscpy dest      src_rest
+bscpy (PS dest_fptr dest_off dest_size `Chunk` dest_rest)
+      (PS src_fptr  src_off  src_size  `Chunk` src_rest)
+  = do let csize = min dest_size src_size
+       withForeignPtr dest_fptr $ \dest_ptr ->
+         withForeignPtr src_fptr $ \src_ptr ->
+           memcpy (dest_ptr `advancePtr` dest_off)
+                  (src_ptr  `advancePtr` src_off)
+                  (fromIntegral csize) -- TODO memmove?
+       bscpy (PS dest_fptr (dest_off + csize) (dest_size - csize) `Chunk` dest_rest)
+             (PS src_fptr  (src_off  + csize) (src_size  - csize) `Chunk` src_rest)
+bscpy _ _ = return ()
\ No newline at end of file
diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs
new file mode 100644
index 00000000..16f888bf
--- /dev/null
+++ b/src/System/Torrent/Storage.hs
@@ -0,0 +1,336 @@
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  non-portable
+--
+--   This module implements mapping from single continious block space
+--   to file storage. Storage can be used in two modes:
+--
+--     * As in memory storage - in this case we don't touch filesystem.
+--
+--     * As ordinary mmaped file storage - when we need to store
+--       data in the filesystem.
+--
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE RecordWildCards #-}
+module System.Torrent.Storage
+       ( Storage (metainfo)
+       , ppStorage
+
+         -- * Construction
+       , openStorage, closeStorage, withStorage
+       , getCompleteBitfield
+
+         -- * Modification
+       , getBlk, putBlk, selBlk
+       , getPiece, validatePiece
+
+         -- * TODO expose only File interface!
+         -- * File interface
+       , FD
+       , openFD, flushFD, closeFD
+       , readFD, writeFD
+       ) where
+
+import Control.Applicative
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import Control.Monad.Trans
+
+import Data.ByteString as B
+import qualified Data.ByteString.Lazy as Lazy
+import Text.PrettyPrint
+import System.FilePath
+import System.Directory
+import Foreign.C.Error
+
+import Data.Torrent.Bitfield as BF
+import Data.Torrent.Block
+import Data.Torrent.Metainfo
+import System.IO.MMap.Fixed as Fixed
+
+-- TODO merge piece validation and Sessions.available into one transaction.
+data Storage = Storage {
+    -- |
+    metainfo  :: !Torrent
+
+    -- | Bitmask of complete and verified _pieces_.
+  , complete  :: !(TVar  Bitfield)
+
+    -- | Bitmask of complete _blocks_.
+  , blocks    :: !(TVar Bitfield)
+    -- TODO use bytestring for fast serialization
+    -- because we need to write this bitmap to disc periodically
+
+  , blockSize :: !Int
+
+    -- | Used to map linear block addresses to disjoint
+    -- mallocated/mmaped adresses.
+  , payload :: !Fixed
+  }
+
+ppStorage :: Storage -> IO Doc
+ppStorage Storage {..} = pp <$> readTVarIO blocks
+  where
+    pp bf = int blockSize
+
+getCompleteBitfield :: Storage -> STM Bitfield
+getCompleteBitfield Storage {..} = readTVar complete
+
+{-----------------------------------------------------------------------
+    Construction
+-----------------------------------------------------------------------}
+
+-- TODO doc args
+openStorage :: Torrent -> FilePath -> Bitfield -> IO Storage
+openStorage t @ Torrent {..} contentPath bf = do
+    let content_paths = contentLayout contentPath tInfo
+    mapM_ (mkDir . fst)  content_paths
+
+    let blockSize = defaultBlockSize `min` ciPieceLength tInfo
+    Storage t <$> newTVarIO bf
+              <*> newTVarIO (haveNone (blockCount blockSize tInfo))
+              <*> pure blockSize
+              <*> coalesceFiles content_paths
+  where
+    mkDir path = do
+      let dirPath = fst (splitFileName path)
+      exist <- doesDirectoryExist dirPath
+      unless exist $ do
+        createDirectoryIfMissing True dirPath
+
+-- TODO
+closeStorage :: Storage -> IO ()
+closeStorage st = return ()
+
+
+withStorage :: Torrent -> FilePath -> Bitfield -> (Storage -> IO a) -> IO a
+withStorage se path bf = bracket (openStorage se path bf) closeStorage
+
+{-----------------------------------------------------------------------
+    Modification
+-----------------------------------------------------------------------}
+
+-- TODO to avoid races we might need to try Control.Concurrent.yield
+-- TODO make block_payload :: Lazy.ByteString
+
+selBlk :: MonadIO m => PieceIx -> Storage -> m [BlockIx]
+selBlk pix st @ Storage {..}
+  = liftIO $ {-# SCC selBlk #-} atomically $ do
+    mask <- pieceMask pix st
+    select mask <$> readTVar blocks
+  where
+    select mask = fmap mkBix . toList . difference mask
+    -- TODO clip upper bound of block index
+    mkBix ix  = BlockIx pix (blockSize * (ix - offset)) blockSize
+
+    offset    = coeff * pix
+    coeff     = ciPieceLength (tInfo metainfo)  `div` blockSize
+
+--
+-- TODO make global lock map -- otherwise we might get broken pieces
+--
+-- imagine the following situation:
+--
+--   thread1: write
+--   thread1: mark
+--
+-- this let us avoid races as well
+--
+
+-- | Write a block to the storage. If block out of range then block is clipped.
+--
+--
+--
+putBlk :: MonadIO m => Block -> Storage -> m Bool
+putBlk blk @ Block {..}  st @ Storage {..}
+  = liftIO $ {-# SCC putBlk #-} do
+--  let blkIx = undefined
+--  bm <- readTVarIO blocks
+--  unless (member blkIx bm) $ do
+    writeBytes (blkInterval (ciPieceLength (tInfo metainfo)) blk)  blkData  payload
+
+    markBlock blk st
+    completePiece blkPiece st
+
+markBlock :: Block -> Storage -> IO ()
+markBlock Block {..} Storage {..} = {-# SCC markBlock #-} do
+  let piLen = ciPieceLength (tInfo metainfo)
+  let glIx  = (piLen `div` blockSize) * blkPiece + (blkOffset `div` blockSize)
+  atomically $ modifyTVar' blocks (have glIx)
+
+-- | Read a block by given block index. If lower or upper bound out of
+-- range then index is clipped.
+--
+--  Do not block.
+--
+getBlk :: MonadIO m => BlockIx -> Storage -> m Block
+getBlk ix @ BlockIx {..}  st @ Storage {..}
+  = liftIO $ {-# SCC getBlk #-} do
+  -- TODO check if __piece__ is available
+  let piLen = ciPieceLength (tInfo metainfo)
+  bs <- readBytes (ixInterval piLen ix) payload
+  return $ Block ixPiece ixOffset bs
+
+getPiece :: PieceIx -> Storage -> IO Lazy.ByteString
+getPiece pix st @ Storage {..} = {-# SCC getPiece #-} do
+  let piLen = ciPieceLength (tInfo metainfo)
+  let bix   = BlockIx pix 0 piLen
+  let bs    = viewBytes (ixInterval piLen bix) payload
+  return $ bs
+
+resetPiece :: PieceIx -> Storage -> IO ()
+resetPiece pix st @ Storage {..}
+  = {-# SCC resetPiece #-} atomically $ do
+  mask <- pieceMask pix st
+  modifyTVar' blocks (`difference` mask)
+
+validatePiece :: Storage -> PieceIx -> IO Bool
+validatePiece storage pix = do
+  checkPiece (tInfo (metainfo storage)) pix <$> getPiece pix storage
+
+completePiece :: PieceIx -> Storage -> IO Bool
+completePiece pix st @ Storage {..} = {-# SCC completePiece #-} do
+  downloaded <- atomically $ isDownloaded pix st
+  if not downloaded then return False
+    else do
+      piece <- getPiece pix st
+      if checkPiece (tInfo metainfo) pix piece
+        then do
+          atomically $ modifyTVar' complete (BF.have pix)
+          return True
+        else do
+          print $ "----------------------------- invalid " ++ show pix
+--          resetPiece pix st
+          return True
+
+-- | Check each piece in the storage against content info hash.
+--
+--   Note that this function will block until each the entire storage
+--   checked. This may take a long time for a big torrents ­ use fork
+--   if needed.
+--
+validateStorage :: Storage -> IO ()
+validateStorage st = undefined -- (`validatePiece` st) [0..pieceCount st]
+
+{-----------------------------------------------------------------------
+  POSIX-like file interface
+------------------------------------------------------------------------
+This is useful for virtual filesystem writers and just for per file
+interface.
+-----------------------------------------------------------------------}
+-- TODO reference counting: storage might be closed before all FDs
+-- gets closed!
+-- or we can forbid to close storage and use finalizers only?
+
+type Offset = Int
+type Size   = Int
+
+data FD = FD {
+    fdData    :: ByteString
+  , fdNoBlock :: Bool
+  }
+
+
+-- TODO return "is dir" error
+-- | This call correspond to open(2) with the following parameters:
+--
+--     * OpenMode = ReadOnly;
+--
+--     * OpenFileFlags = O_NONBLOCK. (not true yet)
+--
+openFD :: FilePath -> Bool -> Storage -> IO (Either Errno FD)
+openFD path nonblock Storage {..}
+  | Just offset <- fileOffset path (tInfo metainfo)
+  , Just bs     <- lookupRegion (fromIntegral offset) payload
+  = return $ Right $ FD bs nonblock
+  | otherwise = return $ Left $ eNOENT
+
+-- | Cancel all enqueued read operations and report any delayed
+-- errors.
+flushFD :: FD -> IO Errno
+flushFD _ = return eOK
+
+-- | This call correspond to close(2).
+closeFD :: FD -> IO ()
+closeFD _ = return ()
+
+-- TODO
+maskRegion :: FD -> Offset -> Size -> Maybe Size
+maskRegion FD {..} offset siz = return siz
+
+-- TODO
+isComplete :: FD -> Offset -> Size -> IO Size
+isComplete _ _ siz = return siz
+
+-- TODO
+enqueueRead :: FD -> Offset -> Size -> IO ()
+enqueueRead _ _ _ = return ()
+
+-- TODO
+readAhead :: FD -> Offset -> Size -> IO ()
+readAhead _ _ _ = return ()
+
+-- TODO
+waitRegion :: FD -> Offset -> Size -> IO ByteString
+waitRegion _ _ _ = return B.empty
+
+-- TODO implement blocking and non blocking modes?
+-- TODO check if region completely downloaded
+-- TODO if not we could return EAGAIN
+-- TODO enqueue read to piece manager
+-- | This call correspond to pread(2).
+readFD :: FD -> Offset -> Size -> IO (Either Errno ByteString)
+readFD fd @ FD {..} offset reqSize =
+  case maskRegion fd offset reqSize of
+    Nothing      -> return $ Right B.empty
+    Just expSize -> do
+      availSize <- isComplete fd offset expSize
+      if availSize == expSize then haveAllReg expSize else haveSomeReg expSize
+  where
+    haveAllReg expSize = do
+      readAhead fd offset expSize
+      return $ Right $ slice offset expSize fdData
+
+    haveSomeReg expSize
+      | fdNoBlock = return $ Left $ eAGAIN
+      | otherwise = do
+        bs <- waitRegion fd offset expSize
+        readAhead fd offset expSize
+        return $ Right bs
+
+-- TODO implement COW; needed for applications which want to change files.
+writeFD :: FD -> ByteString -> Offset -> IO ()
+writeFD FD {..} bs offset = return ()
+
+{-----------------------------------------------------------------------
+    Internal
+-----------------------------------------------------------------------}
+
+isDownloaded :: PieceIx -> Storage -> STM Bool
+isDownloaded pix st @ Storage {..} = do
+  bf   <- readTVar blocks
+  mask <- pieceMask pix st
+  return $ intersection mask bf == mask
+
+pieceMask :: PieceIx -> Storage -> STM Bitfield
+pieceMask pix Storage {..} =  do
+    bf <- readTVar blocks
+    return $ BF.interval (totalCount bf) offset (offset + coeff - 1)
+  where
+    offset    = coeff * pix
+    coeff     = ciPieceLength (tInfo metainfo) `div` blockSize
+
+
+ixInterval :: Int -> BlockIx -> FixedInterval
+ixInterval pieceSize BlockIx {..} =
+  Fixed.interval (ixPiece * pieceSize + ixOffset) ixLength
+
+blkInterval :: Int -> Block -> FixedInterval
+blkInterval pieceSize Block {..} =
+  Fixed.interval (blkPiece * pieceSize + blkOffset)
+                 (fromIntegral (Lazy.length blkData))
\ No newline at end of file
diff --git a/tests/Main.hs b/tests/Main.hs
index fb69565d..6180069f 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -59,6 +59,86 @@ instance Arbitrary URI where
 instance Arbitrary Text where
   arbitrary = T.pack <$> arbitrary
 
+{-
+{-----------------------------------------------------------------------
+    MemMap
+-----------------------------------------------------------------------}
+
+tmpdir :: FilePath
+tmpdir = "tmp"
+
+boundaryTest :: Assertion
+boundaryTest = do
+  f <- mallocTo (Fixed.interval 0 1) Fixed.empty
+  f <- mallocTo (Fixed.interval 1 2) f
+  writeElem f 0 (1 :: Word8)
+  writeElem f 1 (2 :: Word8)
+  bs <- readBytes (Fixed.interval 0 2) f
+  "\x1\x2" @=? bs
+
+mmapSingle :: Assertion
+mmapSingle = do
+  f  <- mmapTo (tmpdir </> "single.test") (10, 5) 5 Fixed.empty
+  writeBytes (Fixed.interval 5 5) "abcde" f
+  bs <- readBytes (Fixed.interval 5 5) f
+  "abcde" @=? bs
+
+coalesceTest :: Assertion
+coalesceTest = do
+  f <- mmapTo (tmpdir </> "a.test")  (0, 1) 10 Fixed.empty
+  f <- mmapTo (tmpdir </> "bc.test") (0, 2) 12 f
+  f <- mmapTo (tmpdir </> "c.test")  (0, 1) 13 f
+  writeBytes (Fixed.interval 10 4) "abcd" f
+  bs <- readBytes  (Fixed.interval 10 4) f
+  "abcd" @=? bs
+-}
+
+{-----------------------------------------------------------------------
+    Bitfield
+-----------------------------------------------------------------------}
+-- other properties are tested in IntervalSet
+
+prop_completenessRange :: Bitfield -> Bool
+prop_completenessRange bf = 0 <= c && c <= 1
+  where
+    c = completeness bf
+
+prop_minMax :: Bitfield -> Bool
+prop_minMax bf
+  | BF.null bf = True
+  | otherwise  = BF.findMin bf <= BF.findMax bf
+
+prop_rarestInRange :: [Bitfield] -> Bool
+prop_rarestInRange xs = case rarest xs of
+  Just r  -> 0 <= r
+          && r < totalCount (maximumBy (comparing totalCount) xs)
+  Nothing -> True
+
+{- this one should give pretty good coverage -}
+prop_differenceDeMorgan :: Bitfield -> Bitfield -> Bitfield -> Bool
+prop_differenceDeMorgan a b c =
+  (a `BF.difference` (b `BF.intersection` c))
+     == ((a `BF.difference` b) `BF.union` (a `BF.difference` c))
+  &&
+  (a `BF.difference` (b `BF.union` c))
+     == ((a `BF.difference` b) `BF.intersection` (a `BF.difference` c))
+
+              {-
+  [ -- mem map
+    testCase "boudary"  boundaryTest
+  , testCase "single"   mmapSingle
+  , testCase "coalesce" coalesceTest
+  ]
+
+instance Arbitrary Bitfield where
+  arbitrary = mkBitfield <$> (succ . min 1000 <$> positive)
+                         <*> arbitrary
+
+    testProperty "completeness range"      prop_completenessRange
+  , testProperty "rarest in range"         prop_rarestInRange
+  , testProperty "min less that max"       prop_minMax
+  , testProperty "difference de morgan"    prop_differenceDeMorgan
+-}
 {-----------------------------------------------------------------------
     Handshake
 -----------------------------------------------------------------------}