From 0ed2dc1155d4de0283c8d6a1e44507083426a9a3 Mon Sep 17 00:00:00 2001 From: Sam T Date: Wed, 3 Apr 2013 01:16:20 +0400 Subject: cabalize package --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 .gitignore (limited to '.gitignore') diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..316009b8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist +cabal-dev -- cgit v1.2.3 From 3325e02fa3a75878ad6f5519d88396e2cbaa3887 Mon Sep 17 00:00:00 2001 From: Sam T Date: Thu, 20 Jun 2013 19:56:52 +0400 Subject: ~ Ignore profiling files. --- .gitignore | 5 +++++ bittorrent.cabal | 8 +++++--- 2 files changed, 10 insertions(+), 3 deletions(-) (limited to '.gitignore') diff --git a/.gitignore b/.gitignore index 316009b8..7a0c156b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,7 @@ dist cabal-dev +*.aux +*.eventlog +*.hp +*.pdf +*.ps diff --git a/bittorrent.cabal b/bittorrent.cabal index 486975aa..e7b2e33d 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -114,8 +114,10 @@ executable exsample , bittorrent , mtl - ghc-options: -O2 -rtsopts -eventlog -threaded - ghc-prof-options: -prof -auto-all -caf-all + ghc-options: -O2 -rtsopts -threaded +-- -threaded -rtsopts +-- -eventlog +-- ghc-prof-options: -prof -auto-all -caf-all if !flag(testing) buildable: False @@ -184,4 +186,4 @@ benchmark benchmarks ghc-options: -O2 -Wall -fno-warn-orphans if !flag(testing) - buildable: False \ No newline at end of file + buildable: False -- cgit v1.2.3 From e028ac4b464d73f6afee1727d68cedc4e3ed24d5 Mon Sep 17 00:00:00 2001 From: Sam T Date: Thu, 20 Jun 2013 21:25:57 +0400 Subject: ~ merge mmap-fixed package into bittorrent. reason: mmap-fixed is pretty useless out of scope of bittorrent, at least i don't think that it'll be used some time that way. Moreover we can hide some internal stuff and simplify interface and simplify user code. Using mmap-fixed we can provide Storage datatype with all necessary operations needed to keep torrent content in memory of FS. Also that seems pretty annoying to merge this 2 repos into one using git merge(there are not so many stuff anyway), so I just did that manually. :< --- .ghci | 7 +- .gitignore | 1 + Makefile | 4 + bittorrent.cabal | 57 +++++++++---- src/System/IO/MMap/Fixed.hs | 203 ++++++++++++++++++++++++++++++++++++++++++++ tests/MMap.hs | 45 ++++++++++ 6 files changed, 301 insertions(+), 16 deletions(-) create mode 100644 Makefile create mode 100644 src/System/IO/MMap/Fixed.hs create mode 100644 tests/MMap.hs (limited to '.gitignore') diff --git a/.ghci b/.ghci index 21c0f3a6..6f391cbf 100644 --- a/.ghci +++ b/.ghci @@ -1,5 +1,10 @@ import Data.Serialize as S + import Network import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString -import Network.Torrent \ No newline at end of file + +import Network.Torrent + +import System.IO.MMap.Fixed as F +import System.IO.MMap.Fixed as Fixed \ No newline at end of file diff --git a/.gitignore b/.gitignore index 7a0c156b..b662ed9b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ dist cabal-dev +tmp *.aux *.eventlog *.hp diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..b5c055dc --- /dev/null +++ b/Makefile @@ -0,0 +1,4 @@ +.PHONY: clean + +clean: + rm -r tmp \ No newline at end of file diff --git a/bittorrent.cabal b/bittorrent.cabal index e7b2e33d..f99405fa 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -42,6 +42,7 @@ library , Network.BitTorrent.Exchange other-modules: Network.BitTorrent.Internal + , System.IO.MMap.Fixed if flag(testing) exposed-modules: Network.BitTorrent.Exchange.Protocol @@ -56,12 +57,12 @@ library build-depends: base == 4.* - -- Control packages + -- Control , mtl , resourcet , lens - -- Concurrency packages + -- Concurrency , SafeSemaphore , BoundedChan >= 1.0.1.0 , stm >= 2.4 @@ -71,50 +72,58 @@ library , network-conduit == 1.* , cereal-conduit >= 0.5 - -- Data packages + -- Data , array >= 0.4 - , bytestring - -- >= 0.10.2 - , containers >= 0.4 - , intset >= 0.1 + , bytestring >= 0.10 + + , containers >= 0.4 + , intset >= 0.1 + , IntervalMap >= 0.3 + , text >= 0.11.0 , vector - -- Encoding/Serialization packages + -- Encoding/Serialization , bencoding >= 0.1 , cereal >= 0.3 , urlencoded >= 0.4 - -- Time packages + -- Time , time >= 0.1 , old-locale >= 1.0 - -- Network packages + -- Network , network >= 2.4 , HTTP >= 4000.2 , krpc + -- System + , filepath >= 1 + , mmap >= 0.5.2 + -- Misc , data-default , cryptohash - , filepath >= 1 - , bits-atomic >= 0.1 , pretty + , bits-atomic >= 0.1 + extensions: PatternGuards hs-source-dirs: src if flag(testing) cpp-options: -DTESTING ghc-options: -Wall -executable exsample + + +executable example main-is: Main.hs - hs-source-dirs: exsamples + hs-source-dirs: examples build-depends: base == 4.* , bittorrent , mtl - ghc-options: -O2 -rtsopts -threaded + ghc-options: -O2 -rtsopts -threaded -- -threaded -rtsopts -- -eventlog -- ghc-prof-options: -prof -auto-all -caf-all @@ -123,6 +132,7 @@ executable exsample buildable: False + test-suite info-hash type: exitcode-stdio-1.0 main-is: InfoHash.hs @@ -143,6 +153,23 @@ test-suite info-hash +test-suite mmap + type: exitcode-stdio-1.0 + main-is: MMap.hs + build-depends: base == 4.* + , bytestring + , directory + + , HUnit + , test-framework + , test-framework-hunit + + , mmap-fixed + + hs-source-dirs: tests + + + test-suite properties type: exitcode-stdio-1.0 main-is: Main.hs diff --git a/src/System/IO/MMap/Fixed.hs b/src/System/IO/MMap/Fixed.hs new file mode 100644 index 00000000..9d2e354f --- /dev/null +++ b/src/System/IO/MMap/Fixed.hs @@ -0,0 +1,203 @@ +-- 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 +-- +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 + + -- * 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) + +-- | 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/tests/MMap.hs b/tests/MMap.hs new file mode 100644 index 00000000..a4be95f0 --- /dev/null +++ b/tests/MMap.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Test.HUnit +import Test.Framework +import Test.Framework.Providers.HUnit +import Data.Word + +import System.Directory +import System.IO.MMap.Fixed + + +boundaryTest = do + f <- mallocTo (interval 0 1) empty + f <- mallocTo (interval 1 2) f + writeElem f 0 (1 :: Word8) + writeElem f 1 (2 :: Word8) + bs <- readBytes (interval 0 2) f + "\x1\x2" @=? bs + +mmapSingle = do + f <- mmapTo "single.test" (10, 5) 5 empty + writeBytes (interval 5 5) "abcde" f + bs <- readBytes (interval 5 5) f + "abcde" @=? bs + +coalesceTest = do + f <- mmapTo "a.test" (0, 1) 10 empty + f <- mmapTo "bc.test" (0, 2) 12 f + f <- mmapTo "c.test" (0, 1) 13 f + writeBytes (interval 10 4) "abcd" f + bs <- readBytes (interval 10 4) f + "abcd" @=? bs + +main :: IO () +main = do + let tmpdir = "tmp" + createDirectoryIfMissing True tmpdir + setCurrentDirectory tmpdir + + defaultMain + [ testCase "boudary" boundaryTest + , testCase "single" mmapSingle + , testCase "coalesce" coalesceTest + ] \ No newline at end of file -- cgit v1.2.3 From b6b992d5594daa9405e6a5259e161d65af815a88 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 30 Jun 2013 18:41:48 +0400 Subject: ~ Ignore profiling files. --- .gitignore | 1 + 1 file changed, 1 insertion(+) (limited to '.gitignore') diff --git a/.gitignore b/.gitignore index b662ed9b..3d398cbd 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ tmp *.hp *.pdf *.ps +*.prof -- cgit v1.2.3 From 8ad997f8f8725391fbaba415b0e751f42288d697 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 23 Nov 2013 02:01:25 +0400 Subject: Ignore upload-docs script --- .gitignore | 1 + 1 file changed, 1 insertion(+) (limited to '.gitignore') diff --git a/.gitignore b/.gitignore index 3d398cbd..07041bab 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ dist cabal-dev tmp +upload-docs *.aux *.eventlog *.hp -- cgit v1.2.3 From 2b62a5da05832db21159ff81b78c8f41307cacee Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sat, 7 Dec 2013 13:12:45 +0100 Subject: Add cabal sandbox stuff to .gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) (limited to '.gitignore') diff --git a/.gitignore b/.gitignore index 07041bab..cbfbf7f9 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ dist cabal-dev +.cabal-sandbox +cabal.sandbox.config tmp upload-docs *.aux -- cgit v1.2.3 From 98c9297b6d74d4e1635716190a7cb83cd43a03e0 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 3 Jan 2014 22:55:14 +0400 Subject: Ignore torrent files --- .gitignore | 1 + 1 file changed, 1 insertion(+) (limited to '.gitignore') diff --git a/.gitignore b/.gitignore index cbfbf7f9..851c60cc 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,7 @@ cabal-dev cabal.sandbox.config tmp upload-docs +*.torrent *.aux *.eventlog *.hp -- cgit v1.2.3 From c3bcc1e84f7f7f49de1fcd75e589ed4099bff2ea Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sat, 4 Jan 2014 04:10:15 +0000 Subject: Test against rtorrent's dht server when enabled --- .gitignore | 1 + tests/Main.hs | 2 +- tests/Network/BitTorrent/DHT/MessageSpec.hs | 17 +++++++++++++++++ 3 files changed, 19 insertions(+), 1 deletion(-) (limited to '.gitignore') diff --git a/.gitignore b/.gitignore index 851c60cc..2880dc7b 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ upload-docs *.pdf *.ps *.prof +res/rtorrent-sessiondir diff --git a/tests/Main.hs b/tests/Main.hs index 32ee3992..63281cf3 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -12,7 +12,7 @@ import Data.Functor clients :: [(String, String)] clients = [ - ("rtorrent","rtorrent -p 51234-51234 testfile.torrent") ] + ("rtorrent","rtorrent -p 51234-51234 -O dht=on -O dht_port=6881 -O session=rtorrent-sessiondir testfile.torrent") ] main :: IO () main = do diff --git a/tests/Network/BitTorrent/DHT/MessageSpec.hs b/tests/Network/BitTorrent/DHT/MessageSpec.hs index ce2ac0de..af694470 100644 --- a/tests/Network/BitTorrent/DHT/MessageSpec.hs +++ b/tests/Network/BitTorrent/DHT/MessageSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} module Network.BitTorrent.DHT.MessageSpec (spec) where import Control.Monad.Reader +import Control.Concurrent import Data.BEncode as BE import Data.ByteString.Lazy as BL import Data.Default @@ -11,6 +12,7 @@ import Network.KRPC import Network.Socket (PortNumber) import Test.Hspec import Test.QuickCheck +import System.Timeout import Network.BitTorrent.CoreSpec () import Network.BitTorrent.DHT.TokenSpec () @@ -37,9 +39,24 @@ isProtocolError KError {..} = errorCode == ProtocolError prop_bencode :: Eq a => Show a => BEncode a => a -> Expectation prop_bencode x = BE.decode (BL.toStrict (BE.encode x)) `shouldBe` Right x +retry :: Int -> IO (Maybe a) -> IO (Maybe a) +retry 0 _ = return Nothing +retry n a = do + res <- a + case res of + Just _ -> return res + Nothing -> threadDelay (100 * 1000) >> retry (n-1) a + spec :: Spec spec = do context ("you need running DHT node at " ++ show remoteAddr) $ do + it "is running" $ do + _ <- retry 5 $ timeout (100 * 1000) $ do + nid <- genNodeId + Response _remoteAddr Ping <- + rpc (query remoteAddr (Query nid Ping)) + return () + return () describe "ping" $ do it "properly bencoded" $ do BE.decode "d2:id20:abcdefghij0123456789e" -- cgit v1.2.3 From dde56b9e13a66fc96b553d81e5a8bc09d6d9306f Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 12 Feb 2014 18:30:24 +0400 Subject: Ignore ./data directory --- .gitignore | 1 + 1 file changed, 1 insertion(+) (limited to '.gitignore') diff --git a/.gitignore b/.gitignore index 2880dc7b..2c7b83d1 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,7 @@ cabal-dev .cabal-sandbox cabal.sandbox.config tmp +data upload-docs *.torrent *.aux -- cgit v1.2.3 From 09950bdee9d5af82b1766c25fad46dfcb6a0e595 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 15 Feb 2014 05:17:07 +0400 Subject: Ignore nohup files --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) (limited to '.gitignore') diff --git a/.gitignore b/.gitignore index 2c7b83d1..7a23ede7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ +nohup.out + dist cabal-dev .cabal-sandbox -- cgit v1.2.3