From 7a892425de92efd88b98576e848bebc725a9bf14 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 4 Apr 2014 20:30:54 +0400 Subject: Move Infohash and Magnet to Torrent module --- tests/Network/BitTorrent/Client/HandleSpec.hs | 2 +- tests/Network/BitTorrent/DHT/TestData.hs | 2 +- tests/Network/BitTorrent/DHTSpec.hs | 2 +- tests/Network/BitTorrent/Exchange/ConnectionSpec.hs | 1 - tests/Network/BitTorrent/Tracker/TestData.hs | 2 +- 5 files changed, 4 insertions(+), 5 deletions(-) (limited to 'tests/Network') diff --git a/tests/Network/BitTorrent/Client/HandleSpec.hs b/tests/Network/BitTorrent/Client/HandleSpec.hs index 8e16d9b0..d51bab02 100644 --- a/tests/Network/BitTorrent/Client/HandleSpec.hs +++ b/tests/Network/BitTorrent/Client/HandleSpec.hs @@ -2,7 +2,7 @@ module Network.BitTorrent.Client.HandleSpec (spec) where import Data.Default import Test.Hspec -import Data.Torrent.Magnet +import Data.Torrent import Network.BitTorrent.Client import Network.BitTorrent.Client.Handle diff --git a/tests/Network/BitTorrent/DHT/TestData.hs b/tests/Network/BitTorrent/DHT/TestData.hs index 2e000a77..e9473cbb 100644 --- a/tests/Network/BitTorrent/DHT/TestData.hs +++ b/tests/Network/BitTorrent/DHT/TestData.hs @@ -3,7 +3,7 @@ module Network.BitTorrent.DHT.TestData , testTorrents ) where -import Data.Torrent.InfoHash +import Data.Torrent data TestEntry = TestEntry { entryName :: String diff --git a/tests/Network/BitTorrent/DHTSpec.hs b/tests/Network/BitTorrent/DHTSpec.hs index 76b48257..30abc867 100644 --- a/tests/Network/BitTorrent/DHTSpec.hs +++ b/tests/Network/BitTorrent/DHTSpec.hs @@ -6,7 +6,7 @@ import Data.List as L import Test.Hspec import System.Timeout -import Data.Torrent.InfoHash +import Data.Torrent import Network.BitTorrent.DHT diff --git a/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs b/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs index c21f55ef..ccbf2854 100644 --- a/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs +++ b/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs @@ -8,7 +8,6 @@ import Test.Hspec import Test.QuickCheck import Data.Torrent -import Data.Torrent.InfoHash import Network.BitTorrent.Core import Network.BitTorrent.Exchange.Connection import Network.BitTorrent.Exchange.Message diff --git a/tests/Network/BitTorrent/Tracker/TestData.hs b/tests/Network/BitTorrent/Tracker/TestData.hs index e0edba25..b95e2df4 100644 --- a/tests/Network/BitTorrent/Tracker/TestData.hs +++ b/tests/Network/BitTorrent/Tracker/TestData.hs @@ -12,7 +12,7 @@ import Data.Maybe import Data.String import Network.URI -import Data.Torrent.InfoHash +import Data.Torrent data TrackerEntry = TrackerEntry -- cgit v1.2.3 From 052bed30a3d83aa8fb7b8b42509ad96f573439af Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 4 Apr 2014 21:44:18 +0400 Subject: Move HashList to Torrent module --- bittorrent.cabal | 1 - src/Data/Torrent.hs | 199 +++++++++++++++++- src/Data/Torrent/Bitfield.hs | 2 +- src/Data/Torrent/Piece.hs | 232 --------------------- src/Network/BitTorrent/DHT/Session.hs | 2 +- src/Network/BitTorrent/Exchange/Assembler.hs | 2 +- src/Network/BitTorrent/Exchange/Block.hs | 2 +- src/Network/BitTorrent/Exchange/Message.hs | 10 +- src/Network/BitTorrent/Exchange/Session.hs | 3 +- .../BitTorrent/Exchange/Session/Metadata.hs | 1 - src/Network/BitTorrent/Exchange/Session/Status.hs | 2 +- src/System/Torrent/Storage.hs | 2 - tests/Data/Torrent/MetainfoSpec.hs | 1 - tests/Data/Torrent/PieceSpec.hs | 2 +- .../BitTorrent/Exchange/Session/MetadataSpec.hs | 5 +- tests/System/Torrent/StorageSpec.hs | 3 +- 16 files changed, 213 insertions(+), 256 deletions(-) delete mode 100644 src/Data/Torrent/Piece.hs (limited to 'tests/Network') diff --git a/bittorrent.cabal b/bittorrent.cabal index 9d687d7d..9a86702d 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -46,7 +46,6 @@ library hs-source-dirs: src exposed-modules: Data.Torrent Data.Torrent.Bitfield - Data.Torrent.Piece Data.Torrent.Progress Data.Torrent.Tree Network.BitTorrent diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs index 701da9dd..98d6f94e 100644 --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs @@ -86,6 +86,34 @@ module Data.Torrent -- ** Internal , sizeInBase + -- * Pieces + -- ** Attributes + , PieceIx + , PieceCount + , PieceSize + , minPieceSize + , maxPieceSize + , defaultPieceSize + , PieceHash + + -- ** Piece data + , Piece (..) + , pieceSize + , hashPiece + + -- ** Piece control + , HashList (..) + , PieceInfo (..) + , pieceCount + + -- ** Lens + , pieceLength + , pieceHashes + + -- ** Validation + , pieceHash + , checkPieceLazy + -- * Info dictionary , InfoDict (..) , infoDictionary @@ -133,8 +161,11 @@ import Control.Exception import Control.Lens hiding (unsnoc) import Control.Monad import qualified Crypto.Hash.SHA1 as C +import qualified Crypto.Hash.SHA1 as SHA1 import Data.BEncode as BE import Data.BEncode.Types as BE +import Data.Bits +import Data.Bits.Extras import Data.ByteString as BS import Data.ByteString.Base16 as Base16 import Data.ByteString.Base32 as Base32 @@ -146,6 +177,7 @@ import Data.Convertible import Data.Default import Data.Foldable as F import Data.Hashable as Hashable +import Data.Int import qualified Data.List as L import Data.Map as M import Data.Maybe @@ -166,7 +198,6 @@ import Text.PrettyPrint.Class import System.FilePath import System.Posix.Types -import Data.Torrent.Piece import Network.BitTorrent.Core.NodeInfo @@ -526,6 +557,171 @@ sizeInBase n b = fromIntegral (n `div` fromIntegral b) + align {-# SPECIALIZE sizeInBase :: Int -> Int -> Int #-} {-# SPECIALIZE sizeInBase :: Integer -> Int -> Int #-} +{----------------------------------------------------------------------- +-- Piece attributes +-----------------------------------------------------------------------} + +-- | Zero-based index of piece in torrent content. +type PieceIx = Int + +-- | Size of piece in bytes. Should be a power of 2. +-- +-- NOTE: Have max and min size constrained to wide used +-- semi-standard values. This bounds should be used to make decision +-- about piece size for new torrents. +-- +type PieceSize = Int + +-- | Number of pieces in torrent or a part of torrent. +type PieceCount = Int + +defaultBlockSize :: Int +defaultBlockSize = 16 * 1024 + +-- | Optimal number of pieces in torrent. +optimalPieceCount :: PieceCount +optimalPieceCount = 1000 +{-# INLINE optimalPieceCount #-} + +-- | Piece size should not be less than this value. +minPieceSize :: Int +minPieceSize = defaultBlockSize * 4 +{-# INLINE minPieceSize #-} + +-- | To prevent transfer degradation piece size should not exceed this +-- value. +maxPieceSize :: Int +maxPieceSize = 4 * 1024 * 1024 +{-# INLINE maxPieceSize #-} + +toPow2 :: Int -> Int +toPow2 x = bit $ fromIntegral (leadingZeros (0 :: Int) - leadingZeros x) + +-- | Find the optimal piece size for a given torrent size. +defaultPieceSize :: Int64 -> Int +defaultPieceSize x = max minPieceSize $ min maxPieceSize $ toPow2 pc + where + pc = fromIntegral (x `div` fromIntegral optimalPieceCount) + +{----------------------------------------------------------------------- +-- Piece data +-----------------------------------------------------------------------} + +type PieceHash = ByteString + +hashsize :: Int +hashsize = 20 +{-# INLINE hashsize #-} + +-- TODO check if pieceLength is power of 2 +-- | Piece payload should be strict or lazy bytestring. +data Piece a = Piece + { -- | Zero-based piece index in torrent. + pieceIndex :: {-# UNPACK #-} !PieceIx + + -- | Payload. + , pieceData :: !a + } deriving (Show, Read, Eq, Functor, Typeable) + +instance NFData (Piece a) + +-- | Payload bytes are omitted. +instance Pretty (Piece a) where + pretty Piece {..} = "Piece" <+> braces ("index" <+> "=" <+> int pieceIndex) + +-- | Get size of piece in bytes. +pieceSize :: Piece BL.ByteString -> PieceSize +pieceSize Piece {..} = fromIntegral (BL.length pieceData) + +-- | Get piece hash. +hashPiece :: Piece BL.ByteString -> PieceHash +hashPiece Piece {..} = SHA1.hashlazy pieceData + +{----------------------------------------------------------------------- +-- Piece control +-----------------------------------------------------------------------} + +-- | A flat array of SHA1 hash for each piece. +newtype HashList = HashList { unHashList :: ByteString } + deriving (Show, Read, Eq, BEncode, Typeable) + +-- | Empty hash list. +instance Default HashList where + def = HashList "" + +-- | Part of torrent file used for torrent content validation. +data PieceInfo = PieceInfo + { piPieceLength :: {-# UNPACK #-} !PieceSize + -- ^ Number of bytes in each piece. + + , piPieceHashes :: !HashList + -- ^ Concatenation of all 20-byte SHA1 hash values. + } deriving (Show, Read, Eq, Typeable) + +-- | Number of bytes in each piece. +makeLensesFor [("piPieceLength", "pieceLength")] ''PieceInfo + +-- | Concatenation of all 20-byte SHA1 hash values. +makeLensesFor [("piPieceHashes", "pieceHashes")] ''PieceInfo + +instance NFData PieceInfo + +instance Default PieceInfo where + def = PieceInfo 1 def + +class Lint a where + lint :: a -> Either String a + +instance Lint PieceInfo where + lint pinfo @ PieceInfo {..} + | BS.length (unHashList piPieceHashes) `rem` hashsize == 0 + , piPieceLength >= 0 = return pinfo + | otherwise = Left undefined + + +putPieceInfo :: Data.Torrent.Put PieceInfo +putPieceInfo PieceInfo {..} cont = + "piece length" .=! piPieceLength + .: "pieces" .=! piPieceHashes + .: cont + +getPieceInfo :: BE.Get PieceInfo +getPieceInfo = do + PieceInfo <$>! "piece length" + <*>! "pieces" + +instance BEncode PieceInfo where + toBEncode = toDict . (`putPieceInfo` endDict) + fromBEncode = fromDict getPieceInfo + +-- | Hashes are omitted. +instance Pretty PieceInfo where + pretty PieceInfo {..} = "Piece size: " <> int piPieceLength + +slice :: Int -> Int -> ByteString -> ByteString +slice start len = BS.take len . BS.drop start +{-# INLINE slice #-} + +-- | Extract validation hash by specified piece index. +pieceHash :: PieceInfo -> PieceIx -> PieceHash +pieceHash PieceInfo {..} i = slice (hashsize * i) hashsize (unHashList piPieceHashes) + +-- | Find count of pieces in the torrent. If torrent size is not a +-- multiple of piece size then the count is rounded up. +pieceCount :: PieceInfo -> PieceCount +pieceCount PieceInfo {..} = BS.length (unHashList piPieceHashes) `quot` hashsize + +-- | Test if this is last piece in torrent content. +isLastPiece :: PieceInfo -> PieceIx -> Bool +isLastPiece ci i = pieceCount ci == succ i + +-- | Validate piece with metainfo hash. +checkPieceLazy :: PieceInfo -> Piece BL.ByteString -> Bool +checkPieceLazy pinfo @ PieceInfo {..} Piece {..} + = (fromIntegral (BL.length pieceData) == piPieceLength + || isLastPiece pinfo pieceIndex) + && SHA1.hashlazy pieceData == pieceHash pinfo pieceIndex + {----------------------------------------------------------------------- -- Info dictionary -----------------------------------------------------------------------} @@ -620,6 +816,7 @@ instance Pretty InfoDict where {----------------------------------------------------------------------- -- Torrent info -----------------------------------------------------------------------} +-- TODO add torrent file validation -- | Metainfo about particular torrent. data Torrent = Torrent diff --git a/src/Data/Torrent/Bitfield.hs b/src/Data/Torrent/Bitfield.hs index b65f058b..ff701d75 100644 --- a/src/Data/Torrent/Bitfield.hs +++ b/src/Data/Torrent/Bitfield.hs @@ -92,7 +92,7 @@ import Data.List (foldl') import Data.Monoid import Data.Ratio -import Data.Torrent.Piece +import Data.Torrent -- TODO cache some operations diff --git a/src/Data/Torrent/Piece.hs b/src/Data/Torrent/Piece.hs deleted file mode 100644 index d4b2c399..00000000 --- a/src/Data/Torrent/Piece.hs +++ /dev/null @@ -1,232 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Pieces are used to validate torrent content. --- -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.Torrent.Piece - ( -- * Piece attributes - PieceIx - , PieceCount - , PieceSize - , minPieceSize - , maxPieceSize - , defaultPieceSize - , PieceHash - - -- * Piece data - , Piece (..) - , pieceSize - , hashPiece - - -- * Piece control - , HashList (..) - , PieceInfo (..) - , pieceCount - - -- * Lens - , pieceLength - , pieceHashes - - -- * Validation - , pieceHash - , checkPieceLazy - - -- * Internal - , getPieceInfo - , putPieceInfo - ) where - -import Control.DeepSeq -import Control.Lens -import qualified Crypto.Hash.SHA1 as SHA1 -import Data.BEncode -import Data.BEncode.Types -import Data.Bits -import Data.Bits.Extras -import Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Base64 as Base64 -import Data.Default -import Data.Int -import Data.Text.Encoding as T -import Data.Typeable -import Text.PrettyPrint -import Text.PrettyPrint.Class - - --- TODO add torrent file validation -class Lint a where - lint :: a -> Either String a - ---class Validation a where --- validate :: PieceInfo -> Piece a -> Bool - -{----------------------------------------------------------------------- --- Piece attributes ------------------------------------------------------------------------} - --- | Zero-based index of piece in torrent content. -type PieceIx = Int - --- | Size of piece in bytes. Should be a power of 2. --- --- NOTE: Have max and min size constrained to wide used --- semi-standard values. This bounds should be used to make decision --- about piece size for new torrents. --- -type PieceSize = Int - --- | Number of pieces in torrent or a part of torrent. -type PieceCount = Int - -defaultBlockSize :: Int -defaultBlockSize = 16 * 1024 - --- | Optimal number of pieces in torrent. -optimalPieceCount :: PieceCount -optimalPieceCount = 1000 -{-# INLINE optimalPieceCount #-} - --- | Piece size should not be less than this value. -minPieceSize :: Int -minPieceSize = defaultBlockSize * 4 -{-# INLINE minPieceSize #-} - --- | To prevent transfer degradation piece size should not exceed this --- value. -maxPieceSize :: Int -maxPieceSize = 4 * 1024 * 1024 -{-# INLINE maxPieceSize #-} - -toPow2 :: Int -> Int -toPow2 x = bit $ fromIntegral (leadingZeros (0 :: Int) - leadingZeros x) - --- | Find the optimal piece size for a given torrent size. -defaultPieceSize :: Int64 -> Int -defaultPieceSize x = max minPieceSize $ min maxPieceSize $ toPow2 pc - where - pc = fromIntegral (x `div` fromIntegral optimalPieceCount) - -{----------------------------------------------------------------------- --- Piece data ------------------------------------------------------------------------} - -type PieceHash = ByteString - -hashsize :: Int -hashsize = 20 -{-# INLINE hashsize #-} - --- TODO check if pieceLength is power of 2 --- | Piece payload should be strict or lazy bytestring. -data Piece a = Piece - { -- | Zero-based piece index in torrent. - pieceIndex :: {-# UNPACK #-} !PieceIx - - -- | Payload. - , pieceData :: !a - } deriving (Show, Read, Eq, Functor, Typeable) - -instance NFData (Piece a) - --- | Payload bytes are omitted. -instance Pretty (Piece a) where - pretty Piece {..} = "Piece" <+> braces ("index" <+> "=" <+> int pieceIndex) - --- | Get size of piece in bytes. -pieceSize :: Piece BL.ByteString -> PieceSize -pieceSize Piece {..} = fromIntegral (BL.length pieceData) - --- | Get piece hash. -hashPiece :: Piece BL.ByteString -> PieceHash -hashPiece Piece {..} = SHA1.hashlazy pieceData - -{----------------------------------------------------------------------- --- Piece control ------------------------------------------------------------------------} - --- | A flat array of SHA1 hash for each piece. -newtype HashList = HashList { unHashList :: ByteString } - deriving (Show, Read, Eq, BEncode, Typeable) - --- | Empty hash list. -instance Default HashList where - def = HashList "" - --- | Part of torrent file used for torrent content validation. -data PieceInfo = PieceInfo - { piPieceLength :: {-# UNPACK #-} !PieceSize - -- ^ Number of bytes in each piece. - - , piPieceHashes :: !HashList - -- ^ Concatenation of all 20-byte SHA1 hash values. - } deriving (Show, Read, Eq, Typeable) - --- | Number of bytes in each piece. -makeLensesFor [("piPieceLength", "pieceLength")] ''PieceInfo - --- | Concatenation of all 20-byte SHA1 hash values. -makeLensesFor [("piPieceHashes", "pieceHashes")] ''PieceInfo - -instance NFData PieceInfo - -instance Default PieceInfo where - def = PieceInfo 1 def - -instance Lint PieceInfo where - lint pinfo @ PieceInfo {..} - | BS.length (unHashList piPieceHashes) `rem` hashsize == 0 - , piPieceLength >= 0 = return pinfo - | otherwise = Left undefined - - -putPieceInfo :: PieceInfo -> BDict -> BDict -putPieceInfo PieceInfo {..} cont = - "piece length" .=! piPieceLength - .: "pieces" .=! piPieceHashes - .: cont - -getPieceInfo :: Get PieceInfo -getPieceInfo = do - PieceInfo <$>! "piece length" - <*>! "pieces" - -instance BEncode PieceInfo where - toBEncode = toDict . (`putPieceInfo` endDict) - fromBEncode = fromDict getPieceInfo - --- | Hashes are omitted. -instance Pretty PieceInfo where - pretty PieceInfo {..} = "Piece size: " <> int piPieceLength - -slice :: Int -> Int -> ByteString -> ByteString -slice start len = BS.take len . BS.drop start -{-# INLINE slice #-} - --- | Extract validation hash by specified piece index. -pieceHash :: PieceInfo -> PieceIx -> PieceHash -pieceHash PieceInfo {..} i = slice (hashsize * i) hashsize (unHashList piPieceHashes) - --- | Find count of pieces in the torrent. If torrent size is not a --- multiple of piece size then the count is rounded up. -pieceCount :: PieceInfo -> PieceCount -pieceCount PieceInfo {..} = BS.length (unHashList piPieceHashes) `quot` hashsize - --- | Test if this is last piece in torrent content. -isLastPiece :: PieceInfo -> PieceIx -> Bool -isLastPiece ci i = pieceCount ci == succ i - --- | Validate piece with metainfo hash. -checkPieceLazy :: PieceInfo -> Piece BL.ByteString -> Bool -checkPieceLazy pinfo @ PieceInfo {..} Piece {..} - = (fromIntegral (BL.length pieceData) == piPieceLength - || isLastPiece pinfo pieceIndex) - && SHA1.hashlazy pieceData == pieceHash pinfo pieceIndex diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs index 87a6d4ea..8fe81abd 100644 --- a/src/Network/BitTorrent/DHT/Session.hs +++ b/src/Network/BitTorrent/DHT/Session.hs @@ -91,7 +91,7 @@ import System.Random (randomIO) import Text.PrettyPrint as PP hiding ((<>), ($$)) import Text.PrettyPrint.Class -import Data.Torrent +import Data.Torrent as Torrent import Network.KRPC hiding (Options, def) import qualified Network.KRPC as KRPC (def) import Network.BitTorrent.Core diff --git a/src/Network/BitTorrent/Exchange/Assembler.hs b/src/Network/BitTorrent/Exchange/Assembler.hs index e5834948..e17dfbe2 100644 --- a/src/Network/BitTorrent/Exchange/Assembler.hs +++ b/src/Network/BitTorrent/Exchange/Assembler.hs @@ -67,7 +67,7 @@ import Data.Map as M import Data.Maybe import Data.IP -import Data.Torrent.Piece +import Data.Torrent import Network.BitTorrent.Core import Network.BitTorrent.Exchange.Block as B diff --git a/src/Network/BitTorrent/Exchange/Block.hs b/src/Network/BitTorrent/Exchange/Block.hs index 16c124e9..ccc7a0a9 100644 --- a/src/Network/BitTorrent/Exchange/Block.hs +++ b/src/Network/BitTorrent/Exchange/Block.hs @@ -69,7 +69,7 @@ import Numeric import Text.PrettyPrint as PP hiding ((<>)) import Text.PrettyPrint.Class -import Data.Torrent.Piece +import Data.Torrent {----------------------------------------------------------------------- -- Block attributes diff --git a/src/Network/BitTorrent/Exchange/Message.hs b/src/Network/BitTorrent/Exchange/Message.hs index bd5c6526..5ca7c97e 100644 --- a/src/Network/BitTorrent/Exchange/Message.hs +++ b/src/Network/BitTorrent/Exchange/Message.hs @@ -118,8 +118,8 @@ import Text.PrettyPrint as PP hiding ((<>)) import Text.PrettyPrint.Class import Data.Torrent.Bitfield -import Data.Torrent -import qualified Data.Torrent.Piece as P +import Data.Torrent hiding (Piece (..)) +import qualified Data.Torrent as P (Piece (..)) import Network.BitTorrent.Core import Network.BitTorrent.Exchange.Block @@ -864,7 +864,7 @@ instance PeerMessage ExtendedMetadata where -- | All 'Piece's in 'MetadataData' messages MUST have size equal to -- this value. The last trailing piece can be shorter. -metadataPieceSize :: P.PieceSize +metadataPieceSize :: PieceSize metadataPieceSize = 16 * 1024 isLastPiece :: P.Piece a -> Int -> Bool @@ -877,8 +877,8 @@ isLastPiece P.Piece {..} total = succ pieceIndex == pcnt -- length; otherwise serialization MUST fail. isValidPiece :: P.Piece BL.ByteString -> Int -> Bool isValidPiece p @ P.Piece {..} total - | isLastPiece p total = P.pieceSize p <= metadataPieceSize - | otherwise = P.pieceSize p == metadataPieceSize + | isLastPiece p total = pieceSize p <= metadataPieceSize + | otherwise = pieceSize p == metadataPieceSize setMetadataPayload :: BS.ByteString -> ExtendedMetadata -> ExtendedMetadata setMetadataPayload bs (MetadataData (P.Piece pix _) t) = diff --git a/src/Network/BitTorrent/Exchange/Session.hs b/src/Network/BitTorrent/Exchange/Session.hs index 0adb08c8..cae3a2d5 100644 --- a/src/Network/BitTorrent/Exchange/Session.hs +++ b/src/Network/BitTorrent/Exchange/Session.hs @@ -45,8 +45,7 @@ import Text.PrettyPrint.Class import System.Log.FastLogger (LogStr, ToLogStr (..)) import Data.BEncode as BE -import Data.Torrent as T -import Data.Torrent.Piece as Torrent +import Data.Torrent as Torrent import Data.Torrent.Bitfield as BF import Network.BitTorrent.Internal.Types import Network.BitTorrent.Core diff --git a/src/Network/BitTorrent/Exchange/Session/Metadata.hs b/src/Network/BitTorrent/Exchange/Session/Metadata.hs index bdd5b322..a4e54659 100644 --- a/src/Network/BitTorrent/Exchange/Session/Metadata.hs +++ b/src/Network/BitTorrent/Exchange/Session/Metadata.hs @@ -27,7 +27,6 @@ import Data.Tuple import Data.BEncode as BE import Data.Torrent as Torrent -import Data.Torrent.Piece as Torrent import Network.BitTorrent.Core import Network.BitTorrent.Exchange.Block as Block import Network.BitTorrent.Exchange.Message as Message hiding (Status) diff --git a/src/Network/BitTorrent/Exchange/Session/Status.hs b/src/Network/BitTorrent/Exchange/Session/Status.hs index 565c3bf3..4feff8d6 100644 --- a/src/Network/BitTorrent/Exchange/Session/Status.hs +++ b/src/Network/BitTorrent/Exchange/Session/Status.hs @@ -28,7 +28,7 @@ import Data.Map as M import Data.Set as S import Data.Tuple -import Data.Torrent.Piece +import Data.Torrent import Data.Torrent.Bitfield as BF import Network.BitTorrent.Core import Network.BitTorrent.Exchange.Block as Block diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs index 697e3def..1123cea9 100644 --- a/src/System/Torrent/Storage.hs +++ b/src/System/Torrent/Storage.hs @@ -57,8 +57,6 @@ import Data.Typeable import Data.Torrent import Data.Torrent.Bitfield as BF -import Data.Torrent -import Data.Torrent.Piece import System.Torrent.FileMap as FM diff --git a/tests/Data/Torrent/MetainfoSpec.hs b/tests/Data/Torrent/MetainfoSpec.hs index 537b3f99..1a8f97c7 100644 --- a/tests/Data/Torrent/MetainfoSpec.hs +++ b/tests/Data/Torrent/MetainfoSpec.hs @@ -14,7 +14,6 @@ import Test.QuickCheck import Test.QuickCheck.Instances () import Data.Torrent -import Data.Torrent.Piece import Data.Torrent.LayoutSpec () import Network.BitTorrent.Core.NodeInfoSpec () diff --git a/tests/Data/Torrent/PieceSpec.hs b/tests/Data/Torrent/PieceSpec.hs index ef1f2938..d3933396 100644 --- a/tests/Data/Torrent/PieceSpec.hs +++ b/tests/Data/Torrent/PieceSpec.hs @@ -3,7 +3,7 @@ module Data.Torrent.PieceSpec (spec) where import Control.Applicative import Test.Hspec import Test.QuickCheck -import Data.Torrent.Piece +import Data.Torrent instance Arbitrary a => Arbitrary (Piece a) where diff --git a/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs b/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs index 975ceb5b..5392d74b 100644 --- a/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs +++ b/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs @@ -7,8 +7,7 @@ import Test.Hspec import Test.QuickCheck import Data.BEncode as BE -import Data.Torrent -import Data.Torrent.Piece as P +import Data.Torrent as Torrent import Network.BitTorrent.Core import Network.BitTorrent.Exchange.Message import Network.BitTorrent.Exchange.Session.Metadata @@ -36,7 +35,7 @@ simulateFetch :: InfoDict -> Updates (Maybe InfoDict) simulateFetch dict = go where blocks = chunkBy metadataPieceSize (BL.toStrict (BE.encode dict)) - packPiece ix = P.Piece ix (blocks !! ix) + packPiece ix = Torrent.Piece ix (blocks !! ix) ih = idInfoHash dict go = do diff --git a/tests/System/Torrent/StorageSpec.hs b/tests/System/Torrent/StorageSpec.hs index ebf4fe3e..96f1b036 100644 --- a/tests/System/Torrent/StorageSpec.hs +++ b/tests/System/Torrent/StorageSpec.hs @@ -7,9 +7,8 @@ import System.Directory import System.IO.Unsafe import Test.Hspec -import Data.Torrent.Bitfield as BF import Data.Torrent -import Data.Torrent.Piece +import Data.Torrent.Bitfield as BF import System.Torrent.Storage -- cgit v1.2.3 From 7e597cd924d2149b10f900c7dc14ce6e1e321cb5 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 4 Apr 2014 23:06:41 +0400 Subject: [Spec] Follow module layout changes in Torrent --- bittorrent.cabal | 6 +- tests/Data/Torrent/InfoHashSpec.hs | 38 ------- tests/Data/Torrent/LayoutSpec.hs | 30 ----- tests/Data/Torrent/MagnetSpec.hs | 44 ------- tests/Data/Torrent/MetainfoSpec.hs | 78 ------------- tests/Data/Torrent/PieceSpec.hs | 13 --- tests/Data/TorrentSpec.hs | 139 +++++++++++++++++++++++ tests/Network/BitTorrent/DHT/MessageSpec.hs | 2 +- tests/Network/BitTorrent/DHT/SessionSpec.hs | 2 +- tests/Network/BitTorrent/Exchange/MessageSpec.hs | 2 +- tests/Network/BitTorrent/Tracker/MessageSpec.hs | 2 +- 11 files changed, 144 insertions(+), 212 deletions(-) delete mode 100644 tests/Data/Torrent/InfoHashSpec.hs delete mode 100644 tests/Data/Torrent/LayoutSpec.hs delete mode 100644 tests/Data/Torrent/MagnetSpec.hs delete mode 100644 tests/Data/Torrent/MetainfoSpec.hs delete mode 100644 tests/Data/Torrent/PieceSpec.hs create mode 100644 tests/Data/TorrentSpec.hs (limited to 'tests/Network') diff --git a/bittorrent.cabal b/bittorrent.cabal index 9a86702d..6953816d 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -176,12 +176,8 @@ test-suite spec other-modules: Spec Config + Data.TorrentSpec Data.Torrent.BitfieldSpec - Data.Torrent.InfoHashSpec - Data.Torrent.LayoutSpec - Data.Torrent.MagnetSpec - Data.Torrent.MetainfoSpec - Data.Torrent.PieceSpec Data.Torrent.ProgressSpec Network.BitTorrent.Client.HandleSpec Network.BitTorrent.CoreSpec diff --git a/tests/Data/Torrent/InfoHashSpec.hs b/tests/Data/Torrent/InfoHashSpec.hs deleted file mode 100644 index 9accc741..00000000 --- a/tests/Data/Torrent/InfoHashSpec.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent.InfoHashSpec (spec) where - -import Control.Applicative -import Data.ByteString as BS -import Data.Convertible -import System.FilePath -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () - -import Data.Torrent - -instance Arbitrary InfoHash where - arbitrary = do - bs <- BS.pack <$> vectorOf 20 arbitrary - pure $ either (const (error "arbitrary infohash")) id $ safeConvert bs - -type TestPair = (FilePath, String) - --- TODO add a few more torrents here -torrentList :: [TestPair] -torrentList = - [ ( "res" "dapper-dvd-amd64.iso.torrent" - , "0221caf96aa3cb94f0f58d458e78b0fc344ad8bf") - ] - -infohashSpec :: (FilePath, String) -> Spec -infohashSpec (filepath, expectedHash) = do - it ("should match " ++ filepath) $ do - torrent <- fromFile filepath - let actualHash = show $ idInfoHash $ tInfoDict torrent - actualHash `shouldBe` expectedHash - -spec :: Spec -spec = do - describe "info hash" $ do - mapM_ infohashSpec torrentList diff --git a/tests/Data/Torrent/LayoutSpec.hs b/tests/Data/Torrent/LayoutSpec.hs deleted file mode 100644 index a3fe7c02..00000000 --- a/tests/Data/Torrent/LayoutSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -module Data.Torrent.LayoutSpec (spec) where - -import Control.Applicative -import Test.Hspec -import Test.QuickCheck -import System.Posix.Types - -import Data.Torrent - - -instance Arbitrary COff where - arbitrary = fromIntegral <$> (arbitrary :: Gen Int) - -instance Arbitrary a => Arbitrary (FileInfo a) where - arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary LayoutInfo where - arbitrary = oneof - [ SingleFile <$> arbitrary - , MultiFile <$> arbitrary <*> arbitrary - ] - -spec :: Spec -spec = do - describe "accumPosition" $ do - it "" $ property $ \ p1 p2 p3 s1 s2 s3 -> - accumPositions [(p1, s1), (p2, s2), (p3, s3)] - `shouldBe` [(p1, (0, s1)), (p2, (s1, s2)), (p3, (s1 + s2, s3))] \ No newline at end of file diff --git a/tests/Data/Torrent/MagnetSpec.hs b/tests/Data/Torrent/MagnetSpec.hs deleted file mode 100644 index 838df570..00000000 --- a/tests/Data/Torrent/MagnetSpec.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent.MagnetSpec (spec) where - -import Control.Applicative -import Data.Maybe -import Data.Monoid -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () -import Network.URI - -import Data.Torrent -import Data.Torrent.InfoHashSpec () - - -instance Arbitrary URIAuth where - arbitrary = URIAuth <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary URI where - arbitrary - = pure $ fromJust $ parseURI "http://ietf.org/1737.txt?a=1&b=h#123" - -instance Arbitrary Magnet where - arbitrary = Magnet <$> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> pure mempty - -magnetEncoding :: Magnet -> IO () -magnetEncoding m = parseMagnet (renderMagnet m) `shouldBe` Just m - -spec :: Spec -spec = do - describe "Magnet" $ do - it "properly encoded" $ property $ magnetEncoding - - it "parse base32" $ do - let magnet = "magnet:?xt=urn:btih:CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6" - let ih = "CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6" - parseMagnet magnet `shouldBe` Just (nullMagnet ih) - - it "parse base16" $ do - let magnet = "magnet:?xt=urn:btih:0123456789abcdef0123456789abcdef01234567" - let ih = "0123456789abcdef0123456789abcdef01234567" - parseMagnet magnet `shouldBe` Just (nullMagnet ih) diff --git a/tests/Data/Torrent/MetainfoSpec.hs b/tests/Data/Torrent/MetainfoSpec.hs deleted file mode 100644 index 1a8f97c7..00000000 --- a/tests/Data/Torrent/MetainfoSpec.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent.MetainfoSpec (spec) where - -import Control.Applicative -import Data.ByteString as BS -import Data.ByteString.Lazy as BL -import Data.BEncode -import Data.Maybe -import Data.Time -import Network.URI -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () - -import Data.Torrent -import Data.Torrent.LayoutSpec () -import Network.BitTorrent.Core.NodeInfoSpec () - -{----------------------------------------------------------------------- --- Common ------------------------------------------------------------------------} - -data T a = T - -prop_properBEncode :: Show a => BEncode a => Eq a - => T a -> a -> IO () -prop_properBEncode _ expected = actual `shouldBe` Right expected - where - actual = decode $ BL.toStrict $ encode expected - -instance Arbitrary URI where - arbitrary = pure $ fromJust - $ parseURI "http://exsample.com:80/123365_asd" - -{----------------------------------------------------------------------- --- Instances ------------------------------------------------------------------------} - -instance Arbitrary HashList where - arbitrary = HashList <$> arbitrary - -instance Arbitrary PieceInfo where - arbitrary = PieceInfo <$> arbitrary <*> arbitrary - -instance Arbitrary InfoDict where - arbitrary = infoDictionary <$> arbitrary <*> arbitrary <*> arbitrary - -pico :: Gen (Maybe NominalDiffTime) -pico = oneof - [ pure Nothing - , (Just . fromIntegral) <$> (arbitrary :: Gen Int) - ] - -instance Arbitrary Torrent where - arbitrary = Torrent <$> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary - <*> pico <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitrary <*> pure Nothing <*> arbitrary - -{----------------------------------------------------------------------- --- Spec ------------------------------------------------------------------------} - -spec :: Spec -spec = do - describe "FileInfo" $ do - it "properly bencoded" $ property $ - prop_properBEncode (T :: T (FileInfo BS.ByteString)) - - describe "LayoutInfo" $ do - it "properly bencoded" $ property $ - prop_properBEncode (T :: T LayoutInfo) - - describe "Torrent" $ do - it "property bencoded" $ property $ - prop_properBEncode (T :: T Torrent) diff --git a/tests/Data/Torrent/PieceSpec.hs b/tests/Data/Torrent/PieceSpec.hs deleted file mode 100644 index d3933396..00000000 --- a/tests/Data/Torrent/PieceSpec.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.Torrent.PieceSpec (spec) where -import Control.Applicative -import Test.Hspec -import Test.QuickCheck -import Data.Torrent - - -instance Arbitrary a => Arbitrary (Piece a) where - arbitrary = Piece <$> arbitrary <*> arbitrary - -spec :: Spec -spec = return () \ No newline at end of file diff --git a/tests/Data/TorrentSpec.hs b/tests/Data/TorrentSpec.hs new file mode 100644 index 00000000..7186429e --- /dev/null +++ b/tests/Data/TorrentSpec.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS -fno-warn-orphans #-} +module Data.TorrentSpec (spec) where +import Control.Applicative +import Data.BEncode +import Data.ByteString as BS +import Data.ByteString.Lazy as BL +import Data.Convertible +import Data.Maybe +import Data.Monoid +import Data.Time +import Network.URI +import System.FilePath +import System.Posix.Types +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Data.Torrent +import Network.BitTorrent.Core.NodeInfoSpec () + + +pico :: Gen (Maybe NominalDiffTime) +pico = oneof + [ pure Nothing + , (Just . fromIntegral) <$> (arbitrary :: Gen Int) + ] + +instance Arbitrary COff where + arbitrary = fromIntegral <$> (arbitrary :: Gen Int) + +instance Arbitrary URIAuth where + arbitrary = URIAuth <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary URI where + arbitrary + = pure $ fromJust $ parseURI "http://ietf.org/1737.txt?a=1&b=h#123" + +instance Arbitrary InfoHash where + arbitrary = do + bs <- BS.pack <$> vectorOf 20 arbitrary + pure $ either (const (error "arbitrary infohash")) id $ safeConvert bs + +instance Arbitrary a => Arbitrary (FileInfo a) where + arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary LayoutInfo where + arbitrary = oneof + [ SingleFile <$> arbitrary + , MultiFile <$> arbitrary <*> arbitrary + ] + +instance Arbitrary a => Arbitrary (Piece a) where + arbitrary = Piece <$> arbitrary <*> arbitrary + +instance Arbitrary HashList where + arbitrary = HashList <$> arbitrary + +instance Arbitrary PieceInfo where + arbitrary = PieceInfo <$> arbitrary <*> arbitrary + +instance Arbitrary InfoDict where + arbitrary = infoDictionary <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Torrent where + arbitrary = Torrent <$> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> pico <*> arbitrary <*> arbitrary + <*> arbitrary + <*> arbitrary <*> pure Nothing <*> arbitrary + +instance Arbitrary Magnet where + arbitrary = Magnet <$> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> pure mempty + +type TestPair = (FilePath, String) + +-- TODO add a few more torrents here +torrentList :: [TestPair] +torrentList = + [ ( "res" "dapper-dvd-amd64.iso.torrent" + , "0221caf96aa3cb94f0f58d458e78b0fc344ad8bf") + ] + +infohashSpec :: (FilePath, String) -> Spec +infohashSpec (filepath, expectedHash) = do + it ("should match " ++ filepath) $ do + torrent <- fromFile filepath + let actualHash = show $ idInfoHash $ tInfoDict torrent + actualHash `shouldBe` expectedHash + +magnetEncoding :: Magnet -> IO () +magnetEncoding m = parseMagnet (renderMagnet m) `shouldBe` Just m + +data T a = T + +prop_properBEncode :: Show a => BEncode a => Eq a + => T a -> a -> IO () +prop_properBEncode _ expected = actual `shouldBe` Right expected + where + actual = decode $ BL.toStrict $ encode expected + +spec :: Spec +spec = do + describe "info hash" $ do + mapM_ infohashSpec torrentList + + describe "accumPosition" $ do + it "" $ property $ \ p1 p2 p3 s1 s2 s3 -> + accumPositions [(p1, s1), (p2, s2), (p3, s3)] + `shouldBe` [(p1, (0, s1)), (p2, (s1, s2)), (p3, (s1 + s2, s3))] + + describe "FileInfo" $ do + it "properly bencoded" $ property $ + prop_properBEncode (T :: T (FileInfo BS.ByteString)) + + describe "LayoutInfo" $ do + it "properly bencoded" $ property $ + prop_properBEncode (T :: T LayoutInfo) + + describe "Torrent" $ do + it "property bencoded" $ property $ + prop_properBEncode (T :: T Torrent) + + describe "Magnet" $ do + it "properly encoded" $ property $ magnetEncoding + + it "parse base32" $ do + let magnet = "magnet:?xt=urn:btih:CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6" + let ih = "CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6" + parseMagnet magnet `shouldBe` Just (nullMagnet ih) + + it "parse base16" $ do + let magnet = "magnet:?xt=urn:btih:0123456789abcdef0123456789abcdef01234567" + let ih = "0123456789abcdef0123456789abcdef01234567" + parseMagnet magnet `shouldBe` Just (nullMagnet ih) diff --git a/tests/Network/BitTorrent/DHT/MessageSpec.hs b/tests/Network/BitTorrent/DHT/MessageSpec.hs index 4ec875dd..3d886fea 100644 --- a/tests/Network/BitTorrent/DHT/MessageSpec.hs +++ b/tests/Network/BitTorrent/DHT/MessageSpec.hs @@ -17,9 +17,9 @@ import Test.Hspec import Test.QuickCheck import System.Timeout +import Data.TorrentSpec () import Network.BitTorrent.CoreSpec () import Network.BitTorrent.DHT.TokenSpec () -import Data.Torrent.InfoHashSpec () instance MonadLogger IO where diff --git a/tests/Network/BitTorrent/DHT/SessionSpec.hs b/tests/Network/BitTorrent/DHT/SessionSpec.hs index bb32cf0e..1fe1d08a 100644 --- a/tests/Network/BitTorrent/DHT/SessionSpec.hs +++ b/tests/Network/BitTorrent/DHT/SessionSpec.hs @@ -15,7 +15,7 @@ import Network.BitTorrent.DHT import Network.BitTorrent.DHT.Message import Network.BitTorrent.DHT.Session -import Data.Torrent.InfoHashSpec () +import Data.TorrentSpec () import Network.BitTorrent.CoreSpec () import Network.BitTorrent.DHT.TokenSpec () diff --git a/tests/Network/BitTorrent/Exchange/MessageSpec.hs b/tests/Network/BitTorrent/Exchange/MessageSpec.hs index 63d814ff..1395ba11 100644 --- a/tests/Network/BitTorrent/Exchange/MessageSpec.hs +++ b/tests/Network/BitTorrent/Exchange/MessageSpec.hs @@ -10,8 +10,8 @@ import Data.String import Test.Hspec import Test.QuickCheck +import Data.TorrentSpec () import Data.Torrent.BitfieldSpec () -import Data.Torrent.InfoHashSpec () import Network.BitTorrent.CoreSpec () import Network.BitTorrent.Core () import Network.BitTorrent.Exchange.BlockSpec () diff --git a/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/tests/Network/BitTorrent/Tracker/MessageSpec.hs index c56afd2a..439883a1 100644 --- a/tests/Network/BitTorrent/Tracker/MessageSpec.hs +++ b/tests/Network/BitTorrent/Tracker/MessageSpec.hs @@ -16,7 +16,7 @@ import Data.Maybe import Test.Hspec import Test.QuickCheck -import Data.Torrent.InfoHashSpec () +import Data.TorrentSpec () import Data.Torrent.ProgressSpec () import Network.BitTorrent.Core.PeerIdSpec () import Network.BitTorrent.Core.PeerAddrSpec () -- cgit v1.2.3 From 75711985512c8578e913a1b464816968b4aef5dd Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 8 Apr 2014 02:36:18 +0400 Subject: Merge PeerAddr and NodeAddr modules --- bittorrent.cabal | 6 +- src/Data/Torrent.hs | 4 +- src/Network/BitTorrent/Address.hs | 1172 ++++++++++++++++++++ src/Network/BitTorrent/Client.hs | 2 +- src/Network/BitTorrent/Client/Types.hs | 2 +- src/Network/BitTorrent/Core.hs | 88 -- src/Network/BitTorrent/Core/Fingerprint.hs | 290 ----- src/Network/BitTorrent/Core/NodeInfo.hs | 219 ---- src/Network/BitTorrent/Core/PeerAddr.hs | 312 ------ src/Network/BitTorrent/Core/PeerId.hs | 364 ------ src/Network/BitTorrent/DHT.hs | 2 +- src/Network/BitTorrent/DHT/ContactInfo.hs | 4 +- src/Network/BitTorrent/DHT/Message.hs | 2 +- src/Network/BitTorrent/DHT/Query.hs | 2 +- src/Network/BitTorrent/DHT/Routing.hs | 2 +- src/Network/BitTorrent/DHT/Session.hs | 3 +- src/Network/BitTorrent/DHT/Token.hs | 2 +- src/Network/BitTorrent/Exchange/Assembler.hs | 2 +- src/Network/BitTorrent/Exchange/Connection.hs | 2 +- src/Network/BitTorrent/Exchange/Manager.hs | 2 +- src/Network/BitTorrent/Exchange/Message.hs | 2 +- src/Network/BitTorrent/Exchange/Session.hs | 2 +- .../BitTorrent/Exchange/Session/Metadata.hs | 2 +- src/Network/BitTorrent/Exchange/Session/Status.hs | 2 +- src/Network/BitTorrent/Tracker/Message.hs | 2 +- src/Network/BitTorrent/Tracker/RPC.hs | 2 +- src/Network/BitTorrent/Tracker/RPC/HTTP.hs | 2 +- src/Network/BitTorrent/Tracker/Session.hs | 2 +- tests/Config.hs | 2 +- tests/Data/TorrentSpec.hs | 2 +- tests/Network/BitTorrent/Core/FingerprintSpec.hs | 2 +- tests/Network/BitTorrent/Core/NodeInfoSpec.hs | 2 +- tests/Network/BitTorrent/Core/PeerAddrSpec.hs | 4 +- tests/Network/BitTorrent/Core/PeerIdSpec.hs | 2 +- tests/Network/BitTorrent/CoreSpec.hs | 2 +- tests/Network/BitTorrent/DHT/MessageSpec.hs | 2 +- tests/Network/BitTorrent/DHT/QuerySpec.hs | 2 +- tests/Network/BitTorrent/DHT/RoutingSpec.hs | 2 +- tests/Network/BitTorrent/DHT/SessionSpec.hs | 2 +- tests/Network/BitTorrent/DHT/TokenSpec.hs | 2 +- .../Network/BitTorrent/Exchange/ConnectionSpec.hs | 2 +- tests/Network/BitTorrent/Exchange/MessageSpec.hs | 2 +- .../BitTorrent/Exchange/Session/MetadataSpec.hs | 2 +- tests/Network/BitTorrent/Exchange/SessionSpec.hs | 2 +- tests/Network/BitTorrent/Tracker/MessageSpec.hs | 6 +- tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs | 2 +- 46 files changed, 1217 insertions(+), 1323 deletions(-) create mode 100644 src/Network/BitTorrent/Address.hs delete mode 100644 src/Network/BitTorrent/Core.hs delete mode 100644 src/Network/BitTorrent/Core/Fingerprint.hs delete mode 100644 src/Network/BitTorrent/Core/NodeInfo.hs delete mode 100644 src/Network/BitTorrent/Core/PeerAddr.hs delete mode 100644 src/Network/BitTorrent/Core/PeerId.hs (limited to 'tests/Network') diff --git a/bittorrent.cabal b/bittorrent.cabal index 6953816d..761ed1c4 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -49,14 +49,10 @@ library Data.Torrent.Progress Data.Torrent.Tree Network.BitTorrent + Network.BitTorrent.Address Network.BitTorrent.Client Network.BitTorrent.Client.Types Network.BitTorrent.Client.Handle - Network.BitTorrent.Core - Network.BitTorrent.Core.Fingerprint - Network.BitTorrent.Core.NodeInfo - Network.BitTorrent.Core.PeerId - Network.BitTorrent.Core.PeerAddr Network.BitTorrent.DHT Network.BitTorrent.DHT.ContactInfo Network.BitTorrent.DHT.Message diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs index 7c56edf7..cfc26453 100644 --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs @@ -187,7 +187,7 @@ import Text.PrettyPrint.Class import System.FilePath import System.Posix.Types -import Network.BitTorrent.Core.NodeInfo +import Network.BitTorrent.Address {----------------------------------------------------------------------- @@ -836,7 +836,7 @@ data Torrent = Torrent , tNodes :: !(Maybe [NodeAddr HostName]) -- ^ This key should be set to the /K closest/ nodes in the -- torrent generating client's routing table. Alternatively, the - -- key could be set to a known good 'Network.BitTorrent.Core.Node' + -- key could be set to a known good 'Network.BitTorrent.Address.Node' -- such as one operated by the person generating the torrent. -- -- Please do not automatically add \"router.bittorrent.com\" to diff --git a/src/Network/BitTorrent/Address.hs b/src/Network/BitTorrent/Address.hs new file mode 100644 index 00000000..8723433d --- /dev/null +++ b/src/Network/BitTorrent/Address.hs @@ -0,0 +1,1172 @@ +-- | +-- Module : Network.BitTorrent.Address +-- Copyright : (c) Sam Truzjan 2013 +-- (c) Daniel Gröber 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Peer and Node addresses. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -fno-warn-orphans #-} +module Network.BitTorrent.Address + ( -- * Address + Address (..) + , fromAddr + + -- ** IP + , IPv4 + , IPv6 + , IP (..) + + -- * PeerId + -- $peer-id + , PeerId + + -- ** Generation + , genPeerId + , timestamp + , entropy + + -- ** Encoding + , azureusStyle + , shadowStyle + , defaultClientId + , defaultVersionNumber + + -- * PeerAddr + -- $peer-addr + , PeerAddr(..) + , defaultPorts + , peerSockAddr + , peerSocket + + -- * Node + -- ** Id + , NodeId + , testIdBit + , genNodeId + , NodeDistance + , distance + + -- ** Info + , NodeAddr (..) + , NodeInfo (..) + , rank + + -- * Fingerprint + -- $fingerprint + , ClientImpl (..) + , Fingerprint (..) + , libFingerprint + , fingerprint + + -- * Utils + , libUserAgent + ) where + +import Control.Applicative +import Control.Monad +import Data.BEncode as BE +import Data.BEncode as BS +import Data.BEncode.BDict (BKey) +import Data.Bits +import Data.ByteString as BS +import Data.ByteString.Internal as BS +import Data.ByteString.Base16 as Base16 +import Data.ByteString.Char8 as BC +import Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Builder as BS +import Data.Char +import Data.Convertible +import Data.Default +import Data.Foldable +import Data.IP +import Data.List as L +import Data.List.Split as L +import Data.Maybe (fromMaybe, catMaybes) +import Data.Monoid +import Data.Hashable +import Data.Ord +import Data.Serialize as S +import Data.String +import Data.Time +import Data.Typeable +import Data.Version +import Data.Word +import qualified Text.ParserCombinators.ReadP as RP +import Text.Read (readMaybe) +import Network.HTTP.Types.QueryLike +import Network.Socket +import Text.PrettyPrint as PP hiding ((<>)) +import Text.PrettyPrint.Class +import System.Locale (defaultTimeLocale) +import System.Entropy + +-- import Paths_bittorrent (version) + +{----------------------------------------------------------------------- +-- Address +-----------------------------------------------------------------------} + +instance Pretty UTCTime where + pretty = PP.text . show + +class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a) + => Address a where + toSockAddr :: a -> SockAddr + fromSockAddr :: SockAddr -> Maybe a + +fromAddr :: (Address a, Address b) => a -> Maybe b +fromAddr = fromSockAddr . toSockAddr + +-- | Note that port is zeroed. +instance Address IPv4 where + toSockAddr = SockAddrInet 0 . toHostAddress + fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h) + fromSockAddr _ = Nothing + +-- | Note that port is zeroed. +instance Address IPv6 where + toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0 + fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h) + fromSockAddr _ = Nothing + +-- | Note that port is zeroed. +instance Address IP where + toSockAddr (IPv4 h) = toSockAddr h + toSockAddr (IPv6 h) = toSockAddr h + fromSockAddr sa = + IPv4 <$> fromSockAddr sa + <|> IPv6 <$> fromSockAddr sa + +setPort :: PortNumber -> SockAddr -> SockAddr +setPort port (SockAddrInet _ h ) = SockAddrInet port h +setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s +setPort _ (SockAddrUnix s ) = SockAddrUnix s +{-# INLINE setPort #-} + +getPort :: SockAddr -> Maybe PortNumber +getPort (SockAddrInet p _ ) = Just p +getPort (SockAddrInet6 p _ _ _) = Just p +getPort (SockAddrUnix _ ) = Nothing +{-# INLINE getPort #-} + +instance Address a => Address (NodeAddr a) where + toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost + fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> getPort sa + +instance Address a => Address (PeerAddr a) where + toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost + fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> getPort sa + +{----------------------------------------------------------------------- +-- Peer id +-----------------------------------------------------------------------} +-- $peer-id +-- +-- 'PeerID' represent self assigned peer identificator. Ideally each +-- host in the network should have unique peer id to avoid +-- collisions, therefore for peer ID generation we use good entropy +-- source. Peer ID is sent in /tracker request/, sent and received in +-- /peer handshakes/ and used in DHT queries. +-- + +-- TODO use unpacked Word160 form (length is known statically) + +-- | Peer identifier is exactly 20 bytes long bytestring. +newtype PeerId = PeerId { getPeerId :: ByteString } + deriving (Show, Eq, Ord, BEncode, Typeable) + +peerIdLen :: Int +peerIdLen = 20 + +-- | For testing purposes only. +instance Default PeerId where + def = azureusStyle defaultClientId defaultVersionNumber "" + +instance Hashable PeerId where + hashWithSalt = hashUsing getPeerId + {-# INLINE hashWithSalt #-} + +instance Serialize PeerId where + put = putByteString . getPeerId + get = PeerId <$> getBytes peerIdLen + +instance QueryValueLike PeerId where + toQueryValue (PeerId pid) = Just pid + {-# INLINE toQueryValue #-} + +instance IsString PeerId where + fromString str + | BS.length bs == peerIdLen = PeerId bs + | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str + where + bs = fromString str + +instance Pretty PeerId where + pretty = text . BC.unpack . getPeerId + +instance Convertible BS.ByteString PeerId where + safeConvert bs + | BS.length bs == peerIdLen = pure (PeerId bs) + | otherwise = convError "invalid length" bs + +------------------------------------------------------------------------ + +-- | Pad bytestring so it's becomes exactly request length. Conversion +-- is done like so: +-- +-- * length < size: Complete bytestring by given charaters. +-- +-- * length = size: Output bytestring as is. +-- +-- * length > size: Drop last (length - size) charaters from a +-- given bytestring. +-- +byteStringPadded :: ByteString -- ^ bytestring to be padded. + -> Int -- ^ size of result builder. + -> Char -- ^ character used for padding. + -> BS.Builder +byteStringPadded bs s c = + BS.byteString (BS.take s bs) <> + BS.byteString (BC.replicate padLen c) + where + padLen = s - min (BS.length bs) s + +-- | Azureus-style encoding have the following layout: +-- +-- * 1 byte : '-' +-- +-- * 2 bytes: client id +-- +-- * 4 bytes: version number +-- +-- * 1 byte : '-' +-- +-- * 12 bytes: random number +-- +azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'. + -> ByteString -- ^ Version number, padded with 'X'. + -> ByteString -- ^ Random number, padded with '0'. + -> PeerId -- ^ Azureus-style encoded peer ID. +azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ + BS.char8 '-' <> + byteStringPadded cid 2 'H' <> + byteStringPadded ver 4 'X' <> + BS.char8 '-' <> + byteStringPadded rnd 12 '0' + +-- | Shadow-style encoding have the following layout: +-- +-- * 1 byte : client id. +-- +-- * 0-4 bytes: version number. If less than 4 then padded with +-- '-' char. +-- +-- * 15 bytes : random number. If length is less than 15 then +-- padded with '0' char. +-- +shadowStyle :: Char -- ^ Client ID. + -> ByteString -- ^ Version number. + -> ByteString -- ^ Random number. + -> PeerId -- ^ Shadow style encoded peer ID. +shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ + BS.char8 cid <> + byteStringPadded ver 4 '-' <> + byteStringPadded rnd 15 '0' + + +-- | 'HS'- 2 bytes long client identifier. +defaultClientId :: ByteString +defaultClientId = "HS" + +-- | Gives exactly 4 bytes long version number for any version of the +-- package. Version is taken from .cabal file. +defaultVersionNumber :: ByteString +defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $ + versionBranch $ ciVersion libFingerprint + +------------------------------------------------------------------------ + +-- | Gives 15 characters long decimal timestamp such that: +-- +-- * 6 bytes : first 6 characters from picoseconds obtained with %q. +-- +-- * 1 byte : character \'.\' for readability. +-- +-- * 9..* bytes: number of whole seconds since the Unix epoch +-- (!)REVERSED. +-- +-- Can be used both with shadow and azureus style encoding. This +-- format is used to make the ID's readable for debugging purposes. +-- +timestamp :: IO ByteString +timestamp = (BC.pack . format) <$> getCurrentTime + where + format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++ + L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t)) + +-- | Gives 15 character long random bytestring. This is more robust +-- method for generation of random part of peer ID than 'timestamp'. +entropy :: IO ByteString +entropy = getEntropy 15 + +-- NOTE: entropy generates incorrrect peer id + +-- | Here we use 'azureusStyle' encoding with the following args: +-- +-- * 'HS' for the client id; ('defaultClientId') +-- +-- * Version of the package for the version number; +-- ('defaultVersionNumber') +-- +-- * UTC time day ++ day time for the random number. ('timestamp') +-- +genPeerId :: IO PeerId +genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp + +{----------------------------------------------------------------------- +-- Peer Addr +-----------------------------------------------------------------------} +-- $peer-addr +-- +-- 'PeerAddr' is used to represent peer address. Currently it's +-- just peer IP and peer port but this might change in future. +-- + +{----------------------------------------------------------------------- +-- Port number +-----------------------------------------------------------------------} + +instance BEncode PortNumber where + toBEncode = toBEncode . fromEnum + fromBEncode = fromBEncode >=> portNumber + where + portNumber :: Integer -> BS.Result PortNumber + portNumber n + | 0 <= n && n <= fromIntegral (maxBound :: Word16) + = pure $ fromIntegral n + | otherwise = decodingError $ "PortNumber: " ++ show n + +instance Serialize PortNumber where + get = fromIntegral <$> getWord16be + {-# INLINE get #-} + put = putWord16be . fromIntegral + {-# INLINE put #-} + +instance Hashable PortNumber where + hashWithSalt s = hashWithSalt s . fromEnum + {-# INLINE hashWithSalt #-} + +instance Pretty PortNumber where + pretty = PP.int . fromEnum + {-# INLINE pretty #-} + +{----------------------------------------------------------------------- +-- IP addr +-----------------------------------------------------------------------} + +class IPAddress i where + toHostAddr :: i -> Either HostAddress HostAddress6 + +instance IPAddress IPv4 where + toHostAddr = Left . toHostAddress + {-# INLINE toHostAddr #-} + +instance IPAddress IPv6 where + toHostAddr = Right . toHostAddress6 + {-# INLINE toHostAddr #-} + +instance IPAddress IP where + toHostAddr (IPv4 ip) = toHostAddr ip + toHostAddr (IPv6 ip) = toHostAddr ip + {-# INLINE toHostAddr #-} + +deriving instance Typeable IP +deriving instance Typeable IPv4 +deriving instance Typeable IPv6 + +ipToBEncode :: Show i => i -> BValue +ipToBEncode ip = BString $ BS8.pack $ show ip +{-# INLINE ipToBEncode #-} + +ipFromBEncode :: Read a => BValue -> BS.Result a +ipFromBEncode (BString (BS8.unpack -> ipStr)) + | Just ip <- readMaybe (ipStr) = pure ip + | otherwise = decodingError $ "IP: " ++ ipStr +ipFromBEncode _ = decodingError $ "IP: addr should be a bstring" + +instance BEncode IP where + toBEncode = ipToBEncode + {-# INLINE toBEncode #-} + fromBEncode = ipFromBEncode + {-# INLINE fromBEncode #-} + +instance BEncode IPv4 where + toBEncode = ipToBEncode + {-# INLINE toBEncode #-} + fromBEncode = ipFromBEncode + {-# INLINE fromBEncode #-} + +instance BEncode IPv6 where + toBEncode = ipToBEncode + {-# INLINE toBEncode #-} + fromBEncode = ipFromBEncode + {-# INLINE fromBEncode #-} + +-- | When 'get'ing an IP it must be 'isolate'd to the appropriate +-- number of bytes since we have no other way of telling which +-- address type we are trying to parse +instance Serialize IP where + put (IPv4 ip) = put ip + put (IPv6 ip) = put ip + + get = do + n <- remaining + case n of + 4 -> IPv4 <$> get + 16 -> IPv6 <$> get + _ -> fail "Wrong number of bytes remaining to parse IP" + +instance Serialize IPv4 where + put = putWord32host . toHostAddress + get = fromHostAddress <$> getWord32host + +instance Serialize IPv6 where + put ip = put $ toHostAddress6 ip + get = fromHostAddress6 <$> get + +instance Pretty IPv4 where + pretty = PP.text . show + {-# INLINE pretty #-} + +instance Pretty IPv6 where + pretty = PP.text . show + {-# INLINE pretty #-} + +instance Pretty IP where + pretty = PP.text . show + {-# INLINE pretty #-} + +instance Hashable IPv4 where + hashWithSalt = hashUsing toHostAddress + {-# INLINE hashWithSalt #-} + +instance Hashable IPv6 where + hashWithSalt s a = hashWithSalt s (toHostAddress6 a) + +instance Hashable IP where + hashWithSalt s (IPv4 h) = hashWithSalt s h + hashWithSalt s (IPv6 h) = hashWithSalt s h + +{----------------------------------------------------------------------- +-- Peer addr +-----------------------------------------------------------------------} +-- TODO check semantic of ord and eq instances + +-- | Peer address info normally extracted from peer list or peer +-- compact list encoding. +data PeerAddr a = PeerAddr + { peerId :: !(Maybe PeerId) + + -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved + -- 'HostName'. + , peerHost :: !a + + -- | The port the peer listenning for incoming P2P sessions. + , peerPort :: {-# UNPACK #-} !PortNumber + } deriving (Show, Eq, Ord, Typeable, Functor) + +peer_ip_key, peer_id_key, peer_port_key :: BKey +peer_ip_key = "ip" +peer_id_key = "peer id" +peer_port_key = "port" + +-- | The tracker's 'announce response' compatible encoding. +instance (Typeable a, BEncode a) => BEncode (PeerAddr a) where + toBEncode PeerAddr {..} = toDict $ + peer_ip_key .=! peerHost + .: peer_id_key .=? peerId + .: peer_port_key .=! peerPort + .: endDict + + fromBEncode = fromDict $ do + peerAddr <$>! peer_ip_key + <*>? peer_id_key + <*>! peer_port_key + where + peerAddr = flip PeerAddr + +-- | The tracker's 'compact peer list' compatible encoding. The +-- 'peerId' is always 'Nothing'. +-- +-- For more info see: +-- +-- TODO: test byte order +instance (Serialize a) => Serialize (PeerAddr a) where + put PeerAddr {..} = put peerHost >> put peerPort + get = PeerAddr Nothing <$> get <*> get + +-- | @127.0.0.1:6881@ +instance Default (PeerAddr IPv4) where + def = "127.0.0.1:6881" + +-- | @127.0.0.1:6881@ +instance Default (PeerAddr IP) where + def = IPv4 <$> def + +-- | Example: +-- +-- @peerPort \"127.0.0.1:6881\" == 6881@ +-- +instance IsString (PeerAddr IPv4) where + fromString str + | [hostAddrStr, portStr] <- splitWhen (== ':') str + , Just hostAddr <- readMaybe hostAddrStr + , Just portNum <- toEnum <$> readMaybe portStr + = PeerAddr Nothing hostAddr portNum + | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str + +instance Read (PeerAddr IPv4) where + readsPrec i = RP.readP_to_S $ do + ipv4 <- RP.readS_to_P (readsPrec i) + _ <- RP.char ':' + port <- toEnum <$> RP.readS_to_P (readsPrec i) + return $ PeerAddr Nothing ipv4 port + +readsIPv6_port :: String -> [((IPv6, PortNumber), String)] +readsIPv6_port = RP.readP_to_S $ do + ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' + _ <- RP.char ':' + port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof + return (ip,port) + +instance IsString (PeerAddr IPv6) where + fromString str + | [((ip,port),"")] <- readsIPv6_port str = + PeerAddr Nothing ip port + | otherwise = error $ "fromString: unable to parse (PeerAddr IPv6): " ++ str + +instance IsString (PeerAddr IP) where + fromString str + | '[' `L.elem` str = IPv6 <$> fromString str + | otherwise = IPv4 <$> fromString str + +-- | fingerprint + "at" + dotted.host.inet.addr:port +-- TODO: instances for IPv6, HostName +instance Pretty a => Pretty (PeerAddr a) where + pretty PeerAddr {..} + | Just pid <- peerId = pretty (fingerprint pid) <+> "at" <+> paddr + | otherwise = paddr + where + paddr = pretty peerHost <> ":" <> text (show peerPort) + +instance Hashable a => Hashable (PeerAddr a) where + hashWithSalt s PeerAddr {..} = + s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort + +-- | Ports typically reserved for bittorrent P2P listener. +defaultPorts :: [PortNumber] +defaultPorts = [6881..6889] + +_resolvePeerAddr :: (IPAddress i) => PeerAddr HostName -> PeerAddr i +_resolvePeerAddr = undefined + +_peerSockAddr :: PeerAddr IP -> (Family, SockAddr) +_peerSockAddr PeerAddr {..} = + case peerHost of + IPv4 ipv4 -> + (AF_INET, SockAddrInet peerPort (toHostAddress ipv4)) + IPv6 ipv6 -> + (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0) + +peerSockAddr :: PeerAddr IP -> SockAddr +peerSockAddr = snd . _peerSockAddr + +-- | Create a socket connected to the address specified in a peerAddr +peerSocket :: SocketType -> PeerAddr IP -> IO Socket +peerSocket socketType pa = do + let (family, addr) = _peerSockAddr pa + sock <- socket family socketType defaultProtocol + connect sock addr + return sock + +{----------------------------------------------------------------------- +-- Node info +-----------------------------------------------------------------------} +-- $node-info +-- +-- A \"node\" is a client\/server listening on a UDP port +-- implementing the distributed hash table protocol. The DHT is +-- composed of nodes and stores the location of peers. BitTorrent +-- clients include a DHT node, which is used to contact other nodes +-- in the DHT to get the location of peers to download from using +-- the BitTorrent protocol. + +-- TODO more compact representation ('ShortByteString's?) + +-- | Each node has a globally unique identifier known as the \"node +-- ID.\" +-- +-- Normally, /this/ node id should be saved between invocations +-- of the client software. +newtype NodeId = NodeId ByteString + deriving (Show, Eq, Ord, BEncode, Typeable) + +nodeIdSize :: Int +nodeIdSize = 20 + +-- | Meaningless node id, for testing purposes only. +instance Default NodeId where + def = NodeId (BS.replicate nodeIdSize 0) + +instance Serialize NodeId where + get = NodeId <$> getByteString nodeIdSize + {-# INLINE get #-} + put (NodeId bs) = putByteString bs + {-# INLINE put #-} + +-- | ASCII encoded. +instance IsString NodeId where + fromString str + | L.length str == nodeIdSize = NodeId (fromString str) + | otherwise = error "fromString: invalid NodeId length" + {-# INLINE fromString #-} + +-- | base16 encoded. +instance Pretty NodeId where + pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid + +-- | Test if the nth bit is set. +testIdBit :: NodeId -> Word -> Bool +testIdBit (NodeId bs) i + | fromIntegral i < nodeIdSize * 8 + , (q, r) <- quotRem (fromIntegral i) 8 + = testBit (BS.index bs q) r + | otherwise = False +{-# INLINE testIdBit #-} + +-- 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. +-- +genNodeId :: IO NodeId +genNodeId = NodeId <$> getEntropy nodeIdSize + +------------------------------------------------------------------------ + +-- | In Kademlia, the distance metric is XOR and the result is +-- interpreted as an unsigned integer. +newtype NodeDistance = NodeDistance BS.ByteString + deriving (Eq, Ord) + +instance Pretty NodeDistance where + pretty (NodeDistance bs) = foldMap bitseq $ BS.unpack bs + where + listBits w = L.map (testBit w) (L.reverse [0..bitSize w - 1]) + bitseq = foldMap (int . fromEnum) . listBits + +-- | distance(A,B) = |A xor B| Smaller values are closer. +distance :: NodeId -> NodeId -> NodeDistance +distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b)) + +------------------------------------------------------------------------ + +data NodeAddr a = NodeAddr + { nodeHost :: !a + , nodePort :: {-# UNPACK #-} !PortNumber + } deriving (Eq, Typeable, Functor) + +instance Show a => Show (NodeAddr a) where + showsPrec i NodeAddr {..} + = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort + +instance Read (NodeAddr IPv4) where + readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ] + +-- | @127.0.0.1:6882@ +instance Default (NodeAddr IPv4) where + def = "127.0.0.1:6882" + +-- | KRPC compatible encoding. +instance Serialize a => Serialize (NodeAddr a) where + get = NodeAddr <$> get <*> get + {-# INLINE get #-} + put NodeAddr {..} = put nodeHost >> put nodePort + {-# INLINE put #-} + +-- | Torrent file compatible encoding. +instance BEncode a => BEncode (NodeAddr a) where + toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort) + {-# INLINE toBEncode #-} + fromBEncode b = uncurry NodeAddr <$> fromBEncode b + {-# INLINE fromBEncode #-} + +instance Hashable a => Hashable (NodeAddr a) where + hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort) + {-# INLINE hashWithSalt #-} + +instance Pretty ip => Pretty (NodeAddr ip) where + pretty NodeAddr {..} = pretty nodeHost <> ":" <> pretty nodePort + +-- | Example: +-- +-- @nodePort \"127.0.0.1:6881\" == 6881@ +-- +instance IsString (NodeAddr IPv4) where + fromString = fromPeerAddr . fromString + +fromPeerAddr :: PeerAddr a -> NodeAddr a +fromPeerAddr PeerAddr {..} = NodeAddr + { nodeHost = peerHost + , nodePort = peerPort + } + +------------------------------------------------------------------------ + +data NodeInfo a = NodeInfo + { nodeId :: !NodeId + , nodeAddr :: !(NodeAddr a) + } deriving (Show, Eq, Functor) + +instance Eq a => Ord (NodeInfo a) where + compare = comparing nodeId + +-- | KRPC 'compact list' compatible encoding: contact information for +-- nodes is encoded as a 26-byte string. Also known as "Compact node +-- info" the 20-byte Node ID in network byte order has the compact +-- IP-address/port info concatenated to the end. +instance Serialize a => Serialize (NodeInfo a) where + get = NodeInfo <$> get <*> get + put NodeInfo {..} = put nodeId >> put nodeAddr + +instance Pretty ip => Pretty (NodeInfo ip) where + pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")" + +instance Pretty ip => Pretty [NodeInfo ip] where + pretty = PP.vcat . PP.punctuate "," . L.map pretty + +-- | Order by closeness: nearest nodes first. +rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip] +rank nid = L.sortBy (comparing (distance nid . nodeId)) + +{----------------------------------------------------------------------- +-- Fingerprint +-----------------------------------------------------------------------} +-- $fingerprint +-- +-- 'Fingerprint' is used to identify the client implementation and +-- version which also contained in 'Peer'. For exsample first 6 +-- bytes of peer id of this this library are @-HS0100-@ while for +-- mainline we have @M4-3-6--@. We could extract this info and +-- print in human-friendly form: this is useful for debugging and +-- logging. +-- +-- For more information see: +-- +-- +-- +-- NOTE: Do /not/ use this information to control client +-- capabilities (such as supported enchancements), this should be +-- done using 'Network.BitTorrent.Extension'! +-- + +-- TODO FIXME +version :: Version +version = Version [0, 0, 0, 3] [] + +-- | List of registered client versions + 'IlibHSbittorrent' (this +-- package) + 'IUnknown' (for not recognized software). All names are +-- prefixed by \"I\" because some of them starts from lowercase letter +-- but that is not a valid Haskell constructor name. +-- +data ClientImpl = + IUnknown + + | IMainline + + | IABC + | IOspreyPermaseed + | IBTQueue + | ITribler + | IShadow + | IBitTornado + +-- UPnP(!) Bit Torrent !??? +-- 'U' - UPnP NAT Bit Torrent + | IBitLord + | IOpera + | IMLdonkey + + | IAres + | IArctic + | IAvicora + | IBitPump + | IAzureus + | IBitBuddy + | IBitComet + | IBitflu + | IBTG + | IBitRocket + | IBTSlave + | IBittorrentX + | IEnhancedCTorrent + | ICTorrent + | IDelugeTorrent + | IPropagateDataClient + | IEBit + | IElectricSheep + | IFoxTorrent + | IGSTorrent + | IHalite + | IlibHSbittorrent + | IHydranode + | IKGet + | IKTorrent + | ILH_ABC + | ILphant + | ILibtorrent + | ILibTorrent + | ILimeWire + | IMonoTorrent + | IMooPolice + | IMiro + | IMoonlightTorrent + | INetTransport + | IPando + | IqBittorrent + | IQQDownload + | IQt4TorrentExample + | IRetriever + | IShareaza + | ISwiftbit + | ISwarmScope + | ISymTorrent + | Isharktorrent + | ITorrentDotNET + | ITransmission + | ITorrentstorm + | ITuoTu + | IuLeecher + | IuTorrent + | IVagaa + | IBitLet + | IFireTorrent + | IXunlei + | IXanTorrent + | IXtorrent + | IZipTorrent + deriving (Show, Eq, Ord, Enum, Bounded) + +parseImpl :: ByteString -> ClientImpl +parseImpl = f . BC.unpack + where + f "AG" = IAres + f "A~" = IAres + f "AR" = IArctic + f "AV" = IAvicora + f "AX" = IBitPump + f "AZ" = IAzureus + f "BB" = IBitBuddy + f "BC" = IBitComet + f "BF" = IBitflu + f "BG" = IBTG + f "BR" = IBitRocket + f "BS" = IBTSlave + f "BX" = IBittorrentX + f "CD" = IEnhancedCTorrent + f "CT" = ICTorrent + f "DE" = IDelugeTorrent + f "DP" = IPropagateDataClient + f "EB" = IEBit + f "ES" = IElectricSheep + f "FT" = IFoxTorrent + f "GS" = IGSTorrent + f "HL" = IHalite + f "HS" = IlibHSbittorrent + f "HN" = IHydranode + f "KG" = IKGet + f "KT" = IKTorrent + f "LH" = ILH_ABC + f "LP" = ILphant + f "LT" = ILibtorrent + f "lt" = ILibTorrent + f "LW" = ILimeWire + f "MO" = IMonoTorrent + f "MP" = IMooPolice + f "MR" = IMiro + f "ML" = IMLdonkey + f "MT" = IMoonlightTorrent + f "NX" = INetTransport + f "PD" = IPando + f "qB" = IqBittorrent + f "QD" = IQQDownload + f "QT" = IQt4TorrentExample + f "RT" = IRetriever + f "S~" = IShareaza + f "SB" = ISwiftbit + f "SS" = ISwarmScope + f "ST" = ISymTorrent + f "st" = Isharktorrent + f "SZ" = IShareaza + f "TN" = ITorrentDotNET + f "TR" = ITransmission + f "TS" = ITorrentstorm + f "TT" = ITuoTu + f "UL" = IuLeecher + f "UT" = IuTorrent + f "VG" = IVagaa + f "WT" = IBitLet + f "WY" = IFireTorrent + f "XL" = IXunlei + f "XT" = IXanTorrent + f "XX" = IXtorrent + f "ZT" = IZipTorrent + f _ = IUnknown + +-- | Used to represent a not recognized implementation +instance Default ClientImpl where + def = IUnknown + {-# INLINE def #-} + +-- | Example: @\"BitLet\" == 'IBitLet'@ +instance IsString ClientImpl where + fromString str + | Just impl <- L.lookup str alist = impl + | otherwise = error $ "fromString: not recognized " ++ str + where + alist = L.map mk [minBound..maxBound] + mk x = (L.tail $ show x, x) + +-- | Example: @pretty 'IBitLet' == \"IBitLet\"@ +instance Pretty ClientImpl where + pretty = text . L.tail . show + +-- | Just the '0' version. +instance Default Version where + def = Version [0] [] + {-# INLINE def #-} + +-- | For dot delimited version strings. +-- Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@ +-- +instance IsString Version where + fromString str + | Just nums <- chunkNums str = Version nums [] + | otherwise = error $ "fromString: invalid version string " ++ str + where + chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==) + +instance Pretty Version where + pretty = text . showVersion + +-- | The all sensible infomation that can be obtained from a peer +-- identifier or torrent /createdBy/ field. +data Fingerprint = Fingerprint + { ciImpl :: ClientImpl + , ciVersion :: Version + } deriving (Show, Eq, Ord) + +-- | Unrecognized client implementation. +instance Default Fingerprint where + def = Fingerprint def def + {-# INLINE def #-} + +-- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@ +instance IsString Fingerprint where + fromString str + | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver) + | otherwise = error $ "fromString: invalid client info string" ++ str + where + (impl, _ver) = L.span ((/=) '-') str + +instance Pretty Fingerprint where + pretty Fingerprint {..} = pretty ciImpl <+> "version" <+> pretty ciVersion + +-- | Fingerprint of this (the bittorrent library) package. Normally, +-- applications should introduce its own fingerprints, otherwise they +-- can use 'libFingerprint' value. +-- +libFingerprint :: Fingerprint +libFingerprint = Fingerprint IlibHSbittorrent version + +-- | HTTP user agent of this (the bittorrent library) package. Can be +-- used in HTTP tracker requests. +libUserAgent :: String +libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version) + +{----------------------------------------------------------------------- +-- For torrent file +-----------------------------------------------------------------------} +-- TODO collect information about createdBy torrent field +{- +renderImpl :: ClientImpl -> Text +renderImpl = T.pack . L.tail . show + +renderVersion :: Version -> Text +renderVersion = undefined + +renderClientInfo :: ClientInfo -> Text +renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion + +parseClientInfo :: Text -> ClientImpl +parseClientInfo t = undefined +-} +{- +-- code used for generation; remove it later on + +mkEnumTyDef :: NM -> String +mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd + +mkPars :: NM -> String +mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl) + +type NM = [(String, String)] +nameMap :: NM +nameMap = + [ ("AG", "Ares") + , ("A~", "Ares") + , ("AR", "Arctic") + , ("AV", "Avicora") + , ("AX", "BitPump") + , ("AZ", "Azureus") + , ("BB", "BitBuddy") + , ("BC", "BitComet") + , ("BF", "Bitflu") + , ("BG", "BTG") + , ("BR", "BitRocket") + , ("BS", "BTSlave") + , ("BX", "BittorrentX") + , ("CD", "EnhancedCTorrent") + , ("CT", "CTorrent") + , ("DE", "DelugeTorrent") + , ("DP", "PropagateDataClient") + , ("EB", "EBit") + , ("ES", "ElectricSheep") + , ("FT", "FoxTorrent") + , ("GS", "GSTorrent") + , ("HL", "Halite") + , ("HS", "libHSnetwork_bittorrent") + , ("HN", "Hydranode") + , ("KG", "KGet") + , ("KT", "KTorrent") + , ("LH", "LH_ABC") + , ("LP", "Lphant") + , ("LT", "Libtorrent") + , ("lt", "LibTorrent") + , ("LW", "LimeWire") + , ("MO", "MonoTorrent") + , ("MP", "MooPolice") + , ("MR", "Miro") + , ("MT", "MoonlightTorrent") + , ("NX", "NetTransport") + , ("PD", "Pando") + , ("qB", "qBittorrent") + , ("QD", "QQDownload") + , ("QT", "Qt4TorrentExample") + , ("RT", "Retriever") + , ("S~", "Shareaza") + , ("SB", "Swiftbit") + , ("SS", "SwarmScope") + , ("ST", "SymTorrent") + , ("st", "sharktorrent") + , ("SZ", "Shareaza") + , ("TN", "TorrentDotNET") + , ("TR", "Transmission") + , ("TS", "Torrentstorm") + , ("TT", "TuoTu") + , ("UL", "uLeecher") + , ("UT", "uTorrent") + , ("VG", "Vagaa") + , ("WT", "BitLet") + , ("WY", "FireTorrent") + , ("XL", "Xunlei") + , ("XT", "XanTorrent") + , ("XX", "Xtorrent") + , ("ZT", "ZipTorrent") + ] +-} + +-- TODO use regexps + +-- | Tries to extract meaningful information from peer ID bytes. If +-- peer id uses unknown coding style then client info returned is +-- 'def'. +-- +fingerprint :: PeerId -> Fingerprint +fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid) + where + getCI = do + leading <- BS.w2c <$> getWord8 + case leading of + '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion + 'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion + 'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion + 'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion + c -> do + c1 <- w2c <$> S.lookAhead getWord8 + if c1 == 'P' + then do + _ <- getWord8 + Fingerprint <$> pure IOpera <*> getOperaVersion + else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion + + getMainlineVersion = do + str <- BC.unpack <$> getByteString 7 + let mnums = L.filter (not . L.null) $ L.linesBy ('-' ==) str + return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) [] + + getAzureusImpl = parseImpl <$> getByteString 2 + getAzureusVersion = mkVer <$> getByteString 4 + where + mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] [] + + getBitCometImpl = do + bs <- getByteString 3 + S.lookAhead $ do + _ <- getByteString 2 + lr <- getByteString 4 + return $ + if lr == "LORD" then IBitLord else + if bs == "UTB" then IBitComet else + if bs == "xbc" then IBitComet else def + + getBitCometVersion = do + x <- getWord8 + y <- getWord8 + return $ Version [fromIntegral x, fromIntegral y] [] + + getOperaVersion = do + str <- BC.unpack <$> getByteString 4 + return $ Version [fromMaybe 0 $ readMaybe str] [] + + getShadowImpl 'A' = IABC + getShadowImpl 'O' = IOspreyPermaseed + getShadowImpl 'Q' = IBTQueue + getShadowImpl 'R' = ITribler + getShadowImpl 'S' = IShadow + getShadowImpl 'T' = IBitTornado + getShadowImpl _ = IUnknown + + decodeShadowVerNr :: Char -> Maybe Int + decodeShadowVerNr c + | '0' < c && c <= '9' = Just (fromEnum c - fromEnum '0') + | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10) + | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36) + | otherwise = Nothing + + getShadowVersion = do + str <- BC.unpack <$> getByteString 5 + return $ Version (catMaybes $ L.map decodeShadowVerNr str) [] diff --git a/src/Network/BitTorrent/Client.hs b/src/Network/BitTorrent/Client.hs index 700289d2..d21b4d1e 100644 --- a/src/Network/BitTorrent/Client.hs +++ b/src/Network/BitTorrent/Client.hs @@ -61,9 +61,9 @@ import Data.Text import Network import Data.Torrent +import Network.BitTorrent.Address import Network.BitTorrent.Client.Types import Network.BitTorrent.Client.Handle -import Network.BitTorrent.Core import Network.BitTorrent.DHT as DHT hiding (Options) import Network.BitTorrent.Tracker as Tracker hiding (Options) import Network.BitTorrent.Exchange as Exchange hiding (Options) diff --git a/src/Network/BitTorrent/Client/Types.hs b/src/Network/BitTorrent/Client/Types.hs index 3c1e9c9c..a5bf0cce 100644 --- a/src/Network/BitTorrent/Client/Types.hs +++ b/src/Network/BitTorrent/Client/Types.hs @@ -35,8 +35,8 @@ import Network import System.Log.FastLogger import Data.Torrent +import Network.BitTorrent.Address import Network.BitTorrent.Internal.Types as Types -import Network.BitTorrent.Core import Network.BitTorrent.DHT as DHT import Network.BitTorrent.Exchange as Exchange import Network.BitTorrent.Tracker as Tracker hiding (Event) diff --git a/src/Network/BitTorrent/Core.hs b/src/Network/BitTorrent/Core.hs deleted file mode 100644 index b9b3c065..00000000 --- a/src/Network/BitTorrent/Core.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Re-export every @Network.BitTorrent.Core.*@ module. --- -module Network.BitTorrent.Core - ( module Core - - -- * Address class - , Address (..) - , fromAddr - - -- * Re-exports from Data.IP - , IPv4 - , IPv6 - , IP (..) - ) where - -import Control.Applicative -import Data.IP -import Data.Hashable -import Data.Serialize -import Data.Time -import Data.Typeable -import Network.Socket (SockAddr (..), PortNumber) -import Text.PrettyPrint as PP hiding ((<>)) -import Text.PrettyPrint.Class - -import Network.BitTorrent.Core.Fingerprint as Core -import Network.BitTorrent.Core.NodeInfo as Core -import Network.BitTorrent.Core.PeerId as Core -import Network.BitTorrent.Core.PeerAddr as Core - - -instance Pretty UTCTime where - pretty = PP.text . show - -class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a) - => Address a where - toSockAddr :: a -> SockAddr - fromSockAddr :: SockAddr -> Maybe a - -fromAddr :: (Address a, Address b) => a -> Maybe b -fromAddr = fromSockAddr . toSockAddr - --- | Note that port is zeroed. -instance Address IPv4 where - toSockAddr = SockAddrInet 0 . toHostAddress - fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h) - fromSockAddr _ = Nothing - --- | Note that port is zeroed. -instance Address IPv6 where - toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0 - fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h) - fromSockAddr _ = Nothing - --- | Note that port is zeroed. -instance Address IP where - toSockAddr (IPv4 h) = toSockAddr h - toSockAddr (IPv6 h) = toSockAddr h - fromSockAddr sa = - IPv4 <$> fromSockAddr sa - <|> IPv6 <$> fromSockAddr sa - -setPort :: PortNumber -> SockAddr -> SockAddr -setPort port (SockAddrInet _ h ) = SockAddrInet port h -setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s -setPort _ (SockAddrUnix s ) = SockAddrUnix s -{-# INLINE setPort #-} - -getPort :: SockAddr -> Maybe PortNumber -getPort (SockAddrInet p _ ) = Just p -getPort (SockAddrInet6 p _ _ _) = Just p -getPort (SockAddrUnix _ ) = Nothing -{-# INLINE getPort #-} - -instance Address a => Address (NodeAddr a) where - toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost - fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> getPort sa - -instance Address a => Address (PeerAddr a) where - toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost - fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> getPort sa diff --git a/src/Network/BitTorrent/Core/Fingerprint.hs b/src/Network/BitTorrent/Core/Fingerprint.hs deleted file mode 100644 index d743acd0..00000000 --- a/src/Network/BitTorrent/Core/Fingerprint.hs +++ /dev/null @@ -1,290 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- 'Fingerprint' is used to identify the client implementation and --- version which also contained in 'Peer'. For exsample first 6 --- bytes of peer id of this this library are @-HS0100-@ while for --- mainline we have @M4-3-6--@. We could extract this info and --- print in human-friendly form: this is useful for debugging and --- logging. --- --- For more information see: --- --- --- --- NOTE: Do /not/ use this information to control client --- capabilities (such as supported enchancements), this should be --- done using 'Network.BitTorrent.Extension'! --- -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Core.Fingerprint - ( ClientImpl (..) - , Fingerprint (..) - , libFingerprint - , libUserAgent - ) where - -import Data.Default -import Data.List as L -import Data.List.Split as L -import Data.Monoid -import Data.String -import Data.Version -import Text.PrettyPrint hiding ((<>)) -import Text.PrettyPrint.Class -import Text.Read (readMaybe) --- import Paths_bittorrent (version) - --- TODO FIXME -version :: Version -version = Version [0, 0, 0, 3] [] - --- | List of registered client versions + 'IlibHSbittorrent' (this --- package) + 'IUnknown' (for not recognized software). All names are --- prefixed by \"I\" because some of them starts from lowercase letter --- but that is not a valid Haskell constructor name. --- -data ClientImpl = - IUnknown - - | IMainline - - | IABC - | IOspreyPermaseed - | IBTQueue - | ITribler - | IShadow - | IBitTornado - --- UPnP(!) Bit Torrent !??? --- 'U' - UPnP NAT Bit Torrent - | IBitLord - | IOpera - | IMLdonkey - - | IAres - | IArctic - | IAvicora - | IBitPump - | IAzureus - | IBitBuddy - | IBitComet - | IBitflu - | IBTG - | IBitRocket - | IBTSlave - | IBittorrentX - | IEnhancedCTorrent - | ICTorrent - | IDelugeTorrent - | IPropagateDataClient - | IEBit - | IElectricSheep - | IFoxTorrent - | IGSTorrent - | IHalite - | IlibHSbittorrent - | IHydranode - | IKGet - | IKTorrent - | ILH_ABC - | ILphant - | ILibtorrent - | ILibTorrent - | ILimeWire - | IMonoTorrent - | IMooPolice - | IMiro - | IMoonlightTorrent - | INetTransport - | IPando - | IqBittorrent - | IQQDownload - | IQt4TorrentExample - | IRetriever - | IShareaza - | ISwiftbit - | ISwarmScope - | ISymTorrent - | Isharktorrent - | ITorrentDotNET - | ITransmission - | ITorrentstorm - | ITuoTu - | IuLeecher - | IuTorrent - | IVagaa - | IBitLet - | IFireTorrent - | IXunlei - | IXanTorrent - | IXtorrent - | IZipTorrent - deriving (Show, Eq, Ord, Enum, Bounded) - --- | Used to represent a not recognized implementation -instance Default ClientImpl where - def = IUnknown - {-# INLINE def #-} - --- | Example: @\"BitLet\" == 'IBitLet'@ -instance IsString ClientImpl where - fromString str - | Just impl <- L.lookup str alist = impl - | otherwise = error $ "fromString: not recognized " ++ str - where - alist = L.map mk [minBound..maxBound] - mk x = (L.tail $ show x, x) - --- | Example: @pretty 'IBitLet' == \"IBitLet\"@ -instance Pretty ClientImpl where - pretty = text . L.tail . show - --- | Just the '0' version. -instance Default Version where - def = Version [0] [] - {-# INLINE def #-} - --- | For dot delimited version strings. --- Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@ --- -instance IsString Version where - fromString str - | Just nums <- chunkNums str = Version nums [] - | otherwise = error $ "fromString: invalid version string " ++ str - where - chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==) - -instance Pretty Version where - pretty = text . showVersion - --- | The all sensible infomation that can be obtained from a peer --- identifier or torrent /createdBy/ field. -data Fingerprint = Fingerprint - { ciImpl :: ClientImpl - , ciVersion :: Version - } deriving (Show, Eq, Ord) - --- | Unrecognized client implementation. -instance Default Fingerprint where - def = Fingerprint def def - {-# INLINE def #-} - --- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@ -instance IsString Fingerprint where - fromString str - | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver) - | otherwise = error $ "fromString: invalid client info string" ++ str - where - (impl, _ver) = L.span ((/=) '-') str - -instance Pretty Fingerprint where - pretty Fingerprint {..} = pretty ciImpl <+> "version" <+> pretty ciVersion - --- | Fingerprint of this (the bittorrent library) package. Normally, --- applications should introduce its own fingerprints, otherwise they --- can use 'libFingerprint' value. --- -libFingerprint :: Fingerprint -libFingerprint = Fingerprint IlibHSbittorrent version - --- | HTTP user agent of this (the bittorrent library) package. Can be --- used in HTTP tracker requests. -libUserAgent :: String -libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version) - -{----------------------------------------------------------------------- --- For torrent file ------------------------------------------------------------------------} --- TODO collect information about createdBy torrent field -{- -renderImpl :: ClientImpl -> Text -renderImpl = T.pack . L.tail . show - -renderVersion :: Version -> Text -renderVersion = undefined - -renderClientInfo :: ClientInfo -> Text -renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion - -parseClientInfo :: Text -> ClientImpl -parseClientInfo t = undefined --} -{- --- code used for generation; remove it later on - -mkEnumTyDef :: NM -> String -mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd - -mkPars :: NM -> String -mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl) - -type NM = [(String, String)] -nameMap :: NM -nameMap = - [ ("AG", "Ares") - , ("A~", "Ares") - , ("AR", "Arctic") - , ("AV", "Avicora") - , ("AX", "BitPump") - , ("AZ", "Azureus") - , ("BB", "BitBuddy") - , ("BC", "BitComet") - , ("BF", "Bitflu") - , ("BG", "BTG") - , ("BR", "BitRocket") - , ("BS", "BTSlave") - , ("BX", "BittorrentX") - , ("CD", "EnhancedCTorrent") - , ("CT", "CTorrent") - , ("DE", "DelugeTorrent") - , ("DP", "PropagateDataClient") - , ("EB", "EBit") - , ("ES", "ElectricSheep") - , ("FT", "FoxTorrent") - , ("GS", "GSTorrent") - , ("HL", "Halite") - , ("HS", "libHSnetwork_bittorrent") - , ("HN", "Hydranode") - , ("KG", "KGet") - , ("KT", "KTorrent") - , ("LH", "LH_ABC") - , ("LP", "Lphant") - , ("LT", "Libtorrent") - , ("lt", "LibTorrent") - , ("LW", "LimeWire") - , ("MO", "MonoTorrent") - , ("MP", "MooPolice") - , ("MR", "Miro") - , ("MT", "MoonlightTorrent") - , ("NX", "NetTransport") - , ("PD", "Pando") - , ("qB", "qBittorrent") - , ("QD", "QQDownload") - , ("QT", "Qt4TorrentExample") - , ("RT", "Retriever") - , ("S~", "Shareaza") - , ("SB", "Swiftbit") - , ("SS", "SwarmScope") - , ("ST", "SymTorrent") - , ("st", "sharktorrent") - , ("SZ", "Shareaza") - , ("TN", "TorrentDotNET") - , ("TR", "Transmission") - , ("TS", "Torrentstorm") - , ("TT", "TuoTu") - , ("UL", "uLeecher") - , ("UT", "uTorrent") - , ("VG", "Vagaa") - , ("WT", "BitLet") - , ("WY", "FireTorrent") - , ("XL", "Xunlei") - , ("XT", "XanTorrent") - , ("XX", "Xtorrent") - , ("ZT", "ZipTorrent") - ] --} diff --git a/src/Network/BitTorrent/Core/NodeInfo.hs b/src/Network/BitTorrent/Core/NodeInfo.hs deleted file mode 100644 index fe17c097..00000000 --- a/src/Network/BitTorrent/Core/NodeInfo.hs +++ /dev/null @@ -1,219 +0,0 @@ --- | --- Module : Network.BitTorrent.Core.Node --- Copyright : (c) Sam Truzjan 2013 --- (c) Daniel Gröber 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- A \"node\" is a client\/server listening on a UDP port --- implementing the distributed hash table protocol. The DHT is --- composed of nodes and stores the location of peers. BitTorrent --- clients include a DHT node, which is used to contact other nodes --- in the DHT to get the location of peers to download from using --- the BitTorrent protocol. --- -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -module Network.BitTorrent.Core.NodeInfo - ( -- * Node ID - NodeId - , testIdBit - , genNodeId - - -- ** Node distance - , NodeDistance - , distance - - -- * Node address - , NodeAddr (..) - - -- * Node info - , NodeInfo (..) - , rank - ) where - -import Control.Applicative -import Data.Bits -import Data.ByteString as BS -import Data.ByteString.Char8 as BC -import Data.ByteString.Base16 as Base16 -import Data.BEncode as BE -import Data.Default -import Data.Hashable -import Data.Foldable -import Data.IP -import Data.List as L -import Data.Monoid -import Data.Ord -import Data.Serialize as S -import Data.String -import Data.Typeable -import Data.Word -import Network -import System.Entropy -import Text.PrettyPrint as PP hiding ((<>)) -import Text.PrettyPrint.Class - -import Network.BitTorrent.Core.PeerAddr (PeerAddr (..)) - -{----------------------------------------------------------------------- --- Node id ------------------------------------------------------------------------} --- TODO more compact representation ('ShortByteString's?) - --- | Each node has a globally unique identifier known as the \"node --- ID.\" --- --- Normally, /this/ node id should be saved between invocations --- of the client software. -newtype NodeId = NodeId ByteString - deriving (Show, Eq, Ord, BEncode, Typeable) - -nodeIdSize :: Int -nodeIdSize = 20 - --- | Meaningless node id, for testing purposes only. -instance Default NodeId where - def = NodeId (BS.replicate nodeIdSize 0) - -instance Serialize NodeId where - get = NodeId <$> getByteString nodeIdSize - {-# INLINE get #-} - put (NodeId bs) = putByteString bs - {-# INLINE put #-} - --- | ASCII encoded. -instance IsString NodeId where - fromString str - | L.length str == nodeIdSize = NodeId (fromString str) - | otherwise = error "fromString: invalid NodeId length" - {-# INLINE fromString #-} - --- | base16 encoded. -instance Pretty NodeId where - pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid - --- | Test if the nth bit is set. -testIdBit :: NodeId -> Word -> Bool -testIdBit (NodeId bs) i - | fromIntegral i < nodeIdSize * 8 - , (q, r) <- quotRem (fromIntegral i) 8 - = testBit (BS.index bs q) r - | otherwise = False -{-# INLINE testIdBit #-} - --- 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. --- -genNodeId :: IO NodeId -genNodeId = NodeId <$> getEntropy nodeIdSize - -{----------------------------------------------------------------------- --- Node distance ------------------------------------------------------------------------} - --- | In Kademlia, the distance metric is XOR and the result is --- interpreted as an unsigned integer. -newtype NodeDistance = NodeDistance BS.ByteString - deriving (Eq, Ord) - -instance Pretty NodeDistance where - pretty (NodeDistance bs) = foldMap bitseq $ BS.unpack bs - where - listBits w = L.map (testBit w) (L.reverse [0..bitSize w - 1]) - bitseq = foldMap (int . fromEnum) . listBits - --- | distance(A,B) = |A xor B| Smaller values are closer. -distance :: NodeId -> NodeId -> NodeDistance -distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b)) - -{----------------------------------------------------------------------- --- Node address ------------------------------------------------------------------------} - -data NodeAddr a = NodeAddr - { nodeHost :: !a - , nodePort :: {-# UNPACK #-} !PortNumber - } deriving (Eq, Typeable, Functor) - -instance Show a => Show (NodeAddr a) where - showsPrec i NodeAddr {..} - = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort - -instance Read (NodeAddr IPv4) where - readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ] - --- | @127.0.0.1:6882@ -instance Default (NodeAddr IPv4) where - def = "127.0.0.1:6882" - --- | KRPC compatible encoding. -instance Serialize a => Serialize (NodeAddr a) where - get = NodeAddr <$> get <*> get - {-# INLINE get #-} - put NodeAddr {..} = put nodeHost >> put nodePort - {-# INLINE put #-} - --- | Torrent file compatible encoding. -instance BEncode a => BEncode (NodeAddr a) where - toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort) - {-# INLINE toBEncode #-} - fromBEncode b = uncurry NodeAddr <$> fromBEncode b - {-# INLINE fromBEncode #-} - -instance Hashable a => Hashable (NodeAddr a) where - hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort) - {-# INLINE hashWithSalt #-} - -instance Pretty ip => Pretty (NodeAddr ip) where - pretty NodeAddr {..} = pretty nodeHost <> ":" <> pretty nodePort - --- | Example: --- --- @nodePort \"127.0.0.1:6881\" == 6881@ --- -instance IsString (NodeAddr IPv4) where - fromString = fromPeerAddr . fromString - -fromPeerAddr :: PeerAddr a -> NodeAddr a -fromPeerAddr PeerAddr {..} = NodeAddr - { nodeHost = peerHost - , nodePort = peerPort - } - -{----------------------------------------------------------------------- --- Node info ------------------------------------------------------------------------} - -data NodeInfo a = NodeInfo - { nodeId :: !NodeId - , nodeAddr :: !(NodeAddr a) - } deriving (Show, Eq, Functor) - -instance Eq a => Ord (NodeInfo a) where - compare = comparing nodeId - --- | KRPC 'compact list' compatible encoding: contact information for --- nodes is encoded as a 26-byte string. Also known as "Compact node --- info" the 20-byte Node ID in network byte order has the compact --- IP-address/port info concatenated to the end. -instance Serialize a => Serialize (NodeInfo a) where - get = NodeInfo <$> get <*> get - put NodeInfo {..} = put nodeId >> put nodeAddr - -instance Pretty ip => Pretty (NodeInfo ip) where - pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")" - -instance Pretty ip => Pretty [NodeInfo ip] where - pretty = PP.vcat . PP.punctuate "," . L.map pretty - --- | Order by closeness: nearest nodes first. -rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip] -rank nid = L.sortBy (comparing (distance nid . nodeId)) diff --git a/src/Network/BitTorrent/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs deleted file mode 100644 index e9ad7c96..00000000 --- a/src/Network/BitTorrent/Core/PeerAddr.hs +++ /dev/null @@ -1,312 +0,0 @@ --- | --- Module : Network.BitTorrent.Core.PeerAddr --- Copyright : (c) Sam Truzjan 2013 --- (c) Daniel Gröber 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : provisional --- Portability : portable --- --- 'PeerAddr' is used to represent peer address. Currently it's --- just peer IP and peer port but this might change in future. --- -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS -fno-warn-orphans #-} -- for PortNumber instances -module Network.BitTorrent.Core.PeerAddr - ( -- * Peer address - PeerAddr(..) - , defaultPorts - , peerSockAddr - , peerSocket - - -- * Peer storage - ) where - -import Control.Applicative -import Control.Monad -import Data.BEncode as BS -import Data.BEncode.BDict (BKey) -import Data.ByteString.Char8 as BS8 -import Data.Char -import Data.Default -import Data.Hashable -import Data.IP -import Data.List as L -import Data.List.Split -import Data.Monoid -import Data.Serialize as S -import Data.String -import Data.Typeable -import Data.Word -import Network.Socket -import Text.PrettyPrint as PP hiding ((<>)) -import Text.PrettyPrint.Class -import Text.Read (readMaybe) -import qualified Text.ParserCombinators.ReadP as RP - ---import Data.Torrent -import Network.BitTorrent.Core.PeerId - - -{----------------------------------------------------------------------- --- Port number ------------------------------------------------------------------------} - -instance BEncode PortNumber where - toBEncode = toBEncode . fromEnum - fromBEncode = fromBEncode >=> portNumber - where - portNumber :: Integer -> BS.Result PortNumber - portNumber n - | 0 <= n && n <= fromIntegral (maxBound :: Word16) - = pure $ fromIntegral n - | otherwise = decodingError $ "PortNumber: " ++ show n - -instance Serialize PortNumber where - get = fromIntegral <$> getWord16be - {-# INLINE get #-} - put = putWord16be . fromIntegral - {-# INLINE put #-} - -instance Hashable PortNumber where - hashWithSalt s = hashWithSalt s . fromEnum - {-# INLINE hashWithSalt #-} - -instance Pretty PortNumber where - pretty = PP.int . fromEnum - {-# INLINE pretty #-} - -{----------------------------------------------------------------------- --- IP addr ------------------------------------------------------------------------} - -class IPAddress i where - toHostAddr :: i -> Either HostAddress HostAddress6 - -instance IPAddress IPv4 where - toHostAddr = Left . toHostAddress - {-# INLINE toHostAddr #-} - -instance IPAddress IPv6 where - toHostAddr = Right . toHostAddress6 - {-# INLINE toHostAddr #-} - -instance IPAddress IP where - toHostAddr (IPv4 ip) = toHostAddr ip - toHostAddr (IPv6 ip) = toHostAddr ip - {-# INLINE toHostAddr #-} - -deriving instance Typeable IP -deriving instance Typeable IPv4 -deriving instance Typeable IPv6 - -ipToBEncode :: Show i => i -> BValue -ipToBEncode ip = BString $ BS8.pack $ show ip -{-# INLINE ipToBEncode #-} - -ipFromBEncode :: Read a => BValue -> BS.Result a -ipFromBEncode (BString (BS8.unpack -> ipStr)) - | Just ip <- readMaybe (ipStr) = pure ip - | otherwise = decodingError $ "IP: " ++ ipStr -ipFromBEncode _ = decodingError $ "IP: addr should be a bstring" - -instance BEncode IP where - toBEncode = ipToBEncode - {-# INLINE toBEncode #-} - fromBEncode = ipFromBEncode - {-# INLINE fromBEncode #-} - -instance BEncode IPv4 where - toBEncode = ipToBEncode - {-# INLINE toBEncode #-} - fromBEncode = ipFromBEncode - {-# INLINE fromBEncode #-} - -instance BEncode IPv6 where - toBEncode = ipToBEncode - {-# INLINE toBEncode #-} - fromBEncode = ipFromBEncode - {-# INLINE fromBEncode #-} - --- | When 'get'ing an IP it must be 'isolate'd to the appropriate --- number of bytes since we have no other way of telling which --- address type we are trying to parse -instance Serialize IP where - put (IPv4 ip) = put ip - put (IPv6 ip) = put ip - - get = do - n <- remaining - case n of - 4 -> IPv4 <$> get - 16 -> IPv6 <$> get - _ -> fail "Wrong number of bytes remaining to parse IP" - -instance Serialize IPv4 where - put = putWord32host . toHostAddress - get = fromHostAddress <$> getWord32host - -instance Serialize IPv6 where - put ip = put $ toHostAddress6 ip - get = fromHostAddress6 <$> get - -instance Pretty IPv4 where - pretty = PP.text . show - {-# INLINE pretty #-} - -instance Pretty IPv6 where - pretty = PP.text . show - {-# INLINE pretty #-} - -instance Pretty IP where - pretty = PP.text . show - {-# INLINE pretty #-} - -instance Hashable IPv4 where - hashWithSalt = hashUsing toHostAddress - {-# INLINE hashWithSalt #-} - -instance Hashable IPv6 where - hashWithSalt s a = hashWithSalt s (toHostAddress6 a) - -instance Hashable IP where - hashWithSalt s (IPv4 h) = hashWithSalt s h - hashWithSalt s (IPv6 h) = hashWithSalt s h - -{----------------------------------------------------------------------- --- Peer addr ------------------------------------------------------------------------} --- TODO check semantic of ord and eq instances - --- | Peer address info normally extracted from peer list or peer --- compact list encoding. -data PeerAddr a = PeerAddr - { peerId :: !(Maybe PeerId) - - -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved - -- 'HostName'. - , peerHost :: !a - - -- | The port the peer listenning for incoming P2P sessions. - , peerPort :: {-# UNPACK #-} !PortNumber - } deriving (Show, Eq, Ord, Typeable, Functor) - -peer_ip_key, peer_id_key, peer_port_key :: BKey -peer_ip_key = "ip" -peer_id_key = "peer id" -peer_port_key = "port" - --- | The tracker's 'announce response' compatible encoding. -instance (Typeable a, BEncode a) => BEncode (PeerAddr a) where - toBEncode PeerAddr {..} = toDict $ - peer_ip_key .=! peerHost - .: peer_id_key .=? peerId - .: peer_port_key .=! peerPort - .: endDict - - fromBEncode = fromDict $ do - peerAddr <$>! peer_ip_key - <*>? peer_id_key - <*>! peer_port_key - where - peerAddr = flip PeerAddr - --- | The tracker's 'compact peer list' compatible encoding. The --- 'peerId' is always 'Nothing'. --- --- For more info see: --- --- TODO: test byte order -instance (Serialize a) => Serialize (PeerAddr a) where - put PeerAddr {..} = put peerHost >> put peerPort - get = PeerAddr Nothing <$> get <*> get - --- | @127.0.0.1:6881@ -instance Default (PeerAddr IPv4) where - def = "127.0.0.1:6881" - --- | @127.0.0.1:6881@ -instance Default (PeerAddr IP) where - def = IPv4 <$> def - --- | Example: --- --- @peerPort \"127.0.0.1:6881\" == 6881@ --- -instance IsString (PeerAddr IPv4) where - fromString str - | [hostAddrStr, portStr] <- splitWhen (== ':') str - , Just hostAddr <- readMaybe hostAddrStr - , Just portNum <- toEnum <$> readMaybe portStr - = PeerAddr Nothing hostAddr portNum - | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str - -instance Read (PeerAddr IPv4) where - readsPrec i = RP.readP_to_S $ do - ipv4 <- RP.readS_to_P (readsPrec i) - _ <- RP.char ':' - port <- toEnum <$> RP.readS_to_P (readsPrec i) - return $ PeerAddr Nothing ipv4 port - -readsIPv6_port :: String -> [((IPv6, PortNumber), String)] -readsIPv6_port = RP.readP_to_S $ do - ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' - _ <- RP.char ':' - port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof - return (ip,port) - -instance IsString (PeerAddr IPv6) where - fromString str - | [((ip,port),"")] <- readsIPv6_port str = - PeerAddr Nothing ip port - | otherwise = error $ "fromString: unable to parse (PeerAddr IPv6): " ++ str - -instance IsString (PeerAddr IP) where - fromString str - | '[' `L.elem` str = IPv6 <$> fromString str - | otherwise = IPv4 <$> fromString str - --- | fingerprint + "at" + dotted.host.inet.addr:port --- TODO: instances for IPv6, HostName -instance Pretty a => Pretty (PeerAddr a) where - pretty PeerAddr {..} - | Just pid <- peerId = pretty (fingerprint pid) <+> "at" <+> paddr - | otherwise = paddr - where - paddr = pretty peerHost <> ":" <> text (show peerPort) - -instance Hashable a => Hashable (PeerAddr a) where - hashWithSalt s PeerAddr {..} = - s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort - --- | Ports typically reserved for bittorrent P2P listener. -defaultPorts :: [PortNumber] -defaultPorts = [6881..6889] - -_resolvePeerAddr :: (IPAddress i) => PeerAddr HostName -> PeerAddr i -_resolvePeerAddr = undefined - -_peerSockAddr :: PeerAddr IP -> (Family, SockAddr) -_peerSockAddr PeerAddr {..} = - case peerHost of - IPv4 ipv4 -> - (AF_INET, SockAddrInet peerPort (toHostAddress ipv4)) - IPv6 ipv6 -> - (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0) - -peerSockAddr :: PeerAddr IP -> SockAddr -peerSockAddr = snd . _peerSockAddr - --- | Create a socket connected to the address specified in a peerAddr -peerSocket :: SocketType -> PeerAddr IP -> IO Socket -peerSocket socketType pa = do - let (family, addr) = _peerSockAddr pa - sock <- socket family socketType defaultProtocol - connect sock addr - return sock diff --git a/src/Network/BitTorrent/Core/PeerId.hs b/src/Network/BitTorrent/Core/PeerId.hs deleted file mode 100644 index a180ff30..00000000 --- a/src/Network/BitTorrent/Core/PeerId.hs +++ /dev/null @@ -1,364 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- 'PeerID' represent self assigned peer identificator. Ideally each --- host in the network should have unique peer id to avoid --- collisions, therefore for peer ID generation we use good entropy --- source. Peer ID is sent in /tracker request/, sent and received in --- /peer handshakes/ and used in DHT queries. --- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Network.BitTorrent.Core.PeerId - ( -- * PeerId - PeerId - - -- * Generation - , genPeerId - , timestamp - , entropy - - -- * Encoding - , azureusStyle - , shadowStyle - , defaultClientId - , defaultVersionNumber - - -- * Decoding - , fingerprint - ) where - -import Control.Applicative -import Data.BEncode as BE -import Data.ByteString as BS -import Data.ByteString.Internal as BS -import Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Builder as BS -import Data.Convertible -import Data.Default -import Data.Foldable (foldMap) -import Data.List as L -import Data.List.Split as L -import Data.Maybe (fromMaybe, catMaybes) -import Data.Monoid -import Data.Hashable -import Data.Serialize as S -import Data.String -import Data.Time.Clock (getCurrentTime) -import Data.Time.Format (formatTime) -import Data.Typeable -import Data.Version (Version(Version), versionBranch) -import Network.HTTP.Types.QueryLike -import System.Entropy (getEntropy) -import System.Locale (defaultTimeLocale) -import Text.PrettyPrint hiding ((<>)) -import Text.PrettyPrint.Class -import Text.Read (readMaybe) - -import Network.BitTorrent.Core.Fingerprint - --- TODO use unpacked Word160 form (length is known statically) - --- | Peer identifier is exactly 20 bytes long bytestring. -newtype PeerId = PeerId { getPeerId :: ByteString } - deriving (Show, Eq, Ord, BEncode, Typeable) - -peerIdLen :: Int -peerIdLen = 20 - --- | For testing purposes only. -instance Default PeerId where - def = azureusStyle defaultClientId defaultVersionNumber "" - -instance Hashable PeerId where - hashWithSalt = hashUsing getPeerId - {-# INLINE hashWithSalt #-} - -instance Serialize PeerId where - put = putByteString . getPeerId - get = PeerId <$> getBytes peerIdLen - -instance QueryValueLike PeerId where - toQueryValue (PeerId pid) = Just pid - {-# INLINE toQueryValue #-} - -instance IsString PeerId where - fromString str - | BS.length bs == peerIdLen = PeerId bs - | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str - where - bs = fromString str - -instance Pretty PeerId where - pretty = text . BC.unpack . getPeerId - -instance Convertible BS.ByteString PeerId where - safeConvert bs - | BS.length bs == peerIdLen = pure (PeerId bs) - | otherwise = convError "invalid length" bs - -{----------------------------------------------------------------------- --- Encoding ------------------------------------------------------------------------} - --- | Pad bytestring so it's becomes exactly request length. Conversion --- is done like so: --- --- * length < size: Complete bytestring by given charaters. --- --- * length = size: Output bytestring as is. --- --- * length > size: Drop last (length - size) charaters from a --- given bytestring. --- -byteStringPadded :: ByteString -- ^ bytestring to be padded. - -> Int -- ^ size of result builder. - -> Char -- ^ character used for padding. - -> BS.Builder -byteStringPadded bs s c = - BS.byteString (BS.take s bs) <> - BS.byteString (BC.replicate padLen c) - where - padLen = s - min (BS.length bs) s - --- | Azureus-style encoding have the following layout: --- --- * 1 byte : '-' --- --- * 2 bytes: client id --- --- * 4 bytes: version number --- --- * 1 byte : '-' --- --- * 12 bytes: random number --- -azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'. - -> ByteString -- ^ Version number, padded with 'X'. - -> ByteString -- ^ Random number, padded with '0'. - -> PeerId -- ^ Azureus-style encoded peer ID. -azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ - BS.char8 '-' <> - byteStringPadded cid 2 'H' <> - byteStringPadded ver 4 'X' <> - BS.char8 '-' <> - byteStringPadded rnd 12 '0' - --- | Shadow-style encoding have the following layout: --- --- * 1 byte : client id. --- --- * 0-4 bytes: version number. If less than 4 then padded with --- '-' char. --- --- * 15 bytes : random number. If length is less than 15 then --- padded with '0' char. --- -shadowStyle :: Char -- ^ Client ID. - -> ByteString -- ^ Version number. - -> ByteString -- ^ Random number. - -> PeerId -- ^ Shadow style encoded peer ID. -shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ - BS.char8 cid <> - byteStringPadded ver 4 '-' <> - byteStringPadded rnd 15 '0' - - --- | 'HS'- 2 bytes long client identifier. -defaultClientId :: ByteString -defaultClientId = "HS" - --- | Gives exactly 4 bytes long version number for any version of the --- package. Version is taken from .cabal file. -defaultVersionNumber :: ByteString -defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $ - versionBranch $ ciVersion libFingerprint - -{----------------------------------------------------------------------- --- Generation ------------------------------------------------------------------------} - --- | Gives 15 characters long decimal timestamp such that: --- --- * 6 bytes : first 6 characters from picoseconds obtained with %q. --- --- * 1 byte : character \'.\' for readability. --- --- * 9..* bytes: number of whole seconds since the Unix epoch --- (!)REVERSED. --- --- Can be used both with shadow and azureus style encoding. This --- format is used to make the ID's readable for debugging purposes. --- -timestamp :: IO ByteString -timestamp = (BC.pack . format) <$> getCurrentTime - where - format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++ - L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t)) - --- | Gives 15 character long random bytestring. This is more robust --- method for generation of random part of peer ID than 'timestamp'. -entropy :: IO ByteString -entropy = getEntropy 15 - --- NOTE: entropy generates incorrrect peer id - --- | Here we use 'azureusStyle' encoding with the following args: --- --- * 'HS' for the client id; ('defaultClientId') --- --- * Version of the package for the version number; --- ('defaultVersionNumber') --- --- * UTC time day ++ day time for the random number. ('timestamp') --- -genPeerId :: IO PeerId -genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp - -{----------------------------------------------------------------------- --- Decoding ------------------------------------------------------------------------} - -parseImpl :: ByteString -> ClientImpl -parseImpl = f . BC.unpack - where - f "AG" = IAres - f "A~" = IAres - f "AR" = IArctic - f "AV" = IAvicora - f "AX" = IBitPump - f "AZ" = IAzureus - f "BB" = IBitBuddy - f "BC" = IBitComet - f "BF" = IBitflu - f "BG" = IBTG - f "BR" = IBitRocket - f "BS" = IBTSlave - f "BX" = IBittorrentX - f "CD" = IEnhancedCTorrent - f "CT" = ICTorrent - f "DE" = IDelugeTorrent - f "DP" = IPropagateDataClient - f "EB" = IEBit - f "ES" = IElectricSheep - f "FT" = IFoxTorrent - f "GS" = IGSTorrent - f "HL" = IHalite - f "HS" = IlibHSbittorrent - f "HN" = IHydranode - f "KG" = IKGet - f "KT" = IKTorrent - f "LH" = ILH_ABC - f "LP" = ILphant - f "LT" = ILibtorrent - f "lt" = ILibTorrent - f "LW" = ILimeWire - f "MO" = IMonoTorrent - f "MP" = IMooPolice - f "MR" = IMiro - f "ML" = IMLdonkey - f "MT" = IMoonlightTorrent - f "NX" = INetTransport - f "PD" = IPando - f "qB" = IqBittorrent - f "QD" = IQQDownload - f "QT" = IQt4TorrentExample - f "RT" = IRetriever - f "S~" = IShareaza - f "SB" = ISwiftbit - f "SS" = ISwarmScope - f "ST" = ISymTorrent - f "st" = Isharktorrent - f "SZ" = IShareaza - f "TN" = ITorrentDotNET - f "TR" = ITransmission - f "TS" = ITorrentstorm - f "TT" = ITuoTu - f "UL" = IuLeecher - f "UT" = IuTorrent - f "VG" = IVagaa - f "WT" = IBitLet - f "WY" = IFireTorrent - f "XL" = IXunlei - f "XT" = IXanTorrent - f "XX" = IXtorrent - f "ZT" = IZipTorrent - f _ = IUnknown - --- TODO use regexps - --- | Tries to extract meaningful information from peer ID bytes. If --- peer id uses unknown coding style then client info returned is --- 'def'. --- -fingerprint :: PeerId -> Fingerprint -fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid) - where - getCI = do - leading <- BS.w2c <$> getWord8 - case leading of - '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion - 'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion - 'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion - 'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion - c -> do - c1 <- w2c <$> S.lookAhead getWord8 - if c1 == 'P' - then do - _ <- getWord8 - Fingerprint <$> pure IOpera <*> getOperaVersion - else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion - - getMainlineVersion = do - str <- BC.unpack <$> getByteString 7 - let mnums = L.filter (not . L.null) $ L.linesBy ('-' ==) str - return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) [] - - getAzureusImpl = parseImpl <$> getByteString 2 - getAzureusVersion = mkVer <$> getByteString 4 - where - mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] [] - - getBitCometImpl = do - bs <- getByteString 3 - S.lookAhead $ do - _ <- getByteString 2 - lr <- getByteString 4 - return $ - if lr == "LORD" then IBitLord else - if bs == "UTB" then IBitComet else - if bs == "xbc" then IBitComet else def - - getBitCometVersion = do - x <- getWord8 - y <- getWord8 - return $ Version [fromIntegral x, fromIntegral y] [] - - getOperaVersion = do - str <- BC.unpack <$> getByteString 4 - return $ Version [fromMaybe 0 $ readMaybe str] [] - - getShadowImpl 'A' = IABC - getShadowImpl 'O' = IOspreyPermaseed - getShadowImpl 'Q' = IBTQueue - getShadowImpl 'R' = ITribler - getShadowImpl 'S' = IShadow - getShadowImpl 'T' = IBitTornado - getShadowImpl _ = IUnknown - - decodeShadowVerNr :: Char -> Maybe Int - decodeShadowVerNr c - | '0' < c && c <= '9' = Just (fromEnum c - fromEnum '0') - | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10) - | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36) - | otherwise = Nothing - - getShadowVersion = do - str <- BC.unpack <$> getByteString 5 - return $ Version (catMaybes $ L.map decodeShadowVerNr str) [] diff --git a/src/Network/BitTorrent/DHT.hs b/src/Network/BitTorrent/DHT.hs index b6067456..39b33478 100644 --- a/src/Network/BitTorrent/DHT.hs +++ b/src/Network/BitTorrent/DHT.hs @@ -63,7 +63,7 @@ import Data.Conduit.List as C import Network.Socket import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.DHT.Query import Network.BitTorrent.DHT.Session import Network.BitTorrent.DHT.Routing as T diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs index 201b84ee..baa240b4 100644 --- a/src/Network/BitTorrent/DHT/ContactInfo.hs +++ b/src/Network/BitTorrent/DHT/ContactInfo.hs @@ -12,13 +12,13 @@ import Data.HashMap.Strict as HM import Data.Serialize import Data.Torrent -import Network.BitTorrent.Core.PeerAddr +import Network.BitTorrent.Address {- import Data.HashMap.Strict as HM import Data.Torrent.InfoHash -import Network.BitTorrent.Core +import Network.BitTorrent.Address -- increase prefix when table is too large -- decrease prefix when table is too small diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs index 06274fa7..145141ee 100644 --- a/src/Network/BitTorrent/DHT/Message.hs +++ b/src/Network/BitTorrent/DHT/Message.hs @@ -93,7 +93,7 @@ import Network import Network.KRPC import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.DHT.Token import Network.KRPC () diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs index 497c9001..d4710ecf 100644 --- a/src/Network/BitTorrent/DHT/Query.hs +++ b/src/Network/BitTorrent/DHT/Query.hs @@ -57,7 +57,7 @@ import Text.PrettyPrint.Class import Network.KRPC hiding (Options, def) import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.DHT.Message import Network.BitTorrent.DHT.Routing import Network.BitTorrent.DHT.Session diff --git a/src/Network/BitTorrent/DHT/Routing.hs b/src/Network/BitTorrent/DHT/Routing.hs index 5dc511bd..ee295125 100644 --- a/src/Network/BitTorrent/DHT/Routing.hs +++ b/src/Network/BitTorrent/DHT/Routing.hs @@ -74,7 +74,7 @@ import Text.PrettyPrint as PP hiding ((<>)) import Text.PrettyPrint.Class import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address {----------------------------------------------------------------------- -- Routing monad diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs index 8fe81abd..0dd4b862 100644 --- a/src/Network/BitTorrent/DHT/Session.hs +++ b/src/Network/BitTorrent/DHT/Session.hs @@ -94,8 +94,7 @@ import Text.PrettyPrint.Class import Data.Torrent as Torrent import Network.KRPC hiding (Options, def) import qualified Network.KRPC as KRPC (def) -import Network.BitTorrent.Core -import Network.BitTorrent.Core.PeerAddr +import Network.BitTorrent.Address import Network.BitTorrent.DHT.ContactInfo as P import Network.BitTorrent.DHT.Message import Network.BitTorrent.DHT.Routing as R diff --git a/src/Network/BitTorrent/DHT/Token.hs b/src/Network/BitTorrent/DHT/Token.hs index a38456fd..a0ed428b 100644 --- a/src/Network/BitTorrent/DHT/Token.hs +++ b/src/Network/BitTorrent/DHT/Token.hs @@ -50,7 +50,7 @@ import Data.String import Data.Time import System.Random -import Network.BitTorrent.Core +import Network.BitTorrent.Address -- TODO use ShortByteString diff --git a/src/Network/BitTorrent/Exchange/Assembler.hs b/src/Network/BitTorrent/Exchange/Assembler.hs index e17dfbe2..7abb8ab0 100644 --- a/src/Network/BitTorrent/Exchange/Assembler.hs +++ b/src/Network/BitTorrent/Exchange/Assembler.hs @@ -68,7 +68,7 @@ import Data.Maybe import Data.IP import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Block as B {----------------------------------------------------------------------- diff --git a/src/Network/BitTorrent/Exchange/Connection.hs b/src/Network/BitTorrent/Exchange/Connection.hs index 42b991a0..9b7942ae 100644 --- a/src/Network/BitTorrent/Exchange/Connection.hs +++ b/src/Network/BitTorrent/Exchange/Connection.hs @@ -137,7 +137,7 @@ import System.Timeout import Data.Torrent.Bitfield as BF import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Message as Msg -- TODO handle port message? diff --git a/src/Network/BitTorrent/Exchange/Manager.hs b/src/Network/BitTorrent/Exchange/Manager.hs index ad7a47a2..54727805 100644 --- a/src/Network/BitTorrent/Exchange/Manager.hs +++ b/src/Network/BitTorrent/Exchange/Manager.hs @@ -13,7 +13,7 @@ import Data.Default import Network.Socket import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Connection hiding (Options) import Network.BitTorrent.Exchange.Session diff --git a/src/Network/BitTorrent/Exchange/Message.hs b/src/Network/BitTorrent/Exchange/Message.hs index 5ca7c97e..a0cb5c91 100644 --- a/src/Network/BitTorrent/Exchange/Message.hs +++ b/src/Network/BitTorrent/Exchange/Message.hs @@ -120,7 +120,7 @@ import Text.PrettyPrint.Class import Data.Torrent.Bitfield import Data.Torrent hiding (Piece (..)) import qualified Data.Torrent as P (Piece (..)) -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Block {----------------------------------------------------------------------- diff --git a/src/Network/BitTorrent/Exchange/Session.hs b/src/Network/BitTorrent/Exchange/Session.hs index cae3a2d5..b68f17a0 100644 --- a/src/Network/BitTorrent/Exchange/Session.hs +++ b/src/Network/BitTorrent/Exchange/Session.hs @@ -48,7 +48,7 @@ import Data.BEncode as BE import Data.Torrent as Torrent import Data.Torrent.Bitfield as BF import Network.BitTorrent.Internal.Types -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Block as Block import Network.BitTorrent.Exchange.Connection import Network.BitTorrent.Exchange.Message as Message diff --git a/src/Network/BitTorrent/Exchange/Session/Metadata.hs b/src/Network/BitTorrent/Exchange/Session/Metadata.hs index a4e54659..f08ebe00 100644 --- a/src/Network/BitTorrent/Exchange/Session/Metadata.hs +++ b/src/Network/BitTorrent/Exchange/Session/Metadata.hs @@ -27,7 +27,7 @@ import Data.Tuple import Data.BEncode as BE import Data.Torrent as Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Block as Block import Network.BitTorrent.Exchange.Message as Message hiding (Status) diff --git a/src/Network/BitTorrent/Exchange/Session/Status.hs b/src/Network/BitTorrent/Exchange/Session/Status.hs index 4feff8d6..63b91926 100644 --- a/src/Network/BitTorrent/Exchange/Session/Status.hs +++ b/src/Network/BitTorrent/Exchange/Session/Status.hs @@ -30,7 +30,7 @@ import Data.Tuple import Data.Torrent import Data.Torrent.Bitfield as BF -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Block as Block import System.Torrent.Storage (Storage, writePiece) diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs index e58f6d70..d251d0ad 100644 --- a/src/Network/BitTorrent/Tracker/Message.hs +++ b/src/Network/BitTorrent/Tracker/Message.hs @@ -126,7 +126,7 @@ import Text.Read (readMaybe) import Data.Torrent import Data.Torrent.Progress -import Network.BitTorrent.Core +import Network.BitTorrent.Address {----------------------------------------------------------------------- diff --git a/src/Network/BitTorrent/Tracker/RPC.hs b/src/Network/BitTorrent/Tracker/RPC.hs index 9148f1f5..ecb1001c 100644 --- a/src/Network/BitTorrent/Tracker/RPC.hs +++ b/src/Network/BitTorrent/Tracker/RPC.hs @@ -38,7 +38,7 @@ import Network.Socket (HostAddress) import Data.Torrent import Data.Torrent.Progress -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Tracker.Message import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP import qualified Network.BitTorrent.Tracker.RPC.UDP as UDP diff --git a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs index b4924e6d..6e55eb04 100644 --- a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs +++ b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs @@ -48,7 +48,7 @@ import Network.HTTP.Types.Header (hUserAgent) import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery) import Data.Torrent (InfoHash) -import Network.BitTorrent.Core.Fingerprint (libUserAgent) +import Network.BitTorrent.Address (libUserAgent) import Network.BitTorrent.Tracker.Message hiding (Request, Response) {----------------------------------------------------------------------- diff --git a/src/Network/BitTorrent/Tracker/Session.hs b/src/Network/BitTorrent/Tracker/Session.hs index 35db459f..cef7d665 100644 --- a/src/Network/BitTorrent/Tracker/Session.hs +++ b/src/Network/BitTorrent/Tracker/Session.hs @@ -58,7 +58,7 @@ import Data.Traversable import Network.URI import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Internal.Cache import Network.BitTorrent.Internal.Types import Network.BitTorrent.Tracker.List as TL diff --git a/tests/Config.hs b/tests/Config.hs index 09e838cc..9ffb0d8c 100644 --- a/tests/Config.hs +++ b/tests/Config.hs @@ -33,7 +33,7 @@ import System.IO.Unsafe import Test.Hspec import Data.Torrent -import Network.BitTorrent.Core (IP, PeerAddr (PeerAddr), genPeerId) +import Network.BitTorrent.Address (IP, PeerAddr (PeerAddr), genPeerId) type ClientName = String diff --git a/tests/Data/TorrentSpec.hs b/tests/Data/TorrentSpec.hs index 7186429e..b4a280e4 100644 --- a/tests/Data/TorrentSpec.hs +++ b/tests/Data/TorrentSpec.hs @@ -19,7 +19,7 @@ import Test.QuickCheck import Test.QuickCheck.Instances () import Data.Torrent -import Network.BitTorrent.Core.NodeInfoSpec () +import Network.BitTorrent.CoreSpec () pico :: Gen (Maybe NominalDiffTime) diff --git a/tests/Network/BitTorrent/Core/FingerprintSpec.hs b/tests/Network/BitTorrent/Core/FingerprintSpec.hs index df62442a..f8ed6950 100644 --- a/tests/Network/BitTorrent/Core/FingerprintSpec.hs +++ b/tests/Network/BitTorrent/Core/FingerprintSpec.hs @@ -1,7 +1,7 @@ -- | see module Network.BitTorrent.Core.FingerprintSpec (spec) where import Test.Hspec -import Network.BitTorrent.Core.PeerId +import Network.BitTorrent.Address spec :: Spec spec = do diff --git a/tests/Network/BitTorrent/Core/NodeInfoSpec.hs b/tests/Network/BitTorrent/Core/NodeInfoSpec.hs index fb777440..0d30b9a6 100644 --- a/tests/Network/BitTorrent/Core/NodeInfoSpec.hs +++ b/tests/Network/BitTorrent/Core/NodeInfoSpec.hs @@ -6,7 +6,7 @@ import Data.String import Test.Hspec import Test.QuickCheck -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Core.PeerAddrSpec () instance Arbitrary NodeId where diff --git a/tests/Network/BitTorrent/Core/PeerAddrSpec.hs b/tests/Network/BitTorrent/Core/PeerAddrSpec.hs index abb90183..387126db 100644 --- a/tests/Network/BitTorrent/Core/PeerAddrSpec.hs +++ b/tests/Network/BitTorrent/Core/PeerAddrSpec.hs @@ -11,8 +11,8 @@ import Network import Test.Hspec import Test.QuickCheck -import Network.BitTorrent.Core.PeerIdSpec hiding (spec) -import Network.BitTorrent.Core.PeerAddr +import Network.BitTorrent.Core.PeerIdSpec () +import Network.BitTorrent.Address instance Arbitrary IPv4 where arbitrary = do diff --git a/tests/Network/BitTorrent/Core/PeerIdSpec.hs b/tests/Network/BitTorrent/Core/PeerIdSpec.hs index 4b0c2398..29b98bbc 100644 --- a/tests/Network/BitTorrent/Core/PeerIdSpec.hs +++ b/tests/Network/BitTorrent/Core/PeerIdSpec.hs @@ -6,7 +6,7 @@ import Data.Text.Encoding as T import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () -import Network.BitTorrent.Core.PeerId +import Network.BitTorrent.Address instance Arbitrary PeerId where diff --git a/tests/Network/BitTorrent/CoreSpec.hs b/tests/Network/BitTorrent/CoreSpec.hs index 460c52be..1e1a21a1 100644 --- a/tests/Network/BitTorrent/CoreSpec.hs +++ b/tests/Network/BitTorrent/CoreSpec.hs @@ -1,9 +1,9 @@ -- | Re-export modules. module Network.BitTorrent.CoreSpec (spec) where import Network.BitTorrent.Core.FingerprintSpec as CoreSpec () +import Network.BitTorrent.Core.PeerAddrSpec as CoreSpec () import Network.BitTorrent.Core.NodeInfoSpec as CoreSpec () import Network.BitTorrent.Core.PeerIdSpec as CoreSpec () -import Network.BitTorrent.Core.PeerAddrSpec as CoreSpec () import Test.Hspec (Spec) diff --git a/tests/Network/BitTorrent/DHT/MessageSpec.hs b/tests/Network/BitTorrent/DHT/MessageSpec.hs index 3d886fea..ab6e1ea5 100644 --- a/tests/Network/BitTorrent/DHT/MessageSpec.hs +++ b/tests/Network/BitTorrent/DHT/MessageSpec.hs @@ -8,7 +8,7 @@ import Data.ByteString.Lazy as BL import Data.Default import Data.List as L import Data.Maybe -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.DHT.Message import qualified Network.KRPC as KRPC (def) import Network.KRPC hiding (def) diff --git a/tests/Network/BitTorrent/DHT/QuerySpec.hs b/tests/Network/BitTorrent/DHT/QuerySpec.hs index d25bd120..81c3b45b 100644 --- a/tests/Network/BitTorrent/DHT/QuerySpec.hs +++ b/tests/Network/BitTorrent/DHT/QuerySpec.hs @@ -9,7 +9,7 @@ import Data.Default import Data.List as L import Test.Hspec -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.DHT import Network.BitTorrent.DHT.Session import Network.BitTorrent.DHT.Query diff --git a/tests/Network/BitTorrent/DHT/RoutingSpec.hs b/tests/Network/BitTorrent/DHT/RoutingSpec.hs index c4a33357..aeccff5f 100644 --- a/tests/Network/BitTorrent/DHT/RoutingSpec.hs +++ b/tests/Network/BitTorrent/DHT/RoutingSpec.hs @@ -8,7 +8,7 @@ import Data.Maybe import Test.Hspec import Test.QuickCheck -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.DHT.Routing as T import Network.BitTorrent.CoreSpec hiding (spec) diff --git a/tests/Network/BitTorrent/DHT/SessionSpec.hs b/tests/Network/BitTorrent/DHT/SessionSpec.hs index 1fe1d08a..522bd8df 100644 --- a/tests/Network/BitTorrent/DHT/SessionSpec.hs +++ b/tests/Network/BitTorrent/DHT/SessionSpec.hs @@ -10,7 +10,7 @@ import Data.List as L import Test.Hspec import Test.QuickCheck -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.DHT import Network.BitTorrent.DHT.Message import Network.BitTorrent.DHT.Session diff --git a/tests/Network/BitTorrent/DHT/TokenSpec.hs b/tests/Network/BitTorrent/DHT/TokenSpec.hs index 6353a24c..a45d2212 100644 --- a/tests/Network/BitTorrent/DHT/TokenSpec.hs +++ b/tests/Network/BitTorrent/DHT/TokenSpec.hs @@ -7,7 +7,7 @@ import Data.String import Test.Hspec import Test.QuickCheck -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.CoreSpec () import Network.BitTorrent.DHT.Token as T diff --git a/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs b/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs index ccbf2854..d654cda1 100644 --- a/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs +++ b/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs @@ -8,7 +8,7 @@ import Test.Hspec import Test.QuickCheck import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Connection import Network.BitTorrent.Exchange.Message diff --git a/tests/Network/BitTorrent/Exchange/MessageSpec.hs b/tests/Network/BitTorrent/Exchange/MessageSpec.hs index 1395ba11..f82b034e 100644 --- a/tests/Network/BitTorrent/Exchange/MessageSpec.hs +++ b/tests/Network/BitTorrent/Exchange/MessageSpec.hs @@ -13,7 +13,7 @@ import Test.QuickCheck import Data.TorrentSpec () import Data.Torrent.BitfieldSpec () import Network.BitTorrent.CoreSpec () -import Network.BitTorrent.Core () +import Network.BitTorrent.Address () import Network.BitTorrent.Exchange.BlockSpec () import Network.BitTorrent.Exchange.Message diff --git a/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs b/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs index 5392d74b..fc5236da 100644 --- a/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs +++ b/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs @@ -8,7 +8,7 @@ import Test.QuickCheck import Data.BEncode as BE import Data.Torrent as Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Message import Network.BitTorrent.Exchange.Session.Metadata diff --git a/tests/Network/BitTorrent/Exchange/SessionSpec.hs b/tests/Network/BitTorrent/Exchange/SessionSpec.hs index c2c76644..bf5b95a1 100644 --- a/tests/Network/BitTorrent/Exchange/SessionSpec.hs +++ b/tests/Network/BitTorrent/Exchange/SessionSpec.hs @@ -3,7 +3,7 @@ module Network.BitTorrent.Exchange.SessionSpec (spec) where import Test.Hspec import Data.Torrent -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Session import Config diff --git a/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/tests/Network/BitTorrent/Tracker/MessageSpec.hs index 439883a1..92fd8d79 100644 --- a/tests/Network/BitTorrent/Tracker/MessageSpec.hs +++ b/tests/Network/BitTorrent/Tracker/MessageSpec.hs @@ -18,11 +18,11 @@ import Test.QuickCheck import Data.TorrentSpec () import Data.Torrent.ProgressSpec () -import Network.BitTorrent.Core.PeerIdSpec () -import Network.BitTorrent.Core.PeerAddrSpec () +import Network.BitTorrent.Address () +import Network.BitTorrent.Address () import Network.BitTorrent.Tracker.Message as Message -import Network.BitTorrent.Core +import Network.BitTorrent.Address --prop_bencode :: Eq a => BEncode a => a -> Bool diff --git a/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs b/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs index 8a1ffc01..1ec3bdb7 100644 --- a/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs +++ b/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs @@ -9,7 +9,7 @@ import Data.List as L import Data.Maybe import Test.Hspec -import Network.BitTorrent.Core +import Network.BitTorrent.Address import Network.BitTorrent.Tracker.Message as Message import Network.BitTorrent.Tracker.TestData -- cgit v1.2.3 From 2a9a39dccbe7ed46b537d6b051c42432c275e156 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 8 Apr 2014 03:11:59 +0400 Subject: Fold CoreSpec modules --- bittorrent.cabal | 4 - tests/Network/BitTorrent/Core/FingerprintSpec.hs | 33 --- tests/Network/BitTorrent/Core/NodeInfoSpec.hs | 52 ---- tests/Network/BitTorrent/Core/PeerAddrSpec.hs | 221 ---------------- tests/Network/BitTorrent/Core/PeerIdSpec.hs | 25 -- tests/Network/BitTorrent/CoreSpec.hs | 308 ++++++++++++++++++++++- 6 files changed, 301 insertions(+), 342 deletions(-) delete mode 100644 tests/Network/BitTorrent/Core/FingerprintSpec.hs delete mode 100644 tests/Network/BitTorrent/Core/NodeInfoSpec.hs delete mode 100644 tests/Network/BitTorrent/Core/PeerAddrSpec.hs delete mode 100644 tests/Network/BitTorrent/Core/PeerIdSpec.hs (limited to 'tests/Network') diff --git a/bittorrent.cabal b/bittorrent.cabal index 761ed1c4..6df074bb 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -177,10 +177,6 @@ test-suite spec Data.Torrent.ProgressSpec Network.BitTorrent.Client.HandleSpec Network.BitTorrent.CoreSpec - Network.BitTorrent.Core.FingerprintSpec - Network.BitTorrent.Core.NodeInfoSpec - Network.BitTorrent.Core.PeerAddrSpec - Network.BitTorrent.Core.PeerIdSpec Network.BitTorrent.DHTSpec Network.BitTorrent.DHT.TestData Network.BitTorrent.DHT.MessageSpec diff --git a/tests/Network/BitTorrent/Core/FingerprintSpec.hs b/tests/Network/BitTorrent/Core/FingerprintSpec.hs deleted file mode 100644 index f8ed6950..00000000 --- a/tests/Network/BitTorrent/Core/FingerprintSpec.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | see -module Network.BitTorrent.Core.FingerprintSpec (spec) where -import Test.Hspec -import Network.BitTorrent.Address - -spec :: Spec -spec = do - describe "client info" $ do - it "decode mainline encoded peer id" $ do - fingerprint "M4-3-6--xxxxxxxxxxxx" `shouldBe` "Mainline-4.3.6" - fingerprint "M4-20-8-xxxxxxxxxxxx" `shouldBe` "Mainline-4.20.8" - - it "decode azureus encoded peer id" $ do - fingerprint "-AZ2060-xxxxxxxxxxxx" `shouldBe` "Azureus-2060" - fingerprint "-BS0000-xxxxxxxxxxxx" `shouldBe` "BTSlave-0" - - it "decode Shad0w style peer id" $ do - fingerprint "S58B-----xxxxxxxxxxx" `shouldBe` "Shadow-5.8.11" - fingerprint "T58B-----xxxxxxxxxxx" `shouldBe` "BitTornado-5.8.11" - - it "decode bitcomet style peer id" $ do - fingerprint "exbc01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49" - fingerprint "FUTB01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49" - fingerprint "exbc01LORDxxxxxxxxxx" `shouldBe` "BitLord-48.49" - - it "decode opera style peer id" $ do - fingerprint "OP0123xxxxxxxxxxxxxx" `shouldBe` "Opera-123" - - it "decode ML donkey style peer id" $ do - fingerprint "-ML2.7.2-xxxxxxxxxxx" `shouldBe` "MLdonkey-0" - --- TODO XBT, Bits on Wheels, Queen Bee, BitTyrant, TorrenTopia, --- BitSpirit, Rufus, G3 Torrent, FlashGet \ No newline at end of file diff --git a/tests/Network/BitTorrent/Core/NodeInfoSpec.hs b/tests/Network/BitTorrent/Core/NodeInfoSpec.hs deleted file mode 100644 index 0d30b9a6..00000000 --- a/tests/Network/BitTorrent/Core/NodeInfoSpec.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Core.NodeInfoSpec (spec) where -import Control.Applicative -import Data.Serialize as S -import Data.String -import Test.Hspec -import Test.QuickCheck - -import Network.BitTorrent.Address -import Network.BitTorrent.Core.PeerAddrSpec () - -instance Arbitrary NodeId where - arbitrary = fromString <$> vector 20 - -instance Arbitrary a => Arbitrary (NodeAddr a) where - arbitrary = NodeAddr <$> arbitrary <*> arbitrary - -instance Arbitrary a => Arbitrary (NodeInfo a) where - arbitrary = NodeInfo <$> arbitrary <*> arbitrary - -spec :: Spec -spec = do - describe "NodeId" $ do - it "properly serialized" $ do - S.decode "mnopqrstuvwxyz123456" - `shouldBe` Right ("mnopqrstuvwxyz123456" :: NodeId) - - S.encode ("mnopqrstuvwxyz123456" :: NodeId) - `shouldBe` "mnopqrstuvwxyz123456" - - it "properly serialized (iso)" $ property $ \ nid -> - S.decode (S.encode nid) `shouldBe` - Right (nid :: NodeId) - - describe "NodeAddr" $ do - it "properly serialized" $ do - S.decode "\127\0\0\1\1\2" `shouldBe` - Right ("127.0.0.1:258" :: NodeAddr IPv4) - - it "properly serialized (iso)" $ property $ \ nid -> - S.decode (S.encode nid) `shouldBe` - Right (nid :: NodeAddr IPv4) - - describe "NodeInfo" $ do - it "properly serialized" $ do - S.decode "mnopqrstuvwxyz123456\ - \\127\0\0\1\1\2" `shouldBe` Right - (NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258" :: NodeInfo IPv4) - - it "properly serialized (iso)" $ property $ \ nid -> - S.decode (S.encode nid) `shouldBe` - Right (nid :: NodeInfo IPv4) diff --git a/tests/Network/BitTorrent/Core/PeerAddrSpec.hs b/tests/Network/BitTorrent/Core/PeerAddrSpec.hs deleted file mode 100644 index 387126db..00000000 --- a/tests/Network/BitTorrent/Core/PeerAddrSpec.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.BitTorrent.Core.PeerAddrSpec (spec) where -import Control.Applicative -import Data.BEncode as BE -import Data.ByteString.Lazy as BL -import Data.IP -import Data.Serialize as S -import Data.Word -import Network -import Test.Hspec -import Test.QuickCheck - -import Network.BitTorrent.Core.PeerIdSpec () -import Network.BitTorrent.Address - -instance Arbitrary IPv4 where - arbitrary = do - a <- choose (0, 255) - b <- choose (0, 255) - c <- choose (0, 255) - d <- choose (0, 255) - return $ toIPv4 [a, b, c, d] - -instance Arbitrary IPv6 where - arbitrary = do - a <- choose (0, fromIntegral (maxBound :: Word16)) - b <- choose (0, fromIntegral (maxBound :: Word16)) - c <- choose (0, fromIntegral (maxBound :: Word16)) - d <- choose (0, fromIntegral (maxBound :: Word16)) - e <- choose (0, fromIntegral (maxBound :: Word16)) - f <- choose (0, fromIntegral (maxBound :: Word16)) - g <- choose (0, fromIntegral (maxBound :: Word16)) - h <- choose (0, fromIntegral (maxBound :: Word16)) - return $ toIPv6 [a, b, c, d, e, f, g, h] - -instance Arbitrary IP where - arbitrary = frequency - [ (1, IPv4 <$> arbitrary) - , (1, IPv6 <$> arbitrary) - ] - -instance Arbitrary PortNumber where - arbitrary = fromIntegral <$> (arbitrary :: Gen Word16) - -instance Arbitrary a => Arbitrary (PeerAddr a) where - arbitrary = PeerAddr <$> arbitrary <*> arbitrary <*> arbitrary - -spec :: Spec -spec = do - describe "PortNumber" $ do - it "properly serialized" $ do - S.decode "\x1\x2" `shouldBe` Right (258 :: PortNumber) - S.encode (258 :: PortNumber) `shouldBe` "\x1\x2" - - it "properly bencoded" $ do - BE.decode "i80e" `shouldBe` Right (80 :: PortNumber) - - it "fail if port number is invalid" $ do - (BE.decode "i-10e" :: BE.Result PortNumber) - `shouldBe` - Left "fromBEncode: unable to decode PortNumber: -10" - - (BE.decode "i70000e" :: BE.Result PortNumber) - `shouldBe` - Left "fromBEncode: unable to decode PortNumber: 70000" - - describe "Peer IPv4" $ do - it "properly serialized" $ do - S.decode "\x1\x2\x3\x4" `shouldBe` Right (toIPv4 [1, 2, 3, 4]) - S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4" - - it "properly serialized (iso)" $ property $ \ ip -> do - S.decode (S.encode ip) `shouldBe` Right (ip :: IPv4) - - it "properly bencoded" $ do - BE.decode "11:168.192.0.1" `shouldBe` Right (toIPv4 [168, 192, 0, 1]) - BE.encode (toIPv4 [168, 192, 0, 1]) `shouldBe` "11:168.192.0.1" - - it "properly bencoded (iso)" $ property $ \ ip -> - BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4) - - it "fail gracefully on invalid strings" $ do - BE.decode "3:1.1" `shouldBe` - (Left "fromBEncode: unable to decode IP: 1.1" :: BE.Result IPv4) - - it "fail gracefully on invalid bencode" $ do - BE.decode "i10e" `shouldBe` - (Left "fromBEncode: unable to decode IP: addr should be a bstring" - :: BE.Result IPv4) - - describe "Peer IPv6" $ do - it "properly serialized" $ do - S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" - `shouldBe` - Right ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6) - - S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6) - `shouldBe` - "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" - - it "properly serialized (iso)" $ property $ \ ip -> - S.decode (S.encode ip) `shouldBe` Right (ip :: IPv6) - - it "properly bencoded" $ do - BE.decode "3:::1" `shouldBe` Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) - BE.encode (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) `shouldBe` - "23:00:00:00:00:00:00:00:01" - - BE.decode "23:00:00:00:00:00:00:00:01" - `shouldBe` - Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) - - it "properly bencoded iso" $ property $ \ ip -> - BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4) - - it "fail gracefully on invalid strings" $ do - BE.decode "4:g::1" `shouldBe` - (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IPv6) - - it "fail gracefully on invalid bencode" $ do - BE.decode "i10e" `shouldBe` - (Left "fromBEncode: unable to decode IP: addr should be a bstring" - :: BE.Result IPv6) - - - describe "Peer IP" $ do - it "properly serialized IPv6" $ do - S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" - `shouldBe` - Right ("102:304:506:708:90a:b0c:d0e:f10" :: IP) - - S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IP) - `shouldBe` - "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" - - it "properly serialized (iso) IPv6" $ property $ \ ip -> - S.decode (S.encode ip) `shouldBe` Right (ip :: IP) - - it "properly serialized IPv4" $ do - S.decode "\x1\x2\x3\x4" `shouldBe` Right (IPv4 $ toIPv4 [1, 2, 3, 4]) - S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4" - - it "properly serialized (iso) IPv4" $ property $ \ ip -> do - S.decode (S.encode ip) `shouldBe` Right (ip :: IP) - - it "properly bencoded" $ do - BE.decode "11:168.192.0.1" `shouldBe` - Right (IPv4 (toIPv4 [168, 192, 0, 1])) - - BE.decode "3:::1" `shouldBe` Right - (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) - - BE.encode (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) `shouldBe` - "23:00:00:00:00:00:00:00:01" - - BE.decode "23:00:00:00:00:00:00:00:01" - `shouldBe` - Right (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) - - it "properly bencoded iso" $ property $ \ ip -> - BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IP) - - it "fail gracefully on invalid strings" $ do - BE.decode "4:g::1" `shouldBe` - (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IP) - - it "fail gracefully on invalid bencode" $ do - BE.decode "i10e" `shouldBe` - (Left "fromBEncode: unable to decode IP: addr should be a bstring" - :: BE.Result IP) - - describe "PeerAddr" $ do - it "IsString" $ do - ("127.0.0.1:80" :: PeerAddr IP) - `shouldBe` PeerAddr Nothing "127.0.0.1" 80 - - ("127.0.0.1:80" :: PeerAddr IPv4) - `shouldBe` PeerAddr Nothing "127.0.0.1" 80 - - ("[::1]:80" :: PeerAddr IP) - `shouldBe` PeerAddr Nothing "::1" 80 - - ("[::1]:80" :: PeerAddr IPv6) - `shouldBe` PeerAddr Nothing "::1" 80 - - it "properly bencoded (iso)" $ property $ \ addr -> - BE.decode (BL.toStrict (BE.encode addr)) - `shouldBe` Right (addr :: PeerAddr IP) - - - it "properly bencoded (ipv4)" $ do - BE.decode "d2:ip11:168.192.0.1\ - \7:peer id20:01234567890123456789\ - \4:porti6881e\ - \e" - `shouldBe` - Right (PeerAddr (Just "01234567890123456789") - (IPv4 (toIPv4 [168, 192, 0, 1])) - 6881) - - it "properly bencoded (ipv6)" $ do - BE.decode "d2:ip3:::1\ - \7:peer id20:01234567890123456789\ - \4:porti6881e\ - \e" - `shouldBe` - Right (PeerAddr (Just "01234567890123456789") - (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) - 6881) - - it "peer id is optional" $ do - BE.decode "d2:ip11:168.192.0.1\ - \4:porti6881e\ - \e" - `shouldBe` - Right (PeerAddr Nothing (IPv4 (toIPv4 [168, 192, 0, 1])) 6881) - - it "has sock addr for both ipv4 and ipv6" $ do - show (peerSockAddr "128.0.0.1:80") `shouldBe` "128.0.0.1:80" - show (peerSockAddr "[::1]:8080" ) `shouldBe` "[::1]:8080" diff --git a/tests/Network/BitTorrent/Core/PeerIdSpec.hs b/tests/Network/BitTorrent/Core/PeerIdSpec.hs deleted file mode 100644 index 29b98bbc..00000000 --- a/tests/Network/BitTorrent/Core/PeerIdSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Network.BitTorrent.Core.PeerIdSpec (spec) where -import Control.Applicative -import Data.BEncode as BE -import Data.Text.Encoding as T -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () -import Network.BitTorrent.Address - - -instance Arbitrary PeerId where - arbitrary = oneof - [ azureusStyle defaultClientId defaultVersionNumber - <$> (T.encodeUtf8 <$> arbitrary) - , shadowStyle 'X' defaultVersionNumber - <$> (T.encodeUtf8 <$> arbitrary) - ] - -spec :: Spec -spec = do - describe "PeerId" $ do - it "properly bencoded" $ do - BE.decode "20:01234567890123456789" - `shouldBe` Right ("01234567890123456789" :: PeerId) \ No newline at end of file diff --git a/tests/Network/BitTorrent/CoreSpec.hs b/tests/Network/BitTorrent/CoreSpec.hs index 1e1a21a1..5bf900b2 100644 --- a/tests/Network/BitTorrent/CoreSpec.hs +++ b/tests/Network/BitTorrent/CoreSpec.hs @@ -1,11 +1,305 @@ --- | Re-export modules. +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Network.BitTorrent.CoreSpec (spec) where -import Network.BitTorrent.Core.FingerprintSpec as CoreSpec () -import Network.BitTorrent.Core.PeerAddrSpec as CoreSpec () -import Network.BitTorrent.Core.NodeInfoSpec as CoreSpec () -import Network.BitTorrent.Core.PeerIdSpec as CoreSpec () +import Control.Applicative +import Data.BEncode as BE +import Data.ByteString.Lazy as BL +import Data.IP +import Data.Serialize as S +import Data.String +import Data.Text.Encoding as T +import Data.Word +import Network +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () -import Test.Hspec (Spec) +import Network.BitTorrent.Address + + +instance Arbitrary IPv4 where + arbitrary = do + a <- choose (0, 255) + b <- choose (0, 255) + c <- choose (0, 255) + d <- choose (0, 255) + return $ toIPv4 [a, b, c, d] + +instance Arbitrary IPv6 where + arbitrary = do + a <- choose (0, fromIntegral (maxBound :: Word16)) + b <- choose (0, fromIntegral (maxBound :: Word16)) + c <- choose (0, fromIntegral (maxBound :: Word16)) + d <- choose (0, fromIntegral (maxBound :: Word16)) + e <- choose (0, fromIntegral (maxBound :: Word16)) + f <- choose (0, fromIntegral (maxBound :: Word16)) + g <- choose (0, fromIntegral (maxBound :: Word16)) + h <- choose (0, fromIntegral (maxBound :: Word16)) + return $ toIPv6 [a, b, c, d, e, f, g, h] + +instance Arbitrary IP where + arbitrary = frequency + [ (1, IPv4 <$> arbitrary) + , (1, IPv6 <$> arbitrary) + ] + +instance Arbitrary PortNumber where + arbitrary = fromIntegral <$> (arbitrary :: Gen Word16) + +instance Arbitrary PeerId where + arbitrary = oneof + [ azureusStyle defaultClientId defaultVersionNumber + <$> (T.encodeUtf8 <$> arbitrary) + , shadowStyle 'X' defaultVersionNumber + <$> (T.encodeUtf8 <$> arbitrary) + ] + +instance Arbitrary a => Arbitrary (PeerAddr a) where + arbitrary = PeerAddr <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary NodeId where + arbitrary = fromString <$> vector 20 + +instance Arbitrary a => Arbitrary (NodeAddr a) where + arbitrary = NodeAddr <$> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary (NodeInfo a) where + arbitrary = NodeInfo <$> arbitrary <*> arbitrary spec :: Spec -spec = return () \ No newline at end of file +spec = do + describe "PeerId" $ do + it "properly bencoded" $ do + BE.decode "20:01234567890123456789" + `shouldBe` Right ("01234567890123456789" :: PeerId) + + describe "PortNumber" $ do + it "properly serialized" $ do + S.decode "\x1\x2" `shouldBe` Right (258 :: PortNumber) + S.encode (258 :: PortNumber) `shouldBe` "\x1\x2" + + it "properly bencoded" $ do + BE.decode "i80e" `shouldBe` Right (80 :: PortNumber) + + it "fail if port number is invalid" $ do + (BE.decode "i-10e" :: BE.Result PortNumber) + `shouldBe` + Left "fromBEncode: unable to decode PortNumber: -10" + + (BE.decode "i70000e" :: BE.Result PortNumber) + `shouldBe` + Left "fromBEncode: unable to decode PortNumber: 70000" + + describe "Peer IPv4" $ do + it "properly serialized" $ do + S.decode "\x1\x2\x3\x4" `shouldBe` Right (toIPv4 [1, 2, 3, 4]) + S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4" + + it "properly serialized (iso)" $ property $ \ ip -> do + S.decode (S.encode ip) `shouldBe` Right (ip :: IPv4) + + it "properly bencoded" $ do + BE.decode "11:168.192.0.1" `shouldBe` Right (toIPv4 [168, 192, 0, 1]) + BE.encode (toIPv4 [168, 192, 0, 1]) `shouldBe` "11:168.192.0.1" + + it "properly bencoded (iso)" $ property $ \ ip -> + BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4) + + it "fail gracefully on invalid strings" $ do + BE.decode "3:1.1" `shouldBe` + (Left "fromBEncode: unable to decode IP: 1.1" :: BE.Result IPv4) + + it "fail gracefully on invalid bencode" $ do + BE.decode "i10e" `shouldBe` + (Left "fromBEncode: unable to decode IP: addr should be a bstring" + :: BE.Result IPv4) + + describe "Peer IPv6" $ do + it "properly serialized" $ do + S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" + `shouldBe` + Right ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6) + + S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6) + `shouldBe` + "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" + + it "properly serialized (iso)" $ property $ \ ip -> + S.decode (S.encode ip) `shouldBe` Right (ip :: IPv6) + + it "properly bencoded" $ do + BE.decode "3:::1" `shouldBe` Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) + BE.encode (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) `shouldBe` + "23:00:00:00:00:00:00:00:01" + + BE.decode "23:00:00:00:00:00:00:00:01" + `shouldBe` + Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) + + it "properly bencoded iso" $ property $ \ ip -> + BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4) + + it "fail gracefully on invalid strings" $ do + BE.decode "4:g::1" `shouldBe` + (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IPv6) + + it "fail gracefully on invalid bencode" $ do + BE.decode "i10e" `shouldBe` + (Left "fromBEncode: unable to decode IP: addr should be a bstring" + :: BE.Result IPv6) + + + describe "Peer IP" $ do + it "properly serialized IPv6" $ do + S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" + `shouldBe` + Right ("102:304:506:708:90a:b0c:d0e:f10" :: IP) + + S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IP) + `shouldBe` + "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10" + + it "properly serialized (iso) IPv6" $ property $ \ ip -> + S.decode (S.encode ip) `shouldBe` Right (ip :: IP) + + it "properly serialized IPv4" $ do + S.decode "\x1\x2\x3\x4" `shouldBe` Right (IPv4 $ toIPv4 [1, 2, 3, 4]) + S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4" + + it "properly serialized (iso) IPv4" $ property $ \ ip -> do + S.decode (S.encode ip) `shouldBe` Right (ip :: IP) + + it "properly bencoded" $ do + BE.decode "11:168.192.0.1" `shouldBe` + Right (IPv4 (toIPv4 [168, 192, 0, 1])) + + BE.decode "3:::1" `shouldBe` Right + (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) + + BE.encode (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) `shouldBe` + "23:00:00:00:00:00:00:00:01" + + BE.decode "23:00:00:00:00:00:00:00:01" + `shouldBe` + Right (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) + + it "properly bencoded iso" $ property $ \ ip -> + BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IP) + + it "fail gracefully on invalid strings" $ do + BE.decode "4:g::1" `shouldBe` + (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IP) + + it "fail gracefully on invalid bencode" $ do + BE.decode "i10e" `shouldBe` + (Left "fromBEncode: unable to decode IP: addr should be a bstring" + :: BE.Result IP) + + describe "PeerAddr" $ do + it "IsString" $ do + ("127.0.0.1:80" :: PeerAddr IP) + `shouldBe` PeerAddr Nothing "127.0.0.1" 80 + + ("127.0.0.1:80" :: PeerAddr IPv4) + `shouldBe` PeerAddr Nothing "127.0.0.1" 80 + + ("[::1]:80" :: PeerAddr IP) + `shouldBe` PeerAddr Nothing "::1" 80 + + ("[::1]:80" :: PeerAddr IPv6) + `shouldBe` PeerAddr Nothing "::1" 80 + + it "properly bencoded (iso)" $ property $ \ addr -> + BE.decode (BL.toStrict (BE.encode addr)) + `shouldBe` Right (addr :: PeerAddr IP) + + + it "properly bencoded (ipv4)" $ do + BE.decode "d2:ip11:168.192.0.1\ + \7:peer id20:01234567890123456789\ + \4:porti6881e\ + \e" + `shouldBe` + Right (PeerAddr (Just "01234567890123456789") + (IPv4 (toIPv4 [168, 192, 0, 1])) + 6881) + + it "properly bencoded (ipv6)" $ do + BE.decode "d2:ip3:::1\ + \7:peer id20:01234567890123456789\ + \4:porti6881e\ + \e" + `shouldBe` + Right (PeerAddr (Just "01234567890123456789") + (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) + 6881) + + it "peer id is optional" $ do + BE.decode "d2:ip11:168.192.0.1\ + \4:porti6881e\ + \e" + `shouldBe` + Right (PeerAddr Nothing (IPv4 (toIPv4 [168, 192, 0, 1])) 6881) + + it "has sock addr for both ipv4 and ipv6" $ do + show (peerSockAddr "128.0.0.1:80") `shouldBe` "128.0.0.1:80" + show (peerSockAddr "[::1]:8080" ) `shouldBe` "[::1]:8080" + + describe "NodeId" $ do + it "properly serialized" $ do + S.decode "mnopqrstuvwxyz123456" + `shouldBe` Right ("mnopqrstuvwxyz123456" :: NodeId) + + S.encode ("mnopqrstuvwxyz123456" :: NodeId) + `shouldBe` "mnopqrstuvwxyz123456" + + it "properly serialized (iso)" $ property $ \ nid -> + S.decode (S.encode nid) `shouldBe` + Right (nid :: NodeId) + + describe "NodeAddr" $ do + it "properly serialized" $ do + S.decode "\127\0\0\1\1\2" `shouldBe` + Right ("127.0.0.1:258" :: NodeAddr IPv4) + + it "properly serialized (iso)" $ property $ \ nid -> + S.decode (S.encode nid) `shouldBe` + Right (nid :: NodeAddr IPv4) + + describe "NodeInfo" $ do + it "properly serialized" $ do + S.decode "mnopqrstuvwxyz123456\ + \\127\0\0\1\1\2" `shouldBe` Right + (NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258" :: NodeInfo IPv4) + + it "properly serialized (iso)" $ property $ \ nid -> + S.decode (S.encode nid) `shouldBe` + Right (nid :: NodeInfo IPv4) + + -- see + describe "Fingerprint" $ do + it "decode mainline encoded peer id" $ do + fingerprint "M4-3-6--xxxxxxxxxxxx" `shouldBe` "Mainline-4.3.6" + fingerprint "M4-20-8-xxxxxxxxxxxx" `shouldBe` "Mainline-4.20.8" + + it "decode azureus encoded peer id" $ do + fingerprint "-AZ2060-xxxxxxxxxxxx" `shouldBe` "Azureus-2060" + fingerprint "-BS0000-xxxxxxxxxxxx" `shouldBe` "BTSlave-0" + + it "decode Shad0w style peer id" $ do + fingerprint "S58B-----xxxxxxxxxxx" `shouldBe` "Shadow-5.8.11" + fingerprint "T58B-----xxxxxxxxxxx" `shouldBe` "BitTornado-5.8.11" + + it "decode bitcomet style peer id" $ do + fingerprint "exbc01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49" + fingerprint "FUTB01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49" + fingerprint "exbc01LORDxxxxxxxxxx" `shouldBe` "BitLord-48.49" + + it "decode opera style peer id" $ do + fingerprint "OP0123xxxxxxxxxxxxxx" `shouldBe` "Opera-123" + + it "decode ML donkey style peer id" $ do + fingerprint "-ML2.7.2-xxxxxxxxxxx" `shouldBe` "MLdonkey-0" + +-- TODO XBT, Bits on Wheels, Queen Bee, BitTyrant, TorrenTopia, +-- BitSpirit, Rufus, G3 Torrent, FlashGet \ No newline at end of file -- cgit v1.2.3 From 3867719780293528e604452818b9d9a616938783 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 8 Apr 2014 03:56:29 +0400 Subject: Move bitfield to exchange subsystem --- bittorrent.cabal | 4 +- src/Data/Torrent/Bitfield.hs | 324 ---------------------- src/Network/BitTorrent/Exchange/Bitfield.hs | 324 ++++++++++++++++++++++ src/Network/BitTorrent/Exchange/Connection.hs | 4 +- src/Network/BitTorrent/Exchange/Message.hs | 2 +- src/Network/BitTorrent/Exchange/Selection.hs | 2 +- src/Network/BitTorrent/Exchange/Session.hs | 2 +- src/Network/BitTorrent/Exchange/Session/Status.hs | 2 +- src/System/Torrent/Storage.hs | 2 +- tests/Data/Torrent/BitfieldSpec.hs | 13 - tests/Network/BitTorrent/Exchange/BitfieldSpec.hs | 13 + tests/Network/BitTorrent/Exchange/MessageSpec.hs | 2 +- tests/System/Torrent/StorageSpec.hs | 2 +- 13 files changed, 348 insertions(+), 348 deletions(-) delete mode 100644 src/Data/Torrent/Bitfield.hs create mode 100644 src/Network/BitTorrent/Exchange/Bitfield.hs delete mode 100644 tests/Data/Torrent/BitfieldSpec.hs create mode 100644 tests/Network/BitTorrent/Exchange/BitfieldSpec.hs (limited to 'tests/Network') diff --git a/bittorrent.cabal b/bittorrent.cabal index 6df074bb..cd4c5d38 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -45,7 +45,6 @@ library , RecordWildCards hs-source-dirs: src exposed-modules: Data.Torrent - Data.Torrent.Bitfield Data.Torrent.Progress Data.Torrent.Tree Network.BitTorrent @@ -62,6 +61,7 @@ library Network.BitTorrent.DHT.Token Network.BitTorrent.Exchange Network.BitTorrent.Exchange.Assembler + Network.BitTorrent.Exchange.Bitfield Network.BitTorrent.Exchange.Block Network.BitTorrent.Exchange.Connection Network.BitTorrent.Exchange.Manager @@ -173,7 +173,6 @@ test-suite spec Config Data.TorrentSpec - Data.Torrent.BitfieldSpec Data.Torrent.ProgressSpec Network.BitTorrent.Client.HandleSpec Network.BitTorrent.CoreSpec @@ -192,6 +191,7 @@ test-suite spec Network.BitTorrent.Tracker.RPC.HTTPSpec Network.BitTorrent.Tracker.RPC.UDPSpec Network.BitTorrent.Tracker.SessionSpec + Network.BitTorrent.Exchange.BitfieldSpec Network.BitTorrent.Exchange.ConnectionSpec Network.BitTorrent.Exchange.MessageSpec Network.BitTorrent.Exchange.SessionSpec diff --git a/src/Data/Torrent/Bitfield.hs b/src/Data/Torrent/Bitfield.hs deleted file mode 100644 index ff701d75..00000000 --- a/src/Data/Torrent/Bitfield.hs +++ /dev/null @@ -1,324 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- 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 - ( -- * Bitfield - PieceIx - , PieceCount - , Bitfield - - -- * Construction - , haveAll - , haveNone - , have - , singleton - , interval - , adjustSize - - -- * Query - -- ** Cardinality - , Data.Torrent.Bitfield.null - , Data.Torrent.Bitfield.full - , haveCount - , totalCount - , completeness - - -- ** Membership - , member - , notMember - , findMin - , findMax - , isSubsetOf - - -- ** Availability - , complement - , Frequency - , frequencies - , rarest - - -- * Combine - , insert - , union - , intersection - , difference - - -- * Conversion - , toList - , fromList - - -- * Serialization - , fromBitmap - , toBitmap - ) 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 - -import Data.Torrent - --- 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 - --- | Test if bitfield have all pieces. -full :: Bitfield -> Bool -full Bitfield {..} = S.size bfSet == bfSize - --- | 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 #-} - --- | Check if all pieces from first bitfield present if the second bitfield -isSubsetOf :: Bitfield -> Bitfield -> Bool -isSubsetOf a b = bfSet a `S.isSubsetOf` bfSet b -{-# INLINE isSubsetOf #-} - --- | Resulting bitfield includes only missing pieces. -complement :: Bitfield -> Bitfield -complement Bitfield {..} = Bitfield - { bfSet = uni `S.difference` bfSet - , bfSize = bfSize - } - where - Bitfield _ uni = haveAll bfSize -{-# INLINE complement #-} - -{----------------------------------------------------------------------- --- Availability ------------------------------------------------------------------------} - --- | Frequencies are needed in piece selection startegies which use --- availability quantity to find out the optimal next piece index to --- download. -type Frequency = Int - --- TODO rename to availability --- | 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 ------------------------------------------------------------------------} - -insert :: PieceIx -> Bitfield -> Bitfield -insert pix bf @ Bitfield {..} - | 0 <= pix && pix < bfSize = Bitfield - { bfSet = S.insert pix bfSet - , bfSize = bfSize - } - | otherwise = bf - --- | 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 - --- | Make bitfield from list of /have/ indexes. -fromList :: PieceCount -> [PieceIx] -> Bitfield -fromList s ixs = Bitfield { - bfSize = s - , bfSet = S.splitGT (-1) $ S.splitLT s $ S.fromList ixs - } - --- | 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 diff --git a/src/Network/BitTorrent/Exchange/Bitfield.hs b/src/Network/BitTorrent/Exchange/Bitfield.hs new file mode 100644 index 00000000..3f4931f3 --- /dev/null +++ b/src/Network/BitTorrent/Exchange/Bitfield.hs @@ -0,0 +1,324 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- 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 Network.BitTorrent.Exchange.Bitfield + ( -- * Bitfield + PieceIx + , PieceCount + , Bitfield + + -- * Construction + , haveAll + , haveNone + , have + , singleton + , interval + , adjustSize + + -- * Query + -- ** Cardinality + , Network.BitTorrent.Exchange.Bitfield.null + , Network.BitTorrent.Exchange.Bitfield.full + , haveCount + , totalCount + , completeness + + -- ** Membership + , member + , notMember + , findMin + , findMax + , isSubsetOf + + -- ** Availability + , complement + , Frequency + , frequencies + , rarest + + -- * Combine + , insert + , union + , intersection + , difference + + -- * Conversion + , toList + , fromList + + -- * Serialization + , fromBitmap + , toBitmap + ) 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 + +import Data.Torrent + +-- 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 + +-- | Test if bitfield have all pieces. +full :: Bitfield -> Bool +full Bitfield {..} = S.size bfSet == bfSize + +-- | 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 #-} + +-- | Check if all pieces from first bitfield present if the second bitfield +isSubsetOf :: Bitfield -> Bitfield -> Bool +isSubsetOf a b = bfSet a `S.isSubsetOf` bfSet b +{-# INLINE isSubsetOf #-} + +-- | Resulting bitfield includes only missing pieces. +complement :: Bitfield -> Bitfield +complement Bitfield {..} = Bitfield + { bfSet = uni `S.difference` bfSet + , bfSize = bfSize + } + where + Bitfield _ uni = haveAll bfSize +{-# INLINE complement #-} + +{----------------------------------------------------------------------- +-- Availability +-----------------------------------------------------------------------} + +-- | Frequencies are needed in piece selection startegies which use +-- availability quantity to find out the optimal next piece index to +-- download. +type Frequency = Int + +-- TODO rename to availability +-- | 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 +-----------------------------------------------------------------------} + +insert :: PieceIx -> Bitfield -> Bitfield +insert pix bf @ Bitfield {..} + | 0 <= pix && pix < bfSize = Bitfield + { bfSet = S.insert pix bfSet + , bfSize = bfSize + } + | otherwise = bf + +-- | 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 + +-- | Make bitfield from list of /have/ indexes. +fromList :: PieceCount -> [PieceIx] -> Bitfield +fromList s ixs = Bitfield { + bfSize = s + , bfSet = S.splitGT (-1) $ S.splitLT s $ S.fromList ixs + } + +-- | 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 diff --git a/src/Network/BitTorrent/Exchange/Connection.hs b/src/Network/BitTorrent/Exchange/Connection.hs index 9b7942ae..f208fa54 100644 --- a/src/Network/BitTorrent/Exchange/Connection.hs +++ b/src/Network/BitTorrent/Exchange/Connection.hs @@ -135,10 +135,10 @@ import Text.Show.Functions () import System.Log.FastLogger (ToLogStr(..)) import System.Timeout -import Data.Torrent.Bitfield as BF import Data.Torrent import Network.BitTorrent.Address -import Network.BitTorrent.Exchange.Message as Msg +import Network.BitTorrent.Exchange.Bitfield as BF +import Network.BitTorrent.Exchange.Message as Msg -- TODO handle port message? -- TODO handle limits? diff --git a/src/Network/BitTorrent/Exchange/Message.hs b/src/Network/BitTorrent/Exchange/Message.hs index a0cb5c91..f8b76186 100644 --- a/src/Network/BitTorrent/Exchange/Message.hs +++ b/src/Network/BitTorrent/Exchange/Message.hs @@ -117,10 +117,10 @@ import Network.Socket hiding (KeepAlive) import Text.PrettyPrint as PP hiding ((<>)) import Text.PrettyPrint.Class -import Data.Torrent.Bitfield import Data.Torrent hiding (Piece (..)) import qualified Data.Torrent as P (Piece (..)) import Network.BitTorrent.Address +import Network.BitTorrent.Exchange.Bitfield import Network.BitTorrent.Exchange.Block {----------------------------------------------------------------------- diff --git a/src/Network/BitTorrent/Exchange/Selection.hs b/src/Network/BitTorrent/Exchange/Selection.hs index 2724fabc..3701450b 100644 --- a/src/Network/BitTorrent/Exchange/Selection.hs +++ b/src/Network/BitTorrent/Exchange/Selection.hs @@ -22,7 +22,7 @@ module Network.BitTorrent.Exchange.Selection import Data.Ratio -import Data.Torrent.Bitfield +import Network.BitTorrent.Exchange.Bitfield type Selector = Bitfield -- ^ Indices of client /have/ pieces. diff --git a/src/Network/BitTorrent/Exchange/Session.hs b/src/Network/BitTorrent/Exchange/Session.hs index b68f17a0..4c6811d9 100644 --- a/src/Network/BitTorrent/Exchange/Session.hs +++ b/src/Network/BitTorrent/Exchange/Session.hs @@ -46,9 +46,9 @@ import System.Log.FastLogger (LogStr, ToLogStr (..)) import Data.BEncode as BE import Data.Torrent as Torrent -import Data.Torrent.Bitfield as BF import Network.BitTorrent.Internal.Types import Network.BitTorrent.Address +import Network.BitTorrent.Exchange.Bitfield as BF import Network.BitTorrent.Exchange.Block as Block import Network.BitTorrent.Exchange.Connection import Network.BitTorrent.Exchange.Message as Message diff --git a/src/Network/BitTorrent/Exchange/Session/Status.hs b/src/Network/BitTorrent/Exchange/Session/Status.hs index 63b91926..af3e94f5 100644 --- a/src/Network/BitTorrent/Exchange/Session/Status.hs +++ b/src/Network/BitTorrent/Exchange/Session/Status.hs @@ -29,7 +29,7 @@ import Data.Set as S import Data.Tuple import Data.Torrent -import Data.Torrent.Bitfield as BF +import Network.BitTorrent.Exchange.Bitfield as BF import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Block as Block import System.Torrent.Storage (Storage, writePiece) diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs index 1123cea9..1d77e55d 100644 --- a/src/System/Torrent/Storage.hs +++ b/src/System/Torrent/Storage.hs @@ -56,7 +56,7 @@ import Data.Conduit.List as C import Data.Typeable import Data.Torrent -import Data.Torrent.Bitfield as BF +import Network.BitTorrent.Exchange.Bitfield as BF import System.Torrent.FileMap as FM diff --git a/tests/Data/Torrent/BitfieldSpec.hs b/tests/Data/Torrent/BitfieldSpec.hs deleted file mode 100644 index 093f6f19..00000000 --- a/tests/Data/Torrent/BitfieldSpec.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent.BitfieldSpec (spec) where -import Control.Applicative -import Test.Hspec -import Test.QuickCheck - -import Data.Torrent.Bitfield - -instance Arbitrary Bitfield where - arbitrary = fromBitmap <$> arbitrary - -spec :: Spec -spec = return () \ No newline at end of file diff --git a/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs b/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs new file mode 100644 index 00000000..234965fa --- /dev/null +++ b/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Network.BitTorrent.Exchange.BitfieldSpec (spec) where +import Control.Applicative +import Test.Hspec +import Test.QuickCheck + +import Network.BitTorrent.Exchange.Bitfield + +instance Arbitrary Bitfield where + arbitrary = fromBitmap <$> arbitrary + +spec :: Spec +spec = return () \ No newline at end of file diff --git a/tests/Network/BitTorrent/Exchange/MessageSpec.hs b/tests/Network/BitTorrent/Exchange/MessageSpec.hs index f82b034e..d615b1ff 100644 --- a/tests/Network/BitTorrent/Exchange/MessageSpec.hs +++ b/tests/Network/BitTorrent/Exchange/MessageSpec.hs @@ -11,7 +11,7 @@ import Test.Hspec import Test.QuickCheck import Data.TorrentSpec () -import Data.Torrent.BitfieldSpec () +import Network.BitTorrent.Exchange.BitfieldSpec () import Network.BitTorrent.CoreSpec () import Network.BitTorrent.Address () import Network.BitTorrent.Exchange.BlockSpec () diff --git a/tests/System/Torrent/StorageSpec.hs b/tests/System/Torrent/StorageSpec.hs index 96f1b036..b5e49078 100644 --- a/tests/System/Torrent/StorageSpec.hs +++ b/tests/System/Torrent/StorageSpec.hs @@ -8,7 +8,7 @@ import System.IO.Unsafe import Test.Hspec import Data.Torrent -import Data.Torrent.Bitfield as BF +import Network.BitTorrent.Exchange.Bitfield as BF import System.Torrent.Storage -- cgit v1.2.3 From 9c7227c5c0cac81351684ccfa2f49d6b97bedf03 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 8 Apr 2014 05:37:34 +0400 Subject: Hide progress module --- bittorrent.cabal | 6 +- src/Data/Torrent/Progress.hs | 155 ---------------------- src/Network/BitTorrent/Internal/Progress.hs | 154 +++++++++++++++++++++ src/Network/BitTorrent/Tracker/Message.hs | 3 +- src/Network/BitTorrent/Tracker/RPC.hs | 2 +- tests/Data/Torrent/ProgressSpec.hs | 13 -- tests/Network/BitTorrent/Internal/ProgressSpec.hs | 13 ++ tests/Network/BitTorrent/Tracker/MessageSpec.hs | 2 +- tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs | 2 +- 9 files changed, 175 insertions(+), 175 deletions(-) delete mode 100644 src/Data/Torrent/Progress.hs create mode 100644 src/Network/BitTorrent/Internal/Progress.hs delete mode 100644 tests/Data/Torrent/ProgressSpec.hs create mode 100644 tests/Network/BitTorrent/Internal/ProgressSpec.hs (limited to 'tests/Network') diff --git a/bittorrent.cabal b/bittorrent.cabal index 0ceec550..d8cf0a01 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -49,7 +49,7 @@ library , RecordWildCards hs-source-dirs: src exposed-modules: Data.Torrent - Data.Torrent.Progress + Network.BitTorrent Network.BitTorrent.Address Network.BitTorrent.Client @@ -84,12 +84,14 @@ library if flag(testing) exposed-modules: Network.BitTorrent.Internal.Cache + Network.BitTorrent.Internal.Progress Network.BitTorrent.Internal.Types System.Torrent.FileMap System.Torrent.Tree else other-modules: Network.BitTorrent.Internal.Cache + Network.BitTorrent.Internal.Progress Network.BitTorrent.Internal.Types System.Torrent.FileMap System.Torrent.Tree @@ -185,7 +187,6 @@ test-suite spec Config Data.TorrentSpec - Data.Torrent.ProgressSpec Network.BitTorrent.Client.HandleSpec Network.BitTorrent.CoreSpec Network.BitTorrent.DHTSpec @@ -196,6 +197,7 @@ test-suite spec Network.BitTorrent.DHT.SessionSpec Network.BitTorrent.DHT.TokenSpec Network.BitTorrent.Internal.CacheSpec + Network.BitTorrent.Internal.ProgressSpec Network.BitTorrent.Tracker.TestData Network.BitTorrent.Tracker.ListSpec Network.BitTorrent.Tracker.MessageSpec diff --git a/src/Data/Torrent/Progress.hs b/src/Data/Torrent/Progress.hs deleted file mode 100644 index 4719020a..00000000 --- a/src/Data/Torrent/Progress.hs +++ /dev/null @@ -1,155 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- 'Progress' used to track amount downloaded\/left\/upload bytes --- either on per client or per torrent basis. This value is used to --- notify the tracker and usually shown to the user. To aggregate --- total progress you can use the Monoid instance. --- -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent.Progress - ( -- * Progress - Progress (..) - - -- * Lens - , left - , uploaded - , downloaded - - -- * Construction - , startProgress - , downloadedProgress - , enqueuedProgress - , uploadedProgress - , dequeuedProgress - - -- * Query - , canDownload - , canUpload - ) where - -import Control.Applicative -import Control.Lens hiding ((%=)) -import Data.ByteString.Lazy.Builder as BS -import Data.ByteString.Lazy.Builder.ASCII as BS -import Data.Default -import Data.List as L -import Data.Monoid -import Data.Serialize as S -import Data.Ratio -import Data.Word -import Network.HTTP.Types.QueryLike -import Text.PrettyPrint as PP -import Text.PrettyPrint.Class - - --- | Progress data is considered as dynamic within one client --- session. This data also should be shared across client application --- sessions (e.g. files), otherwise use 'startProgress' to get initial --- 'Progress' value. --- -data Progress = Progress - { _downloaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes downloaded; - , _left :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes left; - , _uploaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes uploaded. - } deriving (Show, Read, Eq) - -$(makeLenses ''Progress) - --- | UDP tracker compatible encoding. -instance Serialize Progress where - put Progress {..} = do - putWord64be $ fromIntegral _downloaded - putWord64be $ fromIntegral _left - putWord64be $ fromIntegral _uploaded - - get = Progress - <$> (fromIntegral <$> getWord64be) - <*> (fromIntegral <$> getWord64be) - <*> (fromIntegral <$> getWord64be) - -instance Default Progress where - def = Progress 0 0 0 - {-# INLINE def #-} - --- | Can be used to aggregate total progress. -instance Monoid Progress where - mempty = def - {-# INLINE mempty #-} - - mappend (Progress da la ua) (Progress db lb ub) = Progress - { _downloaded = da + db - , _left = la + lb - , _uploaded = ua + ub - } - {-# INLINE mappend #-} - -instance QueryValueLike Builder where - toQueryValue = toQueryValue . BS.toLazyByteString - -instance QueryValueLike Word64 where - toQueryValue = toQueryValue . BS.word64Dec - --- | HTTP Tracker protocol compatible encoding. -instance QueryLike Progress where - toQuery Progress {..} = - [ ("uploaded" , toQueryValue _uploaded) - , ("left" , toQueryValue _left) - , ("downloaded", toQueryValue _downloaded) - ] - -instance Pretty Progress where - pretty Progress {..} = - "/\\" <+> PP.text (show _uploaded) $$ - "\\/" <+> PP.text (show _downloaded) $$ - "left" <+> PP.text (show _left) - --- | Initial progress is used when there are no session before. --- --- Please note that tracker might penalize client some way if the do --- not accumulate progress. If possible and save 'Progress' between --- client sessions to avoid that. --- -startProgress :: Integer -> Progress -startProgress = Progress 0 0 . fromIntegral -{-# INLINE startProgress #-} - --- | Used when the client download some data from /any/ peer. -downloadedProgress :: Int -> Progress -> Progress -downloadedProgress (fromIntegral -> amount) - = (left -~ amount) - . (downloaded +~ amount) -{-# INLINE downloadedProgress #-} - --- | Used when the client upload some data to /any/ peer. -uploadedProgress :: Int -> Progress -> Progress -uploadedProgress (fromIntegral -> amount) = uploaded +~ amount -{-# INLINE uploadedProgress #-} - --- | Used when leecher join client session. -enqueuedProgress :: Integer -> Progress -> Progress -enqueuedProgress amount = left +~ fromIntegral amount -{-# INLINE enqueuedProgress #-} - --- | Used when leecher leave client session. --- (e.g. user deletes not completed torrent) -dequeuedProgress :: Integer -> Progress -> Progress -dequeuedProgress amount = left -~ fromIntegral amount -{-# INLINE dequeuedProgress #-} - -ri2rw64 :: Ratio Int -> Ratio Word64 -ri2rw64 x = fromIntegral (numerator x) % fromIntegral (denominator x) - --- | Check global /download/ limit by uploaded \/ downloaded ratio. -canDownload :: Ratio Int -> Progress -> Bool -canDownload limit Progress {..} = _uploaded % _downloaded > ri2rw64 limit - --- | Check global /upload/ limit by downloaded \/ uploaded ratio. -canUpload :: Ratio Int -> Progress -> Bool -canUpload limit Progress {..} = _downloaded % _uploaded > ri2rw64 limit diff --git a/src/Network/BitTorrent/Internal/Progress.hs b/src/Network/BitTorrent/Internal/Progress.hs new file mode 100644 index 00000000..9aff9935 --- /dev/null +++ b/src/Network/BitTorrent/Internal/Progress.hs @@ -0,0 +1,154 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- 'Progress' used to track amount downloaded\/left\/upload bytes +-- either on per client or per torrent basis. This value is used to +-- notify the tracker and usually shown to the user. To aggregate +-- total progress you can use the Monoid instance. +-- +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS -fno-warn-orphans #-} +module Network.BitTorrent.Internal.Progress + ( -- * Progress + Progress (..) + + -- * Lens + , left + , uploaded + , downloaded + + -- * Construction + , startProgress + , downloadedProgress + , enqueuedProgress + , uploadedProgress + , dequeuedProgress + + -- * Query + , canDownload + , canUpload + ) where + +import Control.Applicative +import Control.Lens hiding ((%=)) +import Data.ByteString.Lazy.Builder as BS +import Data.ByteString.Lazy.Builder.ASCII as BS +import Data.Default +import Data.Monoid +import Data.Serialize as S +import Data.Ratio +import Data.Word +import Network.HTTP.Types.QueryLike +import Text.PrettyPrint as PP +import Text.PrettyPrint.Class + + +-- | Progress data is considered as dynamic within one client +-- session. This data also should be shared across client application +-- sessions (e.g. files), otherwise use 'startProgress' to get initial +-- 'Progress' value. +-- +data Progress = Progress + { _downloaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes downloaded; + , _left :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes left; + , _uploaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes uploaded. + } deriving (Show, Read, Eq) + +$(makeLenses ''Progress) + +-- | UDP tracker compatible encoding. +instance Serialize Progress where + put Progress {..} = do + putWord64be $ fromIntegral _downloaded + putWord64be $ fromIntegral _left + putWord64be $ fromIntegral _uploaded + + get = Progress + <$> (fromIntegral <$> getWord64be) + <*> (fromIntegral <$> getWord64be) + <*> (fromIntegral <$> getWord64be) + +instance Default Progress where + def = Progress 0 0 0 + {-# INLINE def #-} + +-- | Can be used to aggregate total progress. +instance Monoid Progress where + mempty = def + {-# INLINE mempty #-} + + mappend (Progress da la ua) (Progress db lb ub) = Progress + { _downloaded = da + db + , _left = la + lb + , _uploaded = ua + ub + } + {-# INLINE mappend #-} + +instance QueryValueLike Builder where + toQueryValue = toQueryValue . BS.toLazyByteString + +instance QueryValueLike Word64 where + toQueryValue = toQueryValue . BS.word64Dec + +-- | HTTP Tracker protocol compatible encoding. +instance QueryLike Progress where + toQuery Progress {..} = + [ ("uploaded" , toQueryValue _uploaded) + , ("left" , toQueryValue _left) + , ("downloaded", toQueryValue _downloaded) + ] + +instance Pretty Progress where + pretty Progress {..} = + "/\\" <+> PP.text (show _uploaded) $$ + "\\/" <+> PP.text (show _downloaded) $$ + "left" <+> PP.text (show _left) + +-- | Initial progress is used when there are no session before. +-- +-- Please note that tracker might penalize client some way if the do +-- not accumulate progress. If possible and save 'Progress' between +-- client sessions to avoid that. +-- +startProgress :: Integer -> Progress +startProgress = Progress 0 0 . fromIntegral +{-# INLINE startProgress #-} + +-- | Used when the client download some data from /any/ peer. +downloadedProgress :: Int -> Progress -> Progress +downloadedProgress (fromIntegral -> amount) + = (left -~ amount) + . (downloaded +~ amount) +{-# INLINE downloadedProgress #-} + +-- | Used when the client upload some data to /any/ peer. +uploadedProgress :: Int -> Progress -> Progress +uploadedProgress (fromIntegral -> amount) = uploaded +~ amount +{-# INLINE uploadedProgress #-} + +-- | Used when leecher join client session. +enqueuedProgress :: Integer -> Progress -> Progress +enqueuedProgress amount = left +~ fromIntegral amount +{-# INLINE enqueuedProgress #-} + +-- | Used when leecher leave client session. +-- (e.g. user deletes not completed torrent) +dequeuedProgress :: Integer -> Progress -> Progress +dequeuedProgress amount = left -~ fromIntegral amount +{-# INLINE dequeuedProgress #-} + +ri2rw64 :: Ratio Int -> Ratio Word64 +ri2rw64 x = fromIntegral (numerator x) % fromIntegral (denominator x) + +-- | Check global /download/ limit by uploaded \/ downloaded ratio. +canDownload :: Ratio Int -> Progress -> Bool +canDownload limit Progress {..} = _uploaded % _downloaded > ri2rw64 limit + +-- | Check global /upload/ limit by downloaded \/ uploaded ratio. +canUpload :: Ratio Int -> Progress -> Bool +canUpload limit Progress {..} = _downloaded % _uploaded > ri2rw64 limit diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs index d251d0ad..e4a41045 100644 --- a/src/Network/BitTorrent/Tracker/Message.hs +++ b/src/Network/BitTorrent/Tracker/Message.hs @@ -125,9 +125,8 @@ import System.Entropy import Text.Read (readMaybe) import Data.Torrent -import Data.Torrent.Progress import Network.BitTorrent.Address - +import Network.BitTorrent.Internal.Progress {----------------------------------------------------------------------- -- Events diff --git a/src/Network/BitTorrent/Tracker/RPC.hs b/src/Network/BitTorrent/Tracker/RPC.hs index ecb1001c..6fd22b25 100644 --- a/src/Network/BitTorrent/Tracker/RPC.hs +++ b/src/Network/BitTorrent/Tracker/RPC.hs @@ -37,8 +37,8 @@ import Network.URI import Network.Socket (HostAddress) import Data.Torrent -import Data.Torrent.Progress import Network.BitTorrent.Address +import Network.BitTorrent.Internal.Progress import Network.BitTorrent.Tracker.Message import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP import qualified Network.BitTorrent.Tracker.RPC.UDP as UDP diff --git a/tests/Data/Torrent/ProgressSpec.hs b/tests/Data/Torrent/ProgressSpec.hs deleted file mode 100644 index 32efbd7a..00000000 --- a/tests/Data/Torrent/ProgressSpec.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent.ProgressSpec (spec) where -import Control.Applicative -import Test.Hspec -import Test.QuickCheck -import Data.Torrent.Progress - - -instance Arbitrary Progress where - arbitrary = Progress <$> arbitrary <*> arbitrary <*> arbitrary - -spec :: Spec -spec = return () diff --git a/tests/Network/BitTorrent/Internal/ProgressSpec.hs b/tests/Network/BitTorrent/Internal/ProgressSpec.hs new file mode 100644 index 00000000..acbfd84c --- /dev/null +++ b/tests/Network/BitTorrent/Internal/ProgressSpec.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Network.BitTorrent.Internal.ProgressSpec (spec) where +import Control.Applicative +import Test.Hspec +import Test.QuickCheck +import Network.BitTorrent.Internal.Progress + + +instance Arbitrary Progress where + arbitrary = Progress <$> arbitrary <*> arbitrary <*> arbitrary + +spec :: Spec +spec = return () diff --git a/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/tests/Network/BitTorrent/Tracker/MessageSpec.hs index 92fd8d79..29854d58 100644 --- a/tests/Network/BitTorrent/Tracker/MessageSpec.hs +++ b/tests/Network/BitTorrent/Tracker/MessageSpec.hs @@ -17,7 +17,7 @@ import Test.Hspec import Test.QuickCheck import Data.TorrentSpec () -import Data.Torrent.ProgressSpec () +import Network.BitTorrent.Internal.ProgressSpec () import Network.BitTorrent.Address () import Network.BitTorrent.Address () diff --git a/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs b/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs index 65f58911..e928f917 100644 --- a/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs +++ b/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs @@ -5,7 +5,7 @@ import Data.Default import Data.List as L import Test.Hspec -import Data.Torrent.Progress +import Network.BitTorrent.Internal.Progress import Network.BitTorrent.Tracker.Message as Message import Network.BitTorrent.Tracker.RPC.HTTP -- cgit v1.2.3 From cb75f50f4cae778d1dfc57edff771a5145dd9894 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Apr 2014 15:27:43 +0400 Subject: [Exchange] Move all download stuff to single module --- bittorrent.cabal | 6 +- src/Network/BitTorrent/Exchange/Assembler.hs | 168 --------- src/Network/BitTorrent/Exchange/Download.hs | 376 ++++++++++++++------- src/Network/BitTorrent/Exchange/Session.hs | 17 +- .../BitTorrent/Exchange/Session/Metadata.hs | 102 ------ tests/Network/BitTorrent/Exchange/DownloadSpec.hs | 71 ++++ .../BitTorrent/Exchange/Session/MetadataSpec.hs | 70 ---- 7 files changed, 330 insertions(+), 480 deletions(-) delete mode 100644 src/Network/BitTorrent/Exchange/Assembler.hs delete mode 100644 src/Network/BitTorrent/Exchange/Session/Metadata.hs create mode 100644 tests/Network/BitTorrent/Exchange/DownloadSpec.hs delete mode 100644 tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs (limited to 'tests/Network') diff --git a/bittorrent.cabal b/bittorrent.cabal index d8cf0a01..881361f8 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -63,15 +63,13 @@ library Network.BitTorrent.DHT.Session Network.BitTorrent.DHT.Token Network.BitTorrent.Exchange - Network.BitTorrent.Exchange.Assembler Network.BitTorrent.Exchange.Bitfield Network.BitTorrent.Exchange.Block Network.BitTorrent.Exchange.Connection + Network.BitTorrent.Exchange.Download Network.BitTorrent.Exchange.Manager Network.BitTorrent.Exchange.Message Network.BitTorrent.Exchange.Session - Network.BitTorrent.Exchange.Session.Metadata - Network.BitTorrent.Exchange.Session.Status Network.BitTorrent.Tracker Network.BitTorrent.Tracker.List Network.BitTorrent.Tracker.Message @@ -207,9 +205,9 @@ test-suite spec Network.BitTorrent.Tracker.SessionSpec Network.BitTorrent.Exchange.BitfieldSpec Network.BitTorrent.Exchange.ConnectionSpec + Network.BitTorrent.Exchange.DownloadSpec Network.BitTorrent.Exchange.MessageSpec Network.BitTorrent.Exchange.SessionSpec - Network.BitTorrent.Exchange.Session.MetadataSpec System.Torrent.StorageSpec System.Torrent.FileMapSpec build-depends: base == 4.* diff --git a/src/Network/BitTorrent/Exchange/Assembler.hs b/src/Network/BitTorrent/Exchange/Assembler.hs deleted file mode 100644 index 7abb8ab0..00000000 --- a/src/Network/BitTorrent/Exchange/Assembler.hs +++ /dev/null @@ -1,168 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Assembler is used to build pieces from blocks. In general --- 'Assembler' should be used to handle 'Transfer' messages when --- --- A block can have one of the following status: --- --- 1) /not allowed/: Piece is not in download set. 'null' and 'empty'. --- --- --- 2) /waiting/: (allowed?) Block have been allowed to download, --- but /this/ peer did not send any 'Request' message for this --- block. To allow some piece use --- 'Network.BitTorrent.Exchange.Selector' and then 'allowedSet' --- and 'allowPiece'. --- --- 3) /inflight/: (pending?) Block have been requested but --- /remote/ peer did not send any 'Piece' message for this block. --- Related functions 'markInflight' --- --- 4) /pending/: (stalled?) Block have have been downloaded --- Related functions 'insertBlock'. --- --- Piece status: --- --- 1) /assembled/: (downloaded?) All blocks in piece have been --- downloaded but the piece did not verified yet. --- --- * Valid: go to completed; --- --- * Invalid: go to waiting. --- --- 2) /corrupted/: --- --- 3) /downloaded/: (verified?) A piece have been successfully --- verified via the hash. Usually the piece should be stored to --- the 'System.Torrent.Storage' and /this/ peer should send 'Have' --- messages to the /remote/ peers. --- -{-# LANGUAGE TemplateHaskell #-} -module Network.BitTorrent.Exchange.Assembler - ( -- * Assembler - Assembler - - -- * Query - , Network.BitTorrent.Exchange.Assembler.null - , Network.BitTorrent.Exchange.Assembler.size - - -- * - , Network.BitTorrent.Exchange.Assembler.empty - , allowPiece - - -- * Debugging - , Network.BitTorrent.Exchange.Assembler.valid - ) where - -import Control.Applicative -import Control.Lens -import Data.IntMap.Strict as IM -import Data.List as L -import Data.Map as M -import Data.Maybe -import Data.IP - -import Data.Torrent -import Network.BitTorrent.Address -import Network.BitTorrent.Exchange.Block as B - -{----------------------------------------------------------------------- --- Assembler ------------------------------------------------------------------------} - -type Timestamp = () -{- -data BlockRequest = BlockRequest - { requestSent :: Timestamp - , requestedPeer :: PeerAddr IP - , requestedBlock :: BlockIx - } --} -type BlockRange = (BlockOffset, BlockSize) -type PieceMap = IntMap - -data Assembler = Assembler - { -- | A set of blocks that have been 'Request'ed but not yet acked. - _inflight :: Map (PeerAddr IP) (PieceMap [BlockRange]) - - -- | A set of blocks that but not yet assembled. - , _pending :: PieceMap Bucket - - -- | Used for validation of assembled pieces. - , info :: PieceInfo - } - -$(makeLenses ''Assembler) - - -valid :: Assembler -> Bool -valid = undefined - -data Result a - = Completed (Piece a) - | Corrupted PieceIx - | NotRequested PieceIx - | Overlapped BlockIx - -null :: Assembler -> Bool -null = undefined - -size :: Assembler -> Bool -size = undefined - -empty :: PieceInfo -> Assembler -empty = Assembler M.empty IM.empty - -allowPiece :: PieceIx -> Assembler -> Assembler -allowPiece pix a @ Assembler {..} = over pending (IM.insert pix bkt) a - where - bkt = B.empty (piPieceLength info) - -allowedSet :: (PeerAddr IP) -> Assembler -> [BlockIx] -allowedSet = undefined - ---inflight :: PeerAddr -> BlockIx -> Assembler -> Assembler ---inflight = undefined - --- You should check if a returned by peer block is actually have --- been requested and in-flight. This is needed to avoid "I send --- random corrupted block" attacks. -insert :: PeerAddr IP -> Block a -> Assembler -> Assembler -insert = undefined - -{- -insert :: Block a -> Assembler a -> (Assembler a, Maybe (Result a)) -insert blk @ Block {..} a @ Assembler {..} = undefined -{- - = let (pending, mpiece) = inserta blk piecePending - in (Assembler inflightSet pending pieceInfo, f <$> mpiece) - where - f p = undefined --- | checkPieceLazy pieceInfo p = Assembled p --- | otherwise = Corrupted ixPiece --} - - -inflightPieces :: Assembler a -> [PieceIx] -inflightPieces Assembler {..} = IM.keys piecePending - -completeBlocks :: PieceIx -> Assembler a -> [Block a] -completeBlocks pix Assembler {..} = fromMaybe [] $ IM.lookup pix piecePending - -incompleteBlocks :: PieceIx -> Assembler a -> [BlockIx] -incompleteBlocks = undefined - -nextBlock :: Assembler a -> Maybe (Assembler a, BlockIx) -nextBlock Assembler {..} = undefined - -inserta :: Block a - -> PieceMap [Block a] - -> (PieceMap [Block a], Maybe (Piece a)) -inserta = undefined - --} diff --git a/src/Network/BitTorrent/Exchange/Download.hs b/src/Network/BitTorrent/Exchange/Download.hs index fcc94485..9a6b5f91 100644 --- a/src/Network/BitTorrent/Exchange/Download.hs +++ b/src/Network/BitTorrent/Exchange/Download.hs @@ -1,44 +1,196 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} module Network.BitTorrent.Exchange.Download - ( -- * Environment - StatusUpdates - , runStatusUpdates - - -- * Status - , SessionStatus - , sessionStatus - - -- * Query - , getBitfield - , getRequestQueueLength - - -- * Control - , scheduleBlocks - , resetPending - , pushBlock + ( -- * Downloading + Download (..) + , Updates + , runDownloadUpdates + + -- ** Metadata + -- $metadata-download + , MetadataDownload + , metadataDownload + + -- ** Content + -- $content-download + , ContentDownload + , contentDownload ) where import Control.Applicative import Control.Concurrent +import Control.Lens import Control.Monad.State +import Data.BEncode as BE +import Data.ByteString as BS import Data.ByteString.Lazy as BL import Data.Default import Data.List as L import Data.Maybe import Data.Map as M -import Data.Set as S import Data.Tuple -import Data.Torrent -import Network.BitTorrent.Exchange.Bitfield as BF +import Data.Torrent as Torrent import Network.BitTorrent.Address -import Network.BitTorrent.Exchange.Block as Block +import Network.BitTorrent.Exchange.Bitfield as BF +import Network.BitTorrent.Exchange.Block as Block +import Network.BitTorrent.Exchange.Message as Msg import System.Torrent.Storage (Storage, writePiece) {----------------------------------------------------------------------- --- Piece entry +-- Class -----------------------------------------------------------------------} +type Updates s a = StateT s IO a + +runDownloadUpdates :: MVar s -> Updates s a -> IO a +runDownloadUpdates var m = modifyMVar var (fmap swap . runStateT m) + +class Download s chunk | s -> chunk where + scheduleBlocks :: Int -> PeerAddr IP -> Bitfield -> Updates s [BlockIx] + + -- | + scheduleBlock :: PeerAddr IP -> Bitfield -> Updates s (Maybe BlockIx) + scheduleBlock addr bf = listToMaybe <$> scheduleBlocks 1 addr bf + + -- | Get number of sent requests to this peer. + getRequestQueueLength :: PeerAddr IP -> Updates s Int + + -- | Remove all pending block requests to the remote peer. May be used + -- when: + -- + -- * a peer closes connection; + -- + -- * remote peer choked this peer; + -- + -- * timeout expired. + -- + resetPending :: PeerAddr IP -> Updates s () + + -- | MAY write to storage, if a new piece have been completed. + -- + -- You should check if a returned by peer block is actually have + -- been requested and in-flight. This is needed to avoid "I send + -- random corrupted block" attacks. + pushBlock :: PeerAddr IP -> chunk -> Updates s (Maybe Bool) + +{----------------------------------------------------------------------- +-- Metadata download +-----------------------------------------------------------------------} +-- $metadata-download +-- TODO + +data MetadataDownload = MetadataDownload + { _pendingPieces :: [(PeerAddr IP, PieceIx)] + , _bucket :: Bucket + , _topic :: InfoHash + } + +makeLenses ''MetadataDownload + +-- | Create a new scheduler for infodict of the given size. +metadataDownload :: Int -> InfoHash -> MetadataDownload +metadataDownload ps = MetadataDownload [] (Block.empty ps) + +instance Default MetadataDownload where + def = error "instance Default MetadataDownload" + +--cancelPending :: PieceIx -> Updates () +cancelPending pix = pendingPieces %= L.filter ((pix ==) . snd) + +instance Download MetadataDownload (Piece BS.ByteString) where + scheduleBlock addr bf = do + bkt <- use bucket + case spans metadataPieceSize bkt of + [] -> return Nothing + ((off, _ ) : _) -> do + let pix = off `div` metadataPieceSize + pendingPieces %= ((addr, pix) :) + return (Just (BlockIx pix 0 metadataPieceSize)) + + resetPending addr = pendingPieces %= L.filter ((addr ==) . fst) + + pushBlock addr Torrent.Piece {..} = do + p <- use pendingPieces + when ((addr, pieceIndex) `L.notElem` p) $ + error "not requested" + cancelPending pieceIndex + + bucket %= Block.insert (metadataPieceSize * pieceIndex) pieceData + b <- use bucket + case toPiece b of + Nothing -> return Nothing + Just chunks -> do + t <- use topic + case parseInfoDict (BL.toStrict chunks) t of + Right x -> do + pendingPieces .= [] + return undefined -- (Just x) + Left e -> do + pendingPieces .= [] + bucket .= Block.empty (Block.size b) + return undefined -- Nothing + where + -- todo use incremental parsing to avoid BS.concat call + parseInfoDict :: BS.ByteString -> InfoHash -> Result InfoDict + parseInfoDict chunk topic = + case BE.decode chunk of + Right (infodict @ InfoDict {..}) + | topic == idInfoHash -> return infodict + | otherwise -> Left "broken infodict" + Left err -> Left $ "unable to parse infodict " ++ err + +{----------------------------------------------------------------------- +-- Content download +-----------------------------------------------------------------------} +-- $content-download +-- +-- A block can have one of the following status: +-- +-- 1) /not allowed/: Piece is not in download set. +-- +-- 2) /waiting/: (allowed?) Block have been allowed to download, +-- but /this/ peer did not send any 'Request' message for this +-- block. To allow some piece use +-- 'Network.BitTorrent.Exchange.Selector' and then 'allowedSet' +-- and 'allowPiece'. +-- +-- 3) /inflight/: (pending?) Block have been requested but +-- /remote/ peer did not send any 'Piece' message for this block. +-- Related functions 'markInflight' +-- +-- 4) /pending/: (stalled?) Block have have been downloaded +-- Related functions 'insertBlock'. +-- +-- Piece status: +-- +-- 1) /assembled/: (downloaded?) All blocks in piece have been +-- downloaded but the piece did not verified yet. +-- +-- * Valid: go to completed; +-- +-- * Invalid: go to waiting. +-- +-- 2) /corrupted/: +-- +-- 3) /downloaded/: (verified?) A piece have been successfully +-- verified via the hash. Usually the piece should be stored to +-- the 'System.Torrent.Storage' and /this/ peer should send 'Have' +-- messages to the /remote/ peers. +-- + data PieceEntry = PieceEntry { pending :: [(PeerAddr IP, BlockIx)] , stalled :: Bucket @@ -50,44 +202,23 @@ pieceEntry s = PieceEntry [] (Block.empty s) isEmpty :: PieceEntry -> Bool isEmpty PieceEntry {..} = L.null pending && Block.null stalled -holes :: PieceIx -> PieceEntry -> [BlockIx] -holes pix PieceEntry {..} = fmap mkBlockIx (spans defaultTransferSize stalled) +_holes :: PieceIx -> PieceEntry -> [BlockIx] +_holes pix PieceEntry {..} = fmap mkBlockIx (spans defaultTransferSize stalled) where mkBlockIx (off, sz) = BlockIx pix off sz -{----------------------------------------------------------------------- --- Session status ------------------------------------------------------------------------} - -data SessionStatus = SessionStatus - { inprogress :: !(Map PieceIx PieceEntry) - , bitfield :: !Bitfield - , pieceSize :: !PieceSize - } - -sessionStatus :: Bitfield -> PieceSize -> SessionStatus -sessionStatus bf ps = SessionStatus - { inprogress = M.empty - , bitfield = bf - , pieceSize = ps +data ContentDownload = ContentDownload + { inprogress :: !(Map PieceIx PieceEntry) + , bitfield :: !Bitfield + , pieceSize :: !PieceSize + , contentStorage :: Storage } -type StatusUpdates a = StateT SessionStatus IO a - --- | -runStatusUpdates :: MVar SessionStatus -> StatusUpdates a -> IO a -runStatusUpdates var m = modifyMVar var (fmap swap . runStateT m) - -getBitfield :: MVar SessionStatus -> IO Bitfield -getBitfield var = bitfield <$> readMVar var +contentDownload :: Bitfield -> PieceSize -> Storage -> ContentDownload +contentDownload = ContentDownload M.empty -getRequestQueueLength :: PeerAddr IP -> StatusUpdates Int -getRequestQueueLength addr = do - m <- gets (M.elems . M.map (L.filter ((==) addr . fst) . pending) . inprogress) - return $ L.sum $ L.map L.length m - -modifyEntry :: PieceIx -> (PieceEntry -> PieceEntry) -> StatusUpdates () -modifyEntry pix f = modify $ \ s @ SessionStatus {..} -> s +--modifyEntry :: PieceIx -> (PieceEntry -> PieceEntry) -> DownloadUpdates () +modifyEntry pix f = modify $ \ s @ ContentDownload {..} -> s { inprogress = alter (g pieceSize) pix inprogress } where g s = h . f . fromMaybe (pieceEntry s) @@ -95,81 +226,70 @@ modifyEntry pix f = modify $ \ s @ SessionStatus {..} -> s | isEmpty e = Nothing | otherwise = Just e -{----------------------------------------------------------------------- --- Piece download ------------------------------------------------------------------------} +instance Download ContentDownload (Block BL.ByteString) where + scheduleBlocks n addr maskBF = do + ContentDownload {..} <- get + let wantPieces = maskBF `BF.difference` bitfield + let wantBlocks = L.concat $ M.elems $ M.mapWithKey _holes $ + M.filterWithKey (\ pix _ -> pix `BF.member` wantPieces) + inprogress --- TODO choose block nearest to pending or stalled sets to reduce disk --- seeks on remote machines -chooseBlocks :: [BlockIx] -> Int -> StatusUpdates [BlockIx] -chooseBlocks xs n = return (L.take n xs) - --- TODO use selection strategies from Exchange.Selector -choosePiece :: Bitfield -> StatusUpdates (Maybe PieceIx) -choosePiece bf - | BF.null bf = return $ Nothing - | otherwise = return $ Just $ BF.findMin bf - -scheduleBlocks :: PeerAddr IP -> Bitfield -> Int -> StatusUpdates [BlockIx] -scheduleBlocks addr maskBF n = do - SessionStatus {..} <- get - let wantPieces = maskBF `BF.difference` bitfield - let wantBlocks = L.concat $ M.elems $ M.mapWithKey holes $ - M.filterWithKey (\ pix _ -> pix `BF.member` wantPieces) inprogress - - bixs <- if L.null wantBlocks - then do - mpix <- choosePiece wantPieces - case mpix of -- TODO return 'n' blocks - Nothing -> return [] - Just pix -> return [leadingBlock pix defaultTransferSize] - else chooseBlocks wantBlocks n - - forM_ bixs $ \ bix -> do - modifyEntry (ixPiece bix) $ \ e @ PieceEntry {..} -> e - { pending = (addr, bix) : pending } - - return bixs - - --- | Remove all pending block requests to the remote peer. May be used --- when: --- --- * a peer closes connection; --- --- * remote peer choked this peer; --- --- * timeout expired. --- -resetPending :: PeerAddr IP -> StatusUpdates () -resetPending addr = modify $ \ s -> s { inprogress = reset (inprogress s) } - where - reset = fmap $ \ e -> e + bixs <- if L.null wantBlocks + then do + mpix <- choosePiece wantPieces + case mpix of -- TODO return 'n' blocks + Nothing -> return [] + Just pix -> return [leadingBlock pix defaultTransferSize] + else chooseBlocks wantBlocks n + + forM_ bixs $ \ bix -> do + modifyEntry (ixPiece bix) $ \ e @ PieceEntry {..} -> e + { pending = (addr, bix) : pending } + + return bixs + where + -- TODO choose block nearest to pending or stalled sets to reduce disk + -- seeks on remote machines + --chooseBlocks :: [BlockIx] -> Int -> DownloadUpdates [BlockIx] + chooseBlocks xs n = return (L.take n xs) + + -- TODO use selection strategies from Exchange.Selector + --choosePiece :: Bitfield -> DownloadUpdates (Maybe PieceIx) + choosePiece bf + | BF.null bf = return $ Nothing + | otherwise = return $ Just $ BF.findMin bf + + getRequestQueueLength addr = do + m <- gets (M.map (L.filter ((==) addr . fst) . pending) . inprogress) + return $ L.sum $ L.map L.length $ M.elems m + + resetPending addr = modify $ \ s -> s { inprogress = reset (inprogress s) } + where + reset = fmap $ \ e -> e { pending = L.filter (not . (==) addr . fst) (pending e) } --- | MAY write to storage, if a new piece have been completed. -pushBlock :: Block BL.ByteString -> Storage -> StatusUpdates (Maybe Bool) -pushBlock blk @ Block {..} storage = do - mpe <- gets (M.lookup blkPiece . inprogress) - case mpe of - Nothing -> return Nothing - Just (pe @ PieceEntry {..}) - | blockIx blk `L.notElem` fmap snd pending -> return Nothing - | otherwise -> do - let bkt' = Block.insertLazy blkOffset blkData stalled - case toPiece bkt' of - Nothing -> do - modifyEntry blkPiece $ \ e @ PieceEntry {..} -> e - { pending = L.filter ((==) (blockIx blk) . snd) pending - , stalled = bkt' - } - return (Just False) - - Just pieceData -> do - -- TODO verify - liftIO $ writePiece (Piece blkPiece pieceData) storage - modify $ \ s @ SessionStatus {..} -> s - { inprogress = M.delete blkPiece inprogress - , bitfield = BF.insert blkPiece bitfield - } - return (Just True) + pushBlock addr blk @ Block {..} = do + mpe <- gets (M.lookup blkPiece . inprogress) + case mpe of + Nothing -> return Nothing + Just (pe @ PieceEntry {..}) + | blockIx blk `L.notElem` fmap snd pending -> return Nothing + | otherwise -> do + let bkt' = Block.insertLazy blkOffset blkData stalled + case toPiece bkt' of + Nothing -> do + modifyEntry blkPiece $ \ e @ PieceEntry {..} -> e + { pending = L.filter ((==) (blockIx blk) . snd) pending + , stalled = bkt' + } + return (Just False) + + Just pieceData -> do + -- TODO verify + storage <- gets contentStorage + liftIO $ writePiece (Torrent.Piece blkPiece pieceData) storage + modify $ \ s @ ContentDownload {..} -> s + { inprogress = M.delete blkPiece inprogress + , bitfield = BF.insert blkPiece bitfield + } + return (Just True) diff --git a/src/Network/BitTorrent/Exchange/Session.hs b/src/Network/BitTorrent/Exchange/Session.hs index 49bff44f..30b7ed0e 100644 --- a/src/Network/BitTorrent/Exchange/Session.hs +++ b/src/Network/BitTorrent/Exchange/Session.hs @@ -51,9 +51,8 @@ import Network.BitTorrent.Address import Network.BitTorrent.Exchange.Bitfield as BF import Network.BitTorrent.Exchange.Block as Block import Network.BitTorrent.Exchange.Connection -import Network.BitTorrent.Exchange.Download as SS +import Network.BitTorrent.Exchange.Download as D import Network.BitTorrent.Exchange.Message as Message -import Network.BitTorrent.Exchange.Session.Metadata as Metadata import System.Torrent.Storage {----------------------------------------------------------------------- @@ -90,13 +89,13 @@ type LogFun = Loc -> LogSource -> LogLevel -> LogStr -> IO () data SessionState = WaitingMetadata - { metadataDownload :: MVar Metadata.Status + { metadataDownload :: MVar MetadataDownload , metadataCompleted :: MVar InfoDict -- ^ used to unblock waiters , contentRootPath :: FilePath } | HavingMetadata { metadataCache :: Cached InfoDict - , contentDownload :: MVar SessionStatus + , contentDownload :: MVar ContentDownload , contentStorage :: Storage } @@ -105,8 +104,9 @@ newSessionState rootPath (Left ih ) = do WaitingMetadata <$> newMVar def <*> newEmptyMVar <*> pure rootPath newSessionState rootPath (Right dict) = do storage <- openInfoDict ReadWriteEx rootPath dict - download <- newMVar $ sessionStatus (BF.haveNone (totalPieces storage)) - (piPieceLength (idPieceInfo dict)) + download <- newMVar $ D.contentDownload (BF.haveNone (totalPieces storage)) + (piPieceLength (idPieceInfo dict)) + storage return $ HavingMetadata (cache dict) download storage closeSessionState :: SessionState -> IO () @@ -116,8 +116,9 @@ closeSessionState HavingMetadata {..} = close contentStorage haveMetadata :: InfoDict -> SessionState -> IO SessionState haveMetadata dict WaitingMetadata {..} = do storage <- openInfoDict ReadWriteEx contentRootPath dict - download <- newMVar $ sessionStatus (BF.haveNone (totalPieces storage)) - (piPieceLength (idPieceInfo dict)) + download <- newMVar $ D.contentDownload (BF.haveNone (totalPieces storage)) + (piPieceLength (idPieceInfo dict)) + storage return HavingMetadata { metadataCache = cache dict , contentDownload = download diff --git a/src/Network/BitTorrent/Exchange/Session/Metadata.hs b/src/Network/BitTorrent/Exchange/Session/Metadata.hs deleted file mode 100644 index f08ebe00..00000000 --- a/src/Network/BitTorrent/Exchange/Session/Metadata.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Network.BitTorrent.Exchange.Session.Metadata - ( -- * Transfer state - Status - , nullStatus - - -- * State updates - , Updates - , runUpdates - - -- * Piece transfer control - , scheduleBlock - , resetPending - , cancelPending - , pushBlock - ) where - -import Control.Concurrent -import Control.Lens -import Control.Monad.Reader -import Control.Monad.State -import Data.ByteString as BS -import Data.ByteString.Lazy as BL -import Data.Default -import Data.List as L -import Data.Tuple - -import Data.BEncode as BE -import Data.Torrent as Torrent -import Network.BitTorrent.Address -import Network.BitTorrent.Exchange.Block as Block -import Network.BitTorrent.Exchange.Message as Message hiding (Status) - - --- | Current transfer status. -data Status = Status - { _pending :: [(PeerAddr IP, PieceIx)] - , _bucket :: Bucket - } - -makeLenses ''Status - -instance Default Status where - def = error "default status" - --- | Create a new scheduler for infodict of the given size. -nullStatus :: Int -> Status -nullStatus ps = Status [] (Block.empty ps) - -type Updates = ReaderT (PeerAddr IP) (State Status) - -runUpdates :: MVar Status -> PeerAddr IP -> Updates a -> IO a -runUpdates v a m = modifyMVar v (return . swap . runState (runReaderT m a)) - -scheduleBlock :: Updates (Maybe PieceIx) -scheduleBlock = do - addr <- ask - bkt <- use bucket - case spans metadataPieceSize bkt of - [] -> return Nothing - ((off, _ ) : _) -> do - let pix = off `div` metadataPieceSize - pending %= ((addr, pix) :) - return (Just pix) - -cancelPending :: PieceIx -> Updates () -cancelPending pix = pending %= L.filter ((pix ==) . snd) - -resetPending :: Updates () -resetPending = do - addr <- ask - pending %= L.filter ((addr ==) . fst) - -parseInfoDict :: BS.ByteString -> InfoHash -> Result InfoDict -parseInfoDict chunk topic = - case BE.decode chunk of - Right (infodict @ InfoDict {..}) - | topic == idInfoHash -> return infodict - | otherwise -> Left "broken infodict" - Left err -> Left $ "unable to parse infodict " ++ err - --- todo use incremental parsing to avoid BS.concat call -pushBlock :: Torrent.Piece BS.ByteString -> InfoHash -> Updates (Maybe InfoDict) -pushBlock Torrent.Piece {..} topic = do - addr <- ask - p <- use pending - when ((addr, pieceIndex) `L.notElem` p) $ error "not requested" - cancelPending pieceIndex - - bucket %= Block.insert (metadataPieceSize * pieceIndex) pieceData - b <- use bucket - case toPiece b of - Nothing -> return Nothing - Just chunks -> - case parseInfoDict (BL.toStrict chunks) topic of - Right x -> do - pending .= [] - return (Just x) - Left e -> do - pending .= [] - bucket .= Block.empty (Block.size b) - return Nothing diff --git a/tests/Network/BitTorrent/Exchange/DownloadSpec.hs b/tests/Network/BitTorrent/Exchange/DownloadSpec.hs new file mode 100644 index 00000000..a0d40af3 --- /dev/null +++ b/tests/Network/BitTorrent/Exchange/DownloadSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} +module Network.BitTorrent.Exchange.DownloadSpec (spec) where +import Control.Concurrent +import Data.ByteString as BS +import Data.ByteString.Lazy as BL +import Test.Hspec +import Test.QuickCheck + +import Data.BEncode as BE +import Data.Torrent as Torrent +import Network.BitTorrent.Address +import Network.BitTorrent.Exchange.Download +import Network.BitTorrent.Exchange.Message + +import Config +import Network.BitTorrent.CoreSpec () + + +placeholderAddr :: PeerAddr IP +placeholderAddr = "0.0.0.0:0" + +chunkBy :: Int -> BS.ByteString -> [BS.ByteString] +chunkBy s bs + | BS.null bs = [] + | otherwise = BS.take s bs : chunkBy s (BS.drop s bs) + +withUpdates :: Updates s a -> IO a +withUpdates m = do + Torrent {..} <- getTestTorrent + let infoDictLen = fromIntegral $ BL.length $ BE.encode tInfoDict + --mvar <- newMVar (nullStatus infoDictLen) + --runUpdates mvar placeholderAddr m + undefined + +simulateFetch :: InfoDict -> Updates s (Maybe InfoDict) +simulateFetch dict = go + where + blocks = chunkBy metadataPieceSize (BL.toStrict (BE.encode dict)) + packPiece ix = Torrent.Piece ix (blocks !! ix) + ih = idInfoHash dict + + go = do + mix <- scheduleBlock undefined undefined + case mix of + Nothing -> return Nothing + Just ix -> do + mdict <- pushBlock undefined (packPiece ix) + maybe go (return . Just) mdict + +spec :: Spec +spec = do + describe "scheduleBlock" $ do + it "never schedule the same index twice" $ do + pending + + describe "resetPending" $ do + it "" $ do + pending + + describe "cancelPending" $ do + it "must not throw an exception if cancel the same piece twice" $ do + pending + + describe "pushBlock" $ do + it "assemble infodict from chunks" $ do + Torrent {..} <- getTestTorrent + mdict <- withUpdates $ simulateFetch tInfoDict + mdict `shouldBe` Just tInfoDict + + it "must throw an exception if block if not requested" $ do + pending \ No newline at end of file diff --git a/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs b/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs deleted file mode 100644 index fc5236da..00000000 --- a/tests/Network/BitTorrent/Exchange/Session/MetadataSpec.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Network.BitTorrent.Exchange.Session.MetadataSpec (spec) where -import Control.Concurrent -import Data.ByteString as BS -import Data.ByteString.Lazy as BL -import Test.Hspec -import Test.QuickCheck - -import Data.BEncode as BE -import Data.Torrent as Torrent -import Network.BitTorrent.Address -import Network.BitTorrent.Exchange.Message -import Network.BitTorrent.Exchange.Session.Metadata - -import Config -import Network.BitTorrent.CoreSpec () - - -placeholderAddr :: PeerAddr IP -placeholderAddr = "0.0.0.0:0" - -chunkBy :: Int -> BS.ByteString -> [BS.ByteString] -chunkBy s bs - | BS.null bs = [] - | otherwise = BS.take s bs : chunkBy s (BS.drop s bs) - -withUpdates :: Updates a -> IO a -withUpdates m = do - Torrent {..} <- getTestTorrent - let infoDictLen = fromIntegral $ BL.length $ BE.encode tInfoDict - mvar <- newMVar (nullStatus infoDictLen) - runUpdates mvar placeholderAddr m - -simulateFetch :: InfoDict -> Updates (Maybe InfoDict) -simulateFetch dict = go - where - blocks = chunkBy metadataPieceSize (BL.toStrict (BE.encode dict)) - packPiece ix = Torrent.Piece ix (blocks !! ix) - ih = idInfoHash dict - - go = do - mix <- scheduleBlock - case mix of - Nothing -> return Nothing - Just ix -> do - mdict <- pushBlock (packPiece ix) ih - maybe go (return . Just) mdict - -spec :: Spec -spec = do - describe "scheduleBlock" $ do - it "never schedule the same index twice" $ do - pending - - describe "resetPending" $ do - it "" $ do - pending - - describe "cancelPending" $ do - it "must not throw an exception if cancel the same piece twice" $ do - pending - - describe "pushBlock" $ do - it "assemble infodict from chunks" $ do - Torrent {..} <- getTestTorrent - mdict <- withUpdates $ simulateFetch tInfoDict - mdict `shouldBe` Just tInfoDict - - it "must throw an exception if block if not requested" $ do - pending \ No newline at end of file -- cgit v1.2.3 From 55d59c4857dee7e2ab091405e79854c944c7e7e3 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 26 Apr 2014 07:26:36 +0400 Subject: Bump conduit dependency --- bittorrent.cabal | 5 +++-- src/Network/BitTorrent/Client/Types.hs | 2 +- src/Network/BitTorrent/DHT/Session.hs | 3 ++- src/Network/BitTorrent/Exchange/Connection.hs | 1 + tests/Network/BitTorrent/DHT/SessionSpec.hs | 1 + tests/Network/BitTorrent/Exchange/DownloadSpec.hs | 14 +------------- 6 files changed, 9 insertions(+), 17 deletions(-) (limited to 'tests/Network') diff --git a/bittorrent.cabal b/bittorrent.cabal index daef3408..f970a83b 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -117,8 +117,8 @@ library , stm >= 2.4 -- Streaming - , conduit >= 1.0 - , network-conduit >= 1.0 + , conduit >= 1.1 + , conduit-extra >= 1.1 , cereal-conduit >= 0.5 -- * Logging @@ -230,6 +230,7 @@ test-suite spec , mtl , resourcet , conduit + , conduit-extra , monad-loops , monad-logger diff --git a/src/Network/BitTorrent/Client/Types.hs b/src/Network/BitTorrent/Client/Types.hs index a5bf0cce..9bae7dc3 100644 --- a/src/Network/BitTorrent/Client/Types.hs +++ b/src/Network/BitTorrent/Client/Types.hs @@ -100,7 +100,7 @@ externalAddr Client {..} = PeerAddr newtype BitTorrent a = BitTorrent { unBitTorrent :: ReaderT Client IO a } deriving ( Functor, Applicative, Monad - , MonadIO, MonadThrow, MonadUnsafeIO, MonadBase IO + , MonadIO, MonadThrow, MonadBase IO ) class MonadBitTorrent m where diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs index 0dd4b862..eab25ebb 100644 --- a/src/Network/BitTorrent/DHT/Session.hs +++ b/src/Network/BitTorrent/DHT/Session.hs @@ -75,6 +75,7 @@ import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Control import Control.Monad.Trans.Resource +import Data.Conduit.Lazy import Data.Default import Data.Fixed import Data.Hashable @@ -256,7 +257,7 @@ newtype DHT ip a = DHT { unDHT :: ReaderT (Node ip) IO a } deriving ( Functor, Applicative, Monad , MonadIO, MonadBase IO , MonadReader (Node ip) - , MonadThrow, MonadUnsafeIO + , MonadThrow ) instance MonadBaseControl IO (DHT ip) where diff --git a/src/Network/BitTorrent/Exchange/Connection.hs b/src/Network/BitTorrent/Exchange/Connection.hs index f208fa54..2d5f39bf 100644 --- a/src/Network/BitTorrent/Exchange/Connection.hs +++ b/src/Network/BitTorrent/Exchange/Connection.hs @@ -112,6 +112,7 @@ import Control.Concurrent hiding (yield) import Control.Exception import Control.Monad.Reader import Control.Monad.State +import Control.Monad.Trans.Resource import Control.Lens import Data.ByteString as BS import Data.ByteString.Lazy as BSL diff --git a/tests/Network/BitTorrent/DHT/SessionSpec.hs b/tests/Network/BitTorrent/DHT/SessionSpec.hs index 522bd8df..a5376c32 100644 --- a/tests/Network/BitTorrent/DHT/SessionSpec.hs +++ b/tests/Network/BitTorrent/DHT/SessionSpec.hs @@ -5,6 +5,7 @@ import Control.Concurrent import Control.Exception import Control.Monad.Reader import Control.Monad.Trans.Resource +import Data.Conduit.Lazy import Data.Default import Data.List as L import Test.Hspec diff --git a/tests/Network/BitTorrent/Exchange/DownloadSpec.hs b/tests/Network/BitTorrent/Exchange/DownloadSpec.hs index a0d40af3..d46f2034 100644 --- a/tests/Network/BitTorrent/Exchange/DownloadSpec.hs +++ b/tests/Network/BitTorrent/Exchange/DownloadSpec.hs @@ -33,19 +33,7 @@ withUpdates m = do undefined simulateFetch :: InfoDict -> Updates s (Maybe InfoDict) -simulateFetch dict = go - where - blocks = chunkBy metadataPieceSize (BL.toStrict (BE.encode dict)) - packPiece ix = Torrent.Piece ix (blocks !! ix) - ih = idInfoHash dict - - go = do - mix <- scheduleBlock undefined undefined - case mix of - Nothing -> return Nothing - Just ix -> do - mdict <- pushBlock undefined (packPiece ix) - maybe go (return . Just) mdict +simulateFetch dict = undefined spec :: Spec spec = do -- cgit v1.2.3