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 --- src/Data/Torrent.hs | 489 ++++++++++++++++++++++++++++++++++++++++++- src/Data/Torrent/InfoHash.hs | 164 --------------- src/Data/Torrent/Magnet.hs | 372 -------------------------------- 3 files changed, 478 insertions(+), 547 deletions(-) delete mode 100644 src/Data/Torrent/InfoHash.hs delete mode 100644 src/Data/Torrent/Magnet.hs (limited to 'src/Data') diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs index b233937b..5efff598 100644 --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs @@ -17,16 +17,42 @@ -- -- {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -fno-warn-orphans #-} module Data.Torrent - ( -- * Info dictionary - InfoDict (..) + ( -- * InfoHash + -- $infohash + InfoHash + , textToInfoHash + , longHex + , shortHex + + -- * Magnet + -- $magnet-link + , Magnet(..) + , nullMagnet + , simpleMagnet + , detailedMagnet + , parseMagnet + , renderMagnet + + -- ** URN + , URN (..) + , NamespaceId + , btih + , infohashURN + , parseURN + , renderURN + + -- * Info dictionary + , InfoDict (..) , infoDictionary -- ** Lenses @@ -67,34 +93,171 @@ module Data.Torrent import Prelude hiding (sum) import Control.Applicative -import qualified Crypto.Hash.SHA1 as C import Control.DeepSeq import Control.Exception -import Control.Lens +import Control.Lens hiding (unsnoc) +import Control.Monad +import qualified Crypto.Hash.SHA1 as C import Data.BEncode as BE import Data.BEncode.Types as BE import Data.ByteString as BS +import Data.ByteString.Base16 as Base16 +import Data.ByteString.Base32 as Base32 +import Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as BC (pack, unpack) import qualified Data.ByteString.Lazy as BL +import Data.Char import Data.Convertible import Data.Default import Data.Hashable as Hashable import qualified Data.List as L +import Data.Map as M +import Data.Maybe +import Data.Serialize as S +import Data.String import Data.Text as T -import Data.Time +import Data.Text.Encoding as T +import Data.Text.Read import Data.Time.Clock.POSIX import Data.Typeable import Network (HostName) +import Network.HTTP.Types.QueryLike +import Network.HTTP.Types.URI import Network.URI +import Text.ParserCombinators.ReadP as P import Text.PrettyPrint as PP import Text.PrettyPrint.Class import System.FilePath -import Data.Torrent.InfoHash as IH import Data.Torrent.Layout import Data.Torrent.Piece import Network.BitTorrent.Core.NodeInfo + +{----------------------------------------------------------------------- +-- Info hash +-----------------------------------------------------------------------} +-- TODO +-- +-- data Word160 = Word160 {-# UNPACK #-} !Word64 +-- {-# UNPACK #-} !Word64 +-- {-# UNPACK #-} !Word32 +-- +-- newtype InfoHash = InfoHash Word160 +-- +-- reason: bytestring have overhead = 8 words, while infohash have length 20 bytes + +-- $infohash +-- +-- Infohash is a unique identifier of torrent. + +-- | Exactly 20 bytes long SHA1 hash of the info part of torrent file. +newtype InfoHash = InfoHash { getInfoHash :: BS.ByteString } + deriving (Eq, Ord, Typeable) + +infoHashLen :: Int +infoHashLen = 20 + +-- | Meaningless placeholder value. +instance Default InfoHash where + def = "0123456789012345678901234567890123456789" + +-- | Hash raw bytes. (no encoding) +instance Hashable InfoHash where + hashWithSalt s (InfoHash ih) = hashWithSalt s ih + {-# INLINE hashWithSalt #-} + +-- | Convert to\/from raw bencoded string. (no encoding) +instance BEncode InfoHash where + toBEncode = toBEncode . getInfoHash + fromBEncode be = InfoHash <$> fromBEncode be + +-- | Convert to\/from raw bytestring. (no encoding) +instance Serialize InfoHash where + put (InfoHash ih) = putByteString ih + {-# INLINE put #-} + + get = InfoHash <$> getBytes infoHashLen + {-# INLINE get #-} + +-- | Convert to raw query value. (no encoding) +instance QueryValueLike InfoHash where + toQueryValue (InfoHash ih) = Just ih + {-# INLINE toQueryValue #-} + +-- | Convert to base16 encoded string. +instance Show InfoHash where + show (InfoHash ih) = BC.unpack (Base16.encode ih) + +-- | Convert to base16 encoded Doc string. +instance Pretty InfoHash where + pretty = text . show + +-- | Read base16 encoded string. +instance Read InfoHash where + readsPrec _ = readP_to_S $ do + str <- replicateM (infoHashLen * 2) (satisfy isHexDigit) + return $ InfoHash $ decodeIH str + where + decodeIH = BS.pack . L.map fromHex . pair + fromHex (a, b) = read $ '0' : 'x' : a : b : [] + + pair (a : b : xs) = (a, b) : pair xs + pair _ = [] + +-- | Convert raw bytes to info hash. +instance Convertible BS.ByteString InfoHash where + safeConvert bs + | BS.length bs == infoHashLen = pure (InfoHash bs) + | otherwise = convError "invalid length" bs + +-- | Parse infohash from base16\/base32\/base64 encoded string. +instance Convertible Text InfoHash where + safeConvert t + | 20 == hashLen = pure (InfoHash hashStr) + | 26 <= hashLen && hashLen <= 28 = + case Base64.decode hashStr of + Left msg -> convError ("invalid base64 encoding " ++ msg) t + Right ihStr -> safeConvert ihStr + + | hashLen == 32 = + case Base32.decode hashStr of + Left msg -> convError msg t + Right ihStr -> safeConvert ihStr + + | hashLen == 40 = + let (ihStr, inv) = Base16.decode hashStr + in if BS.length inv /= 0 + then convError "invalid base16 encoding" t + else safeConvert ihStr + + | otherwise = convError "invalid length" t + where + hashLen = BS.length hashStr + hashStr = T.encodeUtf8 t + +-- | Decode from base16\/base32\/base64 encoded string. +instance IsString InfoHash where + fromString = either (error . prettyConvertError) id . safeConvert . T.pack + +ignoreErrorMsg :: Either a b -> Maybe b +ignoreErrorMsg = either (const Nothing) Just + +-- | Tries both base16 and base32 while decoding info hash. +-- +-- Use 'safeConvert' for detailed error messages. +-- +textToInfoHash :: Text -> Maybe InfoHash +textToInfoHash = ignoreErrorMsg . safeConvert + +-- | Hex encode infohash to text, full length. +longHex :: InfoHash -> Text +longHex = T.decodeUtf8 . Base16.encode . getInfoHash + +-- | The same as 'longHex', but only first 7 characters. +shortHex :: InfoHash -> Text +shortHex = T.take 7 . longHex + {----------------------------------------------------------------------- -- Info dictionary -----------------------------------------------------------------------} @@ -145,9 +308,9 @@ instance Default InfoDict where infoDictionary :: LayoutInfo -> PieceInfo -> Bool -> InfoDict infoDictionary li pinfo private = InfoDict ih li pinfo private where - ih = hashLazyIH $ encode $ InfoDict def li pinfo private + ih = hashLazyIH $ BE.encode $ InfoDict def li pinfo private -getPrivate :: Get Bool +getPrivate :: BE.Get Bool getPrivate = (Just True ==) <$>? "private" putPrivate :: Bool -> BDict -> BDict @@ -172,7 +335,7 @@ instance BEncode InfoDict where <*> getPieceInfo <*> getPrivate where - ih = hashLazyIH (encode dict) + ih = hashLazyIH (BE.encode dict) ppPrivacy :: Bool -> Doc ppPrivacy privacy = "Privacy: " <> if privacy then "private" else "public" @@ -361,10 +524,314 @@ isTorrentPath filepath = takeExtension filepath == extSeparator : torrentExt fromFile :: FilePath -> IO Torrent fromFile filepath = do contents <- BS.readFile filepath - case decode contents of + case BE.decode contents of Right !t -> return t Left msg -> throwIO $ userError $ msg ++ " while reading torrent file" -- | Encode and write a .torrent file. toFile :: FilePath -> Torrent -> IO () -toFile filepath = BL.writeFile filepath . encode +toFile filepath = BL.writeFile filepath . BE.encode + +{----------------------------------------------------------------------- +-- URN +-----------------------------------------------------------------------} + +-- | Namespace identifier determines the syntactic interpretation of +-- namespace-specific string. +type NamespaceId = [Text] + +-- | BitTorrent Info Hash (hence the name) namespace +-- identifier. Namespace-specific string /should/ be a base16\/base32 +-- encoded SHA1 hash of the corresponding torrent /info/ dictionary. +-- +btih :: NamespaceId +btih = ["btih"] + +-- | URN is pesistent location-independent identifier for +-- resources. In particular, URNs are used represent torrent names +-- as a part of magnet link, see 'Data.Torrent.Magnet.Magnet' for +-- more info. +-- +data URN = URN + { urnNamespace :: NamespaceId -- ^ a namespace identifier; + , urnString :: Text -- ^ a corresponding + -- namespace-specific string. + } deriving (Eq, Ord, Typeable) + +----------------------------------------------------------------------- + +instance Convertible URN InfoHash where + safeConvert u @ URN {..} + | urnNamespace /= btih = convError "invalid namespace" u + | otherwise = safeConvert urnString + +-- | Make resource name for torrent with corresponding +-- infohash. Infohash is base16 (hex) encoded. +-- +infohashURN :: InfoHash -> URN +infohashURN = URN btih . longHex + +-- | Meaningless placeholder value. +instance Default URN where + def = infohashURN def + +------------------------------------------------------------------------ + +-- | Render URN to its text representation. +renderURN :: URN -> Text +renderURN URN {..} + = T.intercalate ":" $ "urn" : urnNamespace ++ [urnString] + +instance Pretty URN where + pretty = text . T.unpack . renderURN + +instance Show URN where + showsPrec n = showsPrec n . T.unpack . renderURN + +instance QueryValueLike URN where + toQueryValue = toQueryValue . renderURN + {-# INLINE toQueryValue #-} + +----------------------------------------------------------------------- + +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc xs = Just (L.init xs, L.last xs) + +instance Convertible Text URN where + safeConvert t = case T.split (== ':') t of + uriScheme : body + | T.toLower uriScheme == "urn" -> + case unsnoc body of + Just (namespace, val) -> pure URN + { urnNamespace = namespace + , urnString = val + } + Nothing -> convError "missing URN string" body + | otherwise -> convError "invalid URN scheme" uriScheme + [] -> convError "missing URN scheme" t + +instance IsString URN where + fromString = either (error . prettyConvertError) id + . safeConvert . T.pack + +-- | Try to parse an URN from its text representation. +-- +-- Use 'safeConvert' for detailed error messages. +-- +parseURN :: Text -> Maybe URN +parseURN = either (const Nothing) pure . safeConvert + +{----------------------------------------------------------------------- +-- Magnet +-----------------------------------------------------------------------} +-- $magnet-link +-- +-- Magnet URI scheme is an standard defining Magnet links. Magnet +-- links are refer to resources by hash, in particular magnet links +-- can refer to torrent using corresponding infohash. In this way, +-- magnet links can be used instead of torrent files. +-- +-- This module provides bittorrent specific implementation of magnet +-- links. +-- +-- For generic magnet uri scheme see: +-- , +-- +-- +-- Bittorrent specific details: +-- +-- + +-- TODO multiple exact topics +-- TODO render/parse supplement for URI/query + +-- | An URI used to identify torrent. +data Magnet = Magnet + { -- | Torrent infohash hash. Can be used in DHT queries if no + -- 'tracker' provided. + exactTopic :: !InfoHash -- TODO InfoHash -> URN? + + -- | A filename for the file to download. Can be used to + -- display name while waiting for metadata. + , displayName :: Maybe Text + + -- | Size of the resource in bytes. + , exactLength :: Maybe Integer + + -- | URI pointing to manifest, e.g. a list of further items. + , manifest :: Maybe Text + + -- | Search string. + , keywordTopic :: Maybe Text + + -- | A source to be queried after not being able to find and + -- download the file in the bittorrent network in a defined + -- amount of time. + , acceptableSource :: Maybe URI + + -- | Direct link to the resource. + , exactSource :: Maybe URI + + -- | URI to the tracker. + , tracker :: Maybe URI + + -- | Additional or experimental parameters. + , supplement :: Map Text Text + } deriving (Eq, Ord, Typeable) + +instance QueryValueLike Integer where + toQueryValue = toQueryValue . show + +instance QueryValueLike URI where + toQueryValue = toQueryValue . show + +instance QueryLike Magnet where + toQuery Magnet {..} = + [ ("xt", toQueryValue $ infohashURN exactTopic) + , ("dn", toQueryValue displayName) + , ("xl", toQueryValue exactLength) + , ("mt", toQueryValue manifest) + , ("kt", toQueryValue keywordTopic) + , ("as", toQueryValue acceptableSource) + , ("xs", toQueryValue exactSource) + , ("tr", toQueryValue tracker) + ] + +instance QueryValueLike Magnet where + toQueryValue = toQueryValue . renderMagnet + +instance Convertible QueryText Magnet where + safeConvert xs = do + urnStr <- getTextMsg "xt" "exact topic not defined" xs + infoHash <- convertVia (error "safeConvert" :: URN) urnStr + return Magnet + { exactTopic = infoHash + , displayName = getText "dn" xs + , exactLength = getText "xl" xs >>= getInt + , manifest = getText "mt" xs + , keywordTopic = getText "kt" xs + , acceptableSource = getText "as" xs >>= getURI + , exactSource = getText "xs" xs >>= getURI + , tracker = getText "tr" xs >>= getURI + , supplement = M.empty + } + where + getInt = either (const Nothing) (Just . fst) . signed decimal + getURI = parseURI . T.unpack + getText p = join . L.lookup p + getTextMsg p msg ps = maybe (convError msg xs) pure $ getText p ps + +magnetScheme :: URI +magnetScheme = URI + { uriScheme = "magnet:" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + , uriFragment = "" + } + +isMagnetURI :: URI -> Bool +isMagnetURI u = u { uriQuery = "" } == magnetScheme + +-- | Can be used instead of 'parseMagnet'. +instance Convertible URI Magnet where + safeConvert u @ URI {..} + | not (isMagnetURI u) = convError "this is not a magnet link" u + | otherwise = safeConvert $ parseQueryText $ BC.pack uriQuery + +-- | Can be used instead of 'renderMagnet'. +instance Convertible Magnet URI where + safeConvert m = pure $ magnetScheme + { uriQuery = BC.unpack $ renderQuery True $ toQuery m } + +instance Convertible String Magnet where + safeConvert str + | Just uri <- parseURI str = safeConvert uri + | otherwise = convError "unable to parse uri" str + +------------------------------------------------------------------------ + +-- | Meaningless placeholder value. +instance Default Magnet where + def = Magnet + { exactTopic = def + , displayName = Nothing + , exactLength = Nothing + , manifest = Nothing + , keywordTopic = Nothing + , acceptableSource = Nothing + , exactSource = Nothing + , tracker = Nothing + , supplement = M.empty + } + +-- | Set 'exactTopic' ('xt' param) only, other params are empty. +nullMagnet :: InfoHash -> Magnet +nullMagnet u = Magnet + { exactTopic = u + , displayName = Nothing + , exactLength = Nothing + , manifest = Nothing + , keywordTopic = Nothing + , acceptableSource = Nothing + , exactSource = Nothing + , tracker = Nothing + , supplement = M.empty + } + +-- | Like 'nullMagnet' but also include 'displayName' ('dn' param). +simpleMagnet :: Torrent -> Magnet +simpleMagnet Torrent {tInfoDict = InfoDict {..}} + = (nullMagnet idInfoHash) + { displayName = Just $ T.decodeUtf8 $ suggestedName idLayoutInfo + } + +-- | Like 'simpleMagnet' but also include 'exactLength' ('xl' param) and +-- 'tracker' ('tr' param). +-- +detailedMagnet :: Torrent -> Magnet +detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce} + = (simpleMagnet t) + { exactLength = Just $ fromIntegral $ contentLength idLayoutInfo + , tracker = tAnnounce + } + +----------------------------------------------------------------------- + +parseMagnetStr :: String -> Maybe Magnet +parseMagnetStr = either (const Nothing) Just . safeConvert + +renderMagnetStr :: Magnet -> String +renderMagnetStr = show . (convert :: Magnet -> URI) + +instance Pretty Magnet where + pretty = PP.text . renderMagnetStr + +instance Show Magnet where + show = renderMagnetStr + {-# INLINE show #-} + +instance Read Magnet where + readsPrec _ xs + | Just m <- parseMagnetStr mstr = [(m, rest)] + | otherwise = [] + where + (mstr, rest) = L.break (== ' ') xs + +instance IsString Magnet where + fromString str = fromMaybe (error msg) $ parseMagnetStr str + where + msg = "unable to parse magnet: " ++ str + +-- | Try to parse magnet link from urlencoded string. Use +-- 'safeConvert' to find out error location. +-- +parseMagnet :: Text -> Maybe Magnet +parseMagnet = parseMagnetStr . T.unpack +{-# INLINE parseMagnet #-} + +-- | Render magnet link to urlencoded string +renderMagnet :: Magnet -> Text +renderMagnet = T.pack . renderMagnetStr +{-# INLINE renderMagnet #-} diff --git a/src/Data/Torrent/InfoHash.hs b/src/Data/Torrent/InfoHash.hs deleted file mode 100644 index f322ac6f..00000000 --- a/src/Data/Torrent/InfoHash.hs +++ /dev/null @@ -1,164 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : provisional --- Portability : portable --- --- Infohash is a unique identifier of torrent. --- -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Data.Torrent.InfoHash - ( InfoHash - - -- * Parsing - , textToInfoHash - - -- * Rendering - , longHex - , shortHex - ) where - -import Control.Applicative -import Control.Monad -import Data.BEncode -import Data.ByteString as BS -import Data.ByteString.Char8 as BC -import Data.ByteString.Base16 as Base16 -import Data.ByteString.Base32 as Base32 -import Data.ByteString.Base64 as Base64 -import Data.Char -import Data.Convertible.Base -import Data.Default -import Data.List as L -import Data.Hashable as Hashable -import Data.Serialize -import Data.String -import Data.Text as T -import Data.Text.Encoding as T -import Data.Typeable -import Network.HTTP.Types.QueryLike -import Text.ParserCombinators.ReadP as P -import Text.PrettyPrint -import Text.PrettyPrint.Class - - --- TODO --- --- data Word160 = Word160 {-# UNPACK #-} !Word64 --- {-# UNPACK #-} !Word64 --- {-# UNPACK #-} !Word32 --- --- newtype InfoHash = InfoHash Word160 --- --- reason: bytestring have overhead = 8 words, while infohash have length 20 bytes - --- | Exactly 20 bytes long SHA1 hash of the info part of torrent file. -newtype InfoHash = InfoHash { getInfoHash :: BS.ByteString } - deriving (Eq, Ord, Typeable) - -infoHashLen :: Int -infoHashLen = 20 - --- | Meaningless placeholder value. -instance Default InfoHash where - def = "0123456789012345678901234567890123456789" - --- | Hash raw bytes. (no encoding) -instance Hashable InfoHash where - hashWithSalt s (InfoHash ih) = hashWithSalt s ih - {-# INLINE hashWithSalt #-} - --- | Convert to\/from raw bencoded string. (no encoding) -instance BEncode InfoHash where - toBEncode = toBEncode . getInfoHash - fromBEncode be = InfoHash <$> fromBEncode be - --- | Convert to\/from raw bytestring. (no encoding) -instance Serialize InfoHash where - put (InfoHash ih) = putByteString ih - {-# INLINE put #-} - - get = InfoHash <$> getBytes infoHashLen - {-# INLINE get #-} - --- | Convert to raw query value. (no encoding) -instance QueryValueLike InfoHash where - toQueryValue (InfoHash ih) = Just ih - {-# INLINE toQueryValue #-} - --- | Convert to base16 encoded string. -instance Show InfoHash where - show (InfoHash ih) = BC.unpack (Base16.encode ih) - --- | Convert to base16 encoded Doc string. -instance Pretty InfoHash where - pretty = text . show - --- | Read base16 encoded string. -instance Read InfoHash where - readsPrec _ = readP_to_S $ do - str <- replicateM (infoHashLen * 2) (satisfy isHexDigit) - return $ InfoHash $ decodeIH str - where - decodeIH = BS.pack . L.map fromHex . pair - fromHex (a, b) = read $ '0' : 'x' : a : b : [] - - pair (a : b : xs) = (a, b) : pair xs - pair _ = [] - --- | Convert raw bytes to info hash. -instance Convertible BS.ByteString InfoHash where - safeConvert bs - | BS.length bs == infoHashLen = pure (InfoHash bs) - | otherwise = convError "invalid length" bs - --- | Parse infohash from base16\/base32\/base64 encoded string. -instance Convertible Text InfoHash where - safeConvert t - | 20 == hashLen = pure (InfoHash hashStr) - | 26 <= hashLen && hashLen <= 28 = - case Base64.decode hashStr of - Left msg -> convError ("invalid base64 encoding " ++ msg) t - Right ihStr -> safeConvert ihStr - - | hashLen == 32 = - case Base32.decode hashStr of - Left msg -> convError msg t - Right ihStr -> safeConvert ihStr - - | hashLen == 40 = - let (ihStr, inv) = Base16.decode hashStr - in if BS.length inv /= 0 - then convError "invalid base16 encoding" t - else safeConvert ihStr - - | otherwise = convError "invalid length" t - where - hashLen = BS.length hashStr - hashStr = T.encodeUtf8 t - --- | Decode from base16\/base32\/base64 encoded string. -instance IsString InfoHash where - fromString = either (error . prettyConvertError) id . safeConvert . T.pack - -ignoreErrorMsg :: Either a b -> Maybe b -ignoreErrorMsg = either (const Nothing) Just - --- | Tries both base16 and base32 while decoding info hash. --- --- Use 'safeConvert' for detailed error messages. --- -textToInfoHash :: Text -> Maybe InfoHash -textToInfoHash = ignoreErrorMsg . safeConvert - --- | Hex encode infohash to text, full length. -longHex :: InfoHash -> Text -longHex = T.decodeUtf8 . Base16.encode . getInfoHash - --- | The same as 'longHex', but only first 7 characters. -shortHex :: InfoHash -> Text -shortHex = T.take 7 . longHex diff --git a/src/Data/Torrent/Magnet.hs b/src/Data/Torrent/Magnet.hs deleted file mode 100644 index aad0debe..00000000 --- a/src/Data/Torrent/Magnet.hs +++ /dev/null @@ -1,372 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : provisional --- Portability : portable --- --- Magnet URI scheme is an standard defining Magnet links. Magnet --- links are refer to resources by hash, in particular magnet links --- can refer to torrent using corresponding infohash. In this way, --- magnet links can be used instead of torrent files. --- --- This module provides bittorrent specific implementation of magnet --- links. --- --- For generic magnet uri scheme see: --- , --- --- --- Bittorrent specific details: --- --- -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent.Magnet - ( -- * Magnet - Magnet(..) - - -- ** Construction - , nullMagnet - , simpleMagnet - , detailedMagnet - - -- ** Conversion - , parseMagnet - , renderMagnet - - -- * URN - , URN (..) - - -- ** Namespaces - , NamespaceId - , btih - - -- ** Construction - , infohashURN - - -- ** Conversion - , parseURN - , renderURN - ) where - -import Control.Applicative -import Control.Monad -import Data.ByteString.Char8 as BC -import Data.Convertible -import Data.Default -import Data.Map as M -import Data.Maybe -import Data.List as L -import Data.String -import Data.Text as T -import Data.Text.Encoding as T -import Data.Text.Read -import Data.Typeable -import Network.HTTP.Types.QueryLike -import Network.HTTP.Types.URI -import Network.URI -import Text.PrettyPrint as PP -import Text.PrettyPrint.Class - -import Data.Torrent -import Data.Torrent.InfoHash -import Data.Torrent.Layout - - --- | Namespace identifier determines the syntactic interpretation of --- namespace-specific string. -type NamespaceId = [Text] - --- | BitTorrent Info Hash (hence the name) namespace --- identifier. Namespace-specific string /should/ be a base16\/base32 --- encoded SHA1 hash of the corresponding torrent /info/ dictionary. --- -btih :: NamespaceId -btih = ["btih"] - --- | URN is pesistent location-independent identifier for --- resources. In particular, URNs are used represent torrent names --- as a part of magnet link, see 'Data.Torrent.Magnet.Magnet' for --- more info. --- -data URN = URN - { urnNamespace :: NamespaceId -- ^ a namespace identifier; - , urnString :: Text -- ^ a corresponding - -- namespace-specific string. - } deriving (Eq, Ord, Typeable) - -{----------------------------------------------------------------------- --- URN to infohash convertion ------------------------------------------------------------------------} - -instance Convertible URN InfoHash where - safeConvert u @ URN {..} - | urnNamespace /= btih = convError "invalid namespace" u - | otherwise = safeConvert urnString - --- | Make resource name for torrent with corresponding --- infohash. Infohash is base16 (hex) encoded. --- -infohashURN :: InfoHash -> URN -infohashURN = URN btih . longHex - --- | Meaningless placeholder value. -instance Default URN where - def = infohashURN def - -{----------------------------------------------------------------------- --- URN Rendering ------------------------------------------------------------------------} - --- | Render URN to its text representation. -renderURN :: URN -> Text -renderURN URN {..} - = T.intercalate ":" $ "urn" : urnNamespace ++ [urnString] - -instance Pretty URN where - pretty = text . T.unpack . renderURN - -instance Show URN where - showsPrec n = showsPrec n . T.unpack . renderURN - -instance QueryValueLike URN where - toQueryValue = toQueryValue . renderURN - {-# INLINE toQueryValue #-} - -{----------------------------------------------------------------------- --- URN Parsing ------------------------------------------------------------------------} - -unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc xs = Just (L.init xs, L.last xs) - -instance Convertible Text URN where - safeConvert t = case T.split (== ':') t of - uriScheme : body - | T.toLower uriScheme == "urn" -> - case unsnoc body of - Just (namespace, val) -> pure URN - { urnNamespace = namespace - , urnString = val - } - Nothing -> convError "missing URN string" body - | otherwise -> convError "invalid URN scheme" uriScheme - [] -> convError "missing URN scheme" t - -instance IsString URN where - fromString = either (error . prettyConvertError) id - . safeConvert . T.pack - --- | Try to parse an URN from its text representation. --- --- Use 'safeConvert' for detailed error messages. --- -parseURN :: Text -> Maybe URN -parseURN = either (const Nothing) pure . safeConvert - -{----------------------------------------------------------------------- --- Magnet ------------------------------------------------------------------------} - --- TODO multiple exact topics --- TODO render/parse supplement for URI/query - --- | An URI used to identify torrent. -data Magnet = Magnet - { -- | Torrent infohash hash. Can be used in DHT queries if no - -- 'tracker' provided. - exactTopic :: !InfoHash -- TODO InfoHash -> URN? - - -- | A filename for the file to download. Can be used to - -- display name while waiting for metadata. - , displayName :: Maybe Text - - -- | Size of the resource in bytes. - , exactLength :: Maybe Integer - - -- | URI pointing to manifest, e.g. a list of further items. - , manifest :: Maybe Text - - -- | Search string. - , keywordTopic :: Maybe Text - - -- | A source to be queried after not being able to find and - -- download the file in the bittorrent network in a defined - -- amount of time. - , acceptableSource :: Maybe URI - - -- | Direct link to the resource. - , exactSource :: Maybe URI - - -- | URI to the tracker. - , tracker :: Maybe URI - - -- | Additional or experimental parameters. - , supplement :: Map Text Text - } deriving (Eq, Ord, Typeable) - -instance QueryValueLike Integer where - toQueryValue = toQueryValue . show - -instance QueryValueLike URI where - toQueryValue = toQueryValue . show - -instance QueryLike Magnet where - toQuery Magnet {..} = - [ ("xt", toQueryValue $ infohashURN exactTopic) - , ("dn", toQueryValue displayName) - , ("xl", toQueryValue exactLength) - , ("mt", toQueryValue manifest) - , ("kt", toQueryValue keywordTopic) - , ("as", toQueryValue acceptableSource) - , ("xs", toQueryValue exactSource) - , ("tr", toQueryValue tracker) - ] - -instance QueryValueLike Magnet where - toQueryValue = toQueryValue . renderMagnet - -instance Convertible QueryText Magnet where - safeConvert xs = do - urnStr <- getTextMsg "xt" "exact topic not defined" xs - infoHash <- convertVia (error "safeConvert" :: URN) urnStr - return Magnet - { exactTopic = infoHash - , displayName = getText "dn" xs - , exactLength = getText "xl" xs >>= getInt - , manifest = getText "mt" xs - , keywordTopic = getText "kt" xs - , acceptableSource = getText "as" xs >>= getURI - , exactSource = getText "xs" xs >>= getURI - , tracker = getText "tr" xs >>= getURI - , supplement = M.empty - } - where - getInt = either (const Nothing) (Just . fst) . signed decimal - getURI = parseURI . T.unpack - getText p = join . L.lookup p - getTextMsg p msg ps = maybe (convError msg xs) pure $ getText p ps - -magnetScheme :: URI -magnetScheme = URI - { uriScheme = "magnet:" - , uriAuthority = Nothing - , uriPath = "" - , uriQuery = "" - , uriFragment = "" - } - -isMagnetURI :: URI -> Bool -isMagnetURI u = u { uriQuery = "" } == magnetScheme - --- | Can be used instead of 'parseMagnet'. -instance Convertible URI Magnet where - safeConvert u @ URI {..} - | not (isMagnetURI u) = convError "this is not a magnet link" u - | otherwise = safeConvert $ parseQueryText $ BC.pack uriQuery - --- | Can be used instead of 'renderMagnet'. -instance Convertible Magnet URI where - safeConvert m = pure $ magnetScheme - { uriQuery = BC.unpack $ renderQuery True $ toQuery m } - -instance Convertible String Magnet where - safeConvert str - | Just uri <- parseURI str = safeConvert uri - | otherwise = convError "unable to parse uri" str - -{----------------------------------------------------------------------- --- Magnet Construction ------------------------------------------------------------------------} - --- | Meaningless placeholder value. -instance Default Magnet where - def = Magnet - { exactTopic = def - , displayName = Nothing - , exactLength = Nothing - , manifest = Nothing - , keywordTopic = Nothing - , acceptableSource = Nothing - , exactSource = Nothing - , tracker = Nothing - , supplement = M.empty - } - --- | Set 'exactTopic' ('xt' param) only, other params are empty. -nullMagnet :: InfoHash -> Magnet -nullMagnet u = Magnet - { exactTopic = u - , displayName = Nothing - , exactLength = Nothing - , manifest = Nothing - , keywordTopic = Nothing - , acceptableSource = Nothing - , exactSource = Nothing - , tracker = Nothing - , supplement = M.empty - } - --- | Like 'nullMagnet' but also include 'displayName' ('dn' param). -simpleMagnet :: Torrent -> Magnet -simpleMagnet Torrent {tInfoDict = InfoDict {..}} - = (nullMagnet idInfoHash) - { displayName = Just $ T.decodeUtf8 $ suggestedName idLayoutInfo - } - --- | Like 'simpleMagnet' but also include 'exactLength' ('xl' param) and --- 'tracker' ('tr' param). --- -detailedMagnet :: Torrent -> Magnet -detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce} - = (simpleMagnet t) - { exactLength = Just $ fromIntegral $ contentLength idLayoutInfo - , tracker = tAnnounce - } - -{----------------------------------------------------------------------- --- Magnet Conversion ------------------------------------------------------------------------} - -parseMagnetStr :: String -> Maybe Magnet -parseMagnetStr = either (const Nothing) Just . safeConvert - -renderMagnetStr :: Magnet -> String -renderMagnetStr = show . (convert :: Magnet -> URI) - -instance Pretty Magnet where - pretty = PP.text . renderMagnetStr - -instance Show Magnet where - show = renderMagnetStr - {-# INLINE show #-} - -instance Read Magnet where - readsPrec _ xs - | Just m <- parseMagnetStr mstr = [(m, rest)] - | otherwise = [] - where - (mstr, rest) = L.break (== ' ') xs - -instance IsString Magnet where - fromString str = fromMaybe (error msg) $ parseMagnetStr str - where - msg = "unable to parse magnet: " ++ str - --- | Try to parse magnet link from urlencoded string. Use --- 'safeConvert' to find out error location. --- -parseMagnet :: Text -> Maybe Magnet -parseMagnet = parseMagnetStr . T.unpack -{-# INLINE parseMagnet #-} - --- | Render magnet link to urlencoded string -renderMagnet :: Magnet -> Text -renderMagnet = T.pack . renderMagnetStr -{-# INLINE renderMagnet #-} -- cgit v1.2.3 From 88ef120511caae5ed74a48a87617b43aec4b7f76 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 4 Apr 2014 21:16:34 +0400 Subject: Move layout info to Torrent module --- bittorrent.cabal | 1 - src/Data/Torrent.hs | 270 +++++++++++++++++++++++++++++- src/Data/Torrent/Layout.hs | 321 ------------------------------------ src/Data/Torrent/Tree.hs | 2 +- src/System/Torrent/FileMap.hs | 2 +- src/System/Torrent/Storage.hs | 2 +- tests/Data/Torrent/LayoutSpec.hs | 2 +- tests/Data/Torrent/MetainfoSpec.hs | 3 +- tests/System/Torrent/FileMapSpec.hs | 2 +- tests/System/Torrent/StorageSpec.hs | 2 +- 10 files changed, 276 insertions(+), 331 deletions(-) delete mode 100644 src/Data/Torrent/Layout.hs (limited to 'src/Data') diff --git a/bittorrent.cabal b/bittorrent.cabal index 0861bf2b..9d687d7d 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.Layout Data.Torrent.Piece Data.Torrent.Progress Data.Torrent.Tree diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs index 5efff598..701da9dd 100644 --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs @@ -23,7 +23,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -fno-warn-orphans #-} module Data.Torrent @@ -51,6 +55,37 @@ module Data.Torrent , parseURN , renderURN + -- * File layout + -- ** FileInfo + , FileOffset + , FileSize + , FileInfo (..) + , fileLength + , filePath + , fileMD5Sum + + -- ** Layout info + , LayoutInfo (..) + , joinFilePath + , singleFile + , multiFile + , rootDirName + , isSingleFile + , isMultiFile + , suggestedName + , contentLength + , fileCount + , blockCount + + -- ** Flat layout info + , FileLayout + , flatLayout + , accumPositions + , fileOffset + + -- ** Internal + , sizeInBase + -- * Info dictionary , InfoDict (..) , infoDictionary @@ -109,6 +144,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Char import Data.Convertible import Data.Default +import Data.Foldable as F import Data.Hashable as Hashable import qualified Data.List as L import Data.Map as M @@ -128,8 +164,8 @@ import Text.ParserCombinators.ReadP as P import Text.PrettyPrint as PP import Text.PrettyPrint.Class import System.FilePath +import System.Posix.Types -import Data.Torrent.Layout import Data.Torrent.Piece import Network.BitTorrent.Core.NodeInfo @@ -258,6 +294,238 @@ longHex = T.decodeUtf8 . Base16.encode . getInfoHash shortHex :: InfoHash -> Text shortHex = T.take 7 . longHex +{----------------------------------------------------------------------- +-- File info +-----------------------------------------------------------------------} + +-- | Size of a file in bytes. +type FileSize = FileOffset + +deriving instance BEncode FileOffset + +-- | Contain metainfo about one single file. +data FileInfo a = FileInfo { + fiLength :: {-# UNPACK #-} !FileSize + -- ^ Length of the file in bytes. + + -- TODO unpacked MD5 sum + , fiMD5Sum :: !(Maybe ByteString) + -- ^ 32 character long MD5 sum of the file. Used by third-party + -- tools, not by bittorrent protocol itself. + + , fiName :: !a + -- ^ One or more string elements that together represent the + -- path and filename. Each element in the list corresponds to + -- either a directory name or (in the case of the last element) + -- the filename. For example, the file: + -- + -- > "dir1/dir2/file.ext" + -- + -- would consist of three string elements: + -- + -- > ["dir1", "dir2", "file.ext"] + -- + } deriving (Show, Read, Eq, Typeable + , Functor, Foldable + ) + +makeLensesFor + [ ("fiLength", "fileLength") + , ("fiMD5Sum", "fileMD5Sum") + , ("fiName" , "filePath" ) + ] + ''FileInfo + +instance NFData a => NFData (FileInfo a) where + rnf FileInfo {..} = rnf fiName + {-# INLINE rnf #-} + +instance BEncode (FileInfo [ByteString]) where + toBEncode FileInfo {..} = toDict $ + "length" .=! fiLength + .: "md5sum" .=? fiMD5Sum + .: "path" .=! fiName + .: endDict + {-# INLINE toBEncode #-} + + fromBEncode = fromDict $ do + FileInfo <$>! "length" + <*>? "md5sum" + <*>! "path" + {-# INLINE fromBEncode #-} + +type Put a = a -> BDict -> BDict + +putFileInfoSingle :: Data.Torrent.Put (FileInfo ByteString) +putFileInfoSingle FileInfo {..} cont = + "length" .=! fiLength + .: "md5sum" .=? fiMD5Sum + .: "name" .=! fiName + .: cont + +getFileInfoSingle :: BE.Get (FileInfo ByteString) +getFileInfoSingle = do + FileInfo <$>! "length" + <*>? "md5sum" + <*>! "name" + +instance BEncode (FileInfo ByteString) where + toBEncode = toDict . (`putFileInfoSingle` endDict) + {-# INLINE toBEncode #-} + + fromBEncode = fromDict getFileInfoSingle + {-# INLINE fromBEncode #-} + +instance Pretty (FileInfo BS.ByteString) where + pretty FileInfo {..} = + "Path: " <> text (T.unpack (T.decodeUtf8 fiName)) + $$ "Size: " <> text (show fiLength) + $$ maybe PP.empty ppMD5 fiMD5Sum + where + ppMD5 md5 = "MD5 : " <> text (show (Base16.encode md5)) + +-- | Join file path. +joinFilePath :: FileInfo [ByteString] -> FileInfo ByteString +joinFilePath = fmap (BS.intercalate "/") + +{----------------------------------------------------------------------- +-- Layout info +-----------------------------------------------------------------------} + +-- | Original (found in torrent file) layout info is either: +-- +-- * Single file with its /name/. +-- +-- * Multiple files with its relative file /paths/. +-- +data LayoutInfo + = SingleFile + { -- | Single file info. + liFile :: !(FileInfo ByteString) + } + | MultiFile + { -- | List of the all files that torrent contains. + liFiles :: ![FileInfo [ByteString]] + + -- | The /suggested/ name of the root directory in which to + -- store all the files. + , liDirName :: !ByteString + } deriving (Show, Read, Eq, Typeable) + +makeLensesFor + [ ("liFile" , "singleFile" ) + , ("liFiles" , "multiFile" ) + , ("liDirName", "rootDirName") + ] + ''LayoutInfo + +instance NFData LayoutInfo where + rnf SingleFile {..} = () + rnf MultiFile {..} = rnf liFiles + +-- | Empty multifile layout. +instance Default LayoutInfo where + def = MultiFile [] "" + +getLayoutInfo :: BE.Get LayoutInfo +getLayoutInfo = single <|> multi + where + single = SingleFile <$> getFileInfoSingle + multi = MultiFile <$>! "files" <*>! "name" + +putLayoutInfo :: Data.Torrent.Put LayoutInfo +putLayoutInfo SingleFile {..} = putFileInfoSingle liFile +putLayoutInfo MultiFile {..} = \ cont -> + "files" .=! liFiles + .: "name" .=! liDirName + .: cont + +instance BEncode LayoutInfo where + toBEncode = toDict . (`putLayoutInfo` endDict) + fromBEncode = fromDict getLayoutInfo + +instance Pretty LayoutInfo where + pretty SingleFile {..} = pretty liFile + pretty MultiFile {..} = vcat $ L.map (pretty . joinFilePath) liFiles + +-- | Test if this is single file torrent. +isSingleFile :: LayoutInfo -> Bool +isSingleFile SingleFile {} = True +isSingleFile _ = False +{-# INLINE isSingleFile #-} + +-- | Test if this is multifile torrent. +isMultiFile :: LayoutInfo -> Bool +isMultiFile MultiFile {} = True +isMultiFile _ = False +{-# INLINE isMultiFile #-} + +-- | Get name of the torrent based on the root path piece. +suggestedName :: LayoutInfo -> ByteString +suggestedName (SingleFile FileInfo {..}) = fiName +suggestedName MultiFile {..} = liDirName +{-# INLINE suggestedName #-} + +-- | Find sum of sizes of the all torrent files. +contentLength :: LayoutInfo -> FileSize +contentLength SingleFile { liFile = FileInfo {..} } = fiLength +contentLength MultiFile { liFiles = tfs } = L.sum (L.map fiLength tfs) + +-- | Get number of all files in torrent. +fileCount :: LayoutInfo -> Int +fileCount SingleFile {..} = 1 +fileCount MultiFile {..} = L.length liFiles + +-- | Find number of blocks of the specified size. If torrent size is +-- not a multiple of block size then the count is rounded up. +blockCount :: Int -> LayoutInfo -> Int +blockCount blkSize ci = contentLength ci `sizeInBase` blkSize + +------------------------------------------------------------------------ + +-- | File layout specifies the order and the size of each file in the +-- storage. Note that order of files is highly important since we +-- coalesce all the files in the given order to get the linear block +-- address space. +-- +type FileLayout a = [(FilePath, a)] + +-- | Extract files layout from torrent info with the given root path. +flatLayout + :: FilePath -- ^ Root path for the all torrent files. + -> LayoutInfo -- ^ Torrent content information. + -> FileLayout FileSize -- ^ The all file paths prefixed with the given root. +flatLayout prefixPath SingleFile { liFile = FileInfo {..} } + = [(prefixPath BC.unpack fiName, fiLength)] +flatLayout prefixPath MultiFile {..} = L.map mkPath liFiles + where -- TODO use utf8 encoding in name + mkPath FileInfo {..} = (path, fiLength) + where + path = prefixPath BC.unpack liDirName + joinPath (L.map BC.unpack fiName) + +-- | Calculate offset of each file based on its length, incrementally. +accumPositions :: FileLayout FileSize -> FileLayout (FileOffset, FileSize) +accumPositions = go 0 + where + go !_ [] = [] + go !offset ((n, s) : xs) = (n, (offset, s)) : go (offset + s) xs + +-- | Gives global offset of a content file for a given full path. +fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset +fileOffset = L.lookup +{-# INLINE fileOffset #-} + +------------------------------------------------------------------------ + +-- | Divide and round up. +sizeInBase :: Integral a => a -> Int -> Int +sizeInBase n b = fromIntegral (n `div` fromIntegral b) + align + where + align = if n `mod` fromIntegral b == 0 then 0 else 1 +{-# SPECIALIZE sizeInBase :: Int -> Int -> Int #-} +{-# SPECIALIZE sizeInBase :: Integer -> Int -> Int #-} + {----------------------------------------------------------------------- -- Info dictionary -----------------------------------------------------------------------} diff --git a/src/Data/Torrent/Layout.hs b/src/Data/Torrent/Layout.hs deleted file mode 100644 index cc529840..00000000 --- a/src/Data/Torrent/Layout.hs +++ /dev/null @@ -1,321 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Layout of files in torrent. --- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent.Layout - ( -- * File attributes - FileOffset - , FileSize - - -- * Single file info - , FileInfo (..) - - -- ** Lens - , fileLength - , filePath - , fileMD5Sum - - -- * File layout - , LayoutInfo (..) - , joinFilePath - - -- ** Lens - , singleFile - , multiFile - , rootDirName - - -- ** Predicates - , isSingleFile - , isMultiFile - - -- ** Query - , suggestedName - , contentLength - , fileCount - , blockCount - - -- * Flat file layout - , FileLayout - , flatLayout - , accumPositions - , fileOffset - - -- * Internal - , sizeInBase - , getLayoutInfo - , putLayoutInfo - ) where - -import Control.Applicative -import Control.DeepSeq -import Control.Lens -import Data.BEncode -import Data.BEncode.Types -import Data.ByteString as BS -import Data.ByteString.Base16 as Base16 -import Data.ByteString.Char8 as BC -import Data.Default -import Data.Foldable as F -import Data.List as L -import Data.Text as T -import Data.Text.Encoding as T -import Data.Typeable -import Text.PrettyPrint as PP -import Text.PrettyPrint.Class -import System.FilePath -import System.Posix.Types - -{----------------------------------------------------------------------- --- File attribytes ------------------------------------------------------------------------} - --- | Size of a file in bytes. -type FileSize = FileOffset - -deriving instance BEncode FileOffset - -{----------------------------------------------------------------------- --- File info both either from info dict or file list ------------------------------------------------------------------------} - --- | Contain metainfo about one single file. -data FileInfo a = FileInfo { - fiLength :: {-# UNPACK #-} !FileSize - -- ^ Length of the file in bytes. - - -- TODO unpacked MD5 sum - , fiMD5Sum :: !(Maybe ByteString) - -- ^ 32 character long MD5 sum of the file. Used by third-party - -- tools, not by bittorrent protocol itself. - - , fiName :: !a - -- ^ One or more string elements that together represent the - -- path and filename. Each element in the list corresponds to - -- either a directory name or (in the case of the last element) - -- the filename. For example, the file: - -- - -- > "dir1/dir2/file.ext" - -- - -- would consist of three string elements: - -- - -- > ["dir1", "dir2", "file.ext"] - -- - } deriving (Show, Read, Eq, Typeable - , Functor, Foldable - ) - -makeLensesFor - [ ("fiLength", "fileLength") - , ("fiMD5Sum", "fileMD5Sum") - , ("fiName" , "filePath" ) - ] - ''FileInfo - -instance NFData a => NFData (FileInfo a) where - rnf FileInfo {..} = rnf fiName - {-# INLINE rnf #-} - -instance BEncode (FileInfo [ByteString]) where - toBEncode FileInfo {..} = toDict $ - "length" .=! fiLength - .: "md5sum" .=? fiMD5Sum - .: "path" .=! fiName - .: endDict - {-# INLINE toBEncode #-} - - fromBEncode = fromDict $ do - FileInfo <$>! "length" - <*>? "md5sum" - <*>! "path" - {-# INLINE fromBEncode #-} - -type Put a = a -> BDict -> BDict - -putFileInfoSingle :: Put (FileInfo ByteString) -putFileInfoSingle FileInfo {..} cont = - "length" .=! fiLength - .: "md5sum" .=? fiMD5Sum - .: "name" .=! fiName - .: cont - -getFileInfoSingle :: Get (FileInfo ByteString) -getFileInfoSingle = do - FileInfo <$>! "length" - <*>? "md5sum" - <*>! "name" - -instance BEncode (FileInfo ByteString) where - toBEncode = toDict . (`putFileInfoSingle` endDict) - {-# INLINE toBEncode #-} - - fromBEncode = fromDict getFileInfoSingle - {-# INLINE fromBEncode #-} - -instance Pretty (FileInfo BS.ByteString) where - pretty FileInfo {..} = - "Path: " <> text (T.unpack (T.decodeUtf8 fiName)) - $$ "Size: " <> text (show fiLength) - $$ maybe PP.empty ppMD5 fiMD5Sum - where - ppMD5 md5 = "MD5 : " <> text (show (Base16.encode md5)) - --- | Join file path. -joinFilePath :: FileInfo [ByteString] -> FileInfo ByteString -joinFilePath = fmap (BS.intercalate "/") - -{----------------------------------------------------------------------- --- Original torrent file layout info ------------------------------------------------------------------------} - --- | Original (found in torrent file) layout info is either: --- --- * Single file with its /name/. --- --- * Multiple files with its relative file /paths/. --- -data LayoutInfo - = SingleFile - { -- | Single file info. - liFile :: !(FileInfo ByteString) - } - | MultiFile - { -- | List of the all files that torrent contains. - liFiles :: ![FileInfo [ByteString]] - - -- | The /suggested/ name of the root directory in which to - -- store all the files. - , liDirName :: !ByteString - } deriving (Show, Read, Eq, Typeable) - -makeLensesFor - [ ("liFile" , "singleFile" ) - , ("liFiles" , "multiFile" ) - , ("liDirName", "rootDirName") - ] - ''LayoutInfo - -instance NFData LayoutInfo where - rnf SingleFile {..} = () - rnf MultiFile {..} = rnf liFiles - --- | Empty multifile layout. -instance Default LayoutInfo where - def = MultiFile [] "" - -getLayoutInfo :: Get LayoutInfo -getLayoutInfo = single <|> multi - where - single = SingleFile <$> getFileInfoSingle - multi = MultiFile <$>! "files" <*>! "name" - -putLayoutInfo :: Put LayoutInfo -putLayoutInfo SingleFile {..} = putFileInfoSingle liFile -putLayoutInfo MultiFile {..} = \ cont -> - "files" .=! liFiles - .: "name" .=! liDirName - .: cont - -instance BEncode LayoutInfo where - toBEncode = toDict . (`putLayoutInfo` endDict) - fromBEncode = fromDict getLayoutInfo - -instance Pretty LayoutInfo where - pretty SingleFile {..} = pretty liFile - pretty MultiFile {..} = vcat $ L.map (pretty . joinFilePath) liFiles - --- | Test if this is single file torrent. -isSingleFile :: LayoutInfo -> Bool -isSingleFile SingleFile {} = True -isSingleFile _ = False -{-# INLINE isSingleFile #-} - --- | Test if this is multifile torrent. -isMultiFile :: LayoutInfo -> Bool -isMultiFile MultiFile {} = True -isMultiFile _ = False -{-# INLINE isMultiFile #-} - --- | Get name of the torrent based on the root path piece. -suggestedName :: LayoutInfo -> ByteString -suggestedName (SingleFile FileInfo {..}) = fiName -suggestedName MultiFile {..} = liDirName -{-# INLINE suggestedName #-} - --- | Find sum of sizes of the all torrent files. -contentLength :: LayoutInfo -> FileSize -contentLength SingleFile { liFile = FileInfo {..} } = fiLength -contentLength MultiFile { liFiles = tfs } = L.sum (L.map fiLength tfs) - --- | Get number of all files in torrent. -fileCount :: LayoutInfo -> Int -fileCount SingleFile {..} = 1 -fileCount MultiFile {..} = L.length liFiles - --- | Find number of blocks of the specified size. If torrent size is --- not a multiple of block size then the count is rounded up. -blockCount :: Int -> LayoutInfo -> Int -blockCount blkSize ci = contentLength ci `sizeInBase` blkSize - -{----------------------------------------------------------------------- --- Flat layout ------------------------------------------------------------------------} - --- | File layout specifies the order and the size of each file in the --- storage. Note that order of files is highly important since we --- coalesce all the files in the given order to get the linear block --- address space. --- -type FileLayout a = [(FilePath, a)] - --- | Extract files layout from torrent info with the given root path. -flatLayout - :: FilePath -- ^ Root path for the all torrent files. - -> LayoutInfo -- ^ Torrent content information. - -> FileLayout FileSize -- ^ The all file paths prefixed with the given root. -flatLayout prefixPath SingleFile { liFile = FileInfo {..} } - = [(prefixPath BC.unpack fiName, fiLength)] -flatLayout prefixPath MultiFile {..} = L.map mkPath liFiles - where -- TODO use utf8 encoding in name - mkPath FileInfo {..} = (path, fiLength) - where - path = prefixPath BC.unpack liDirName - joinPath (L.map BC.unpack fiName) - --- | Calculate offset of each file based on its length, incrementally. -accumPositions :: FileLayout FileSize -> FileLayout (FileOffset, FileSize) -accumPositions = go 0 - where - go !_ [] = [] - go !offset ((n, s) : xs) = (n, (offset, s)) : go (offset + s) xs - --- | Gives global offset of a content file for a given full path. -fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset -fileOffset = lookup -{-# INLINE fileOffset #-} - -{----------------------------------------------------------------------- --- Internal utilities ------------------------------------------------------------------------} - --- | Divide and round up. -sizeInBase :: Integral a => a -> Int -> Int -sizeInBase n b = fromIntegral (n `div` fromIntegral b) + align - where - align = if n `mod` fromIntegral b == 0 then 0 else 1 -{-# SPECIALIZE sizeInBase :: Int -> Int -> Int #-} -{-# SPECIALIZE sizeInBase :: Integer -> Int -> Int #-} diff --git a/src/Data/Torrent/Tree.hs b/src/Data/Torrent/Tree.hs index 102f4dff..5825422f 100644 --- a/src/Data/Torrent/Tree.hs +++ b/src/Data/Torrent/Tree.hs @@ -31,7 +31,7 @@ import Data.List as L import Data.Map as M import Data.Monoid -import Data.Torrent.Layout +import Data.Torrent -- | 'DirTree' is more convenient form of 'LayoutInfo'. diff --git a/src/System/Torrent/FileMap.hs b/src/System/Torrent/FileMap.hs index 80907a30..6e8d7f5a 100644 --- a/src/System/Torrent/FileMap.hs +++ b/src/System/Torrent/FileMap.hs @@ -34,7 +34,7 @@ import Data.Vector as V -- TODO use unboxed vector import Foreign import System.IO.MMap -import Data.Torrent.Layout +import Data.Torrent data FileEntry = FileEntry diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs index 003a4e98..697e3def 100644 --- a/src/System/Torrent/Storage.hs +++ b/src/System/Torrent/Storage.hs @@ -57,7 +57,7 @@ import Data.Typeable import Data.Torrent import Data.Torrent.Bitfield as BF -import Data.Torrent.Layout +import Data.Torrent import Data.Torrent.Piece import System.Torrent.FileMap as FM diff --git a/tests/Data/Torrent/LayoutSpec.hs b/tests/Data/Torrent/LayoutSpec.hs index d3966b3f..a3fe7c02 100644 --- a/tests/Data/Torrent/LayoutSpec.hs +++ b/tests/Data/Torrent/LayoutSpec.hs @@ -7,7 +7,7 @@ import Test.Hspec import Test.QuickCheck import System.Posix.Types -import Data.Torrent.Layout +import Data.Torrent instance Arbitrary COff where diff --git a/tests/Data/Torrent/MetainfoSpec.hs b/tests/Data/Torrent/MetainfoSpec.hs index 369c5e0f..537b3f99 100644 --- a/tests/Data/Torrent/MetainfoSpec.hs +++ b/tests/Data/Torrent/MetainfoSpec.hs @@ -13,9 +13,8 @@ import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () -import Data.Torrent.Piece -import Data.Torrent.Layout import Data.Torrent +import Data.Torrent.Piece import Data.Torrent.LayoutSpec () import Network.BitTorrent.Core.NodeInfoSpec () diff --git a/tests/System/Torrent/FileMapSpec.hs b/tests/System/Torrent/FileMapSpec.hs index 36632b3e..85180c0a 100644 --- a/tests/System/Torrent/FileMapSpec.hs +++ b/tests/System/Torrent/FileMapSpec.hs @@ -9,7 +9,7 @@ import System.FilePath import System.IO.Unsafe import Test.Hspec -import Data.Torrent.Layout +import Data.Torrent import System.Torrent.FileMap as FM diff --git a/tests/System/Torrent/StorageSpec.hs b/tests/System/Torrent/StorageSpec.hs index 30322545..ebf4fe3e 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.Bitfield as BF -import Data.Torrent.Layout +import Data.Torrent import Data.Torrent.Piece import System.Torrent.Storage -- 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 'src/Data') 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 efb0ee20c0253bfac87f1abbc32b5faa169acde7 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 4 Apr 2014 22:12:46 +0400 Subject: [Torrent] Tidy export list --- src/Data/Torrent.hs | 52 +++++++++++++++++++++------------------------------- 1 file changed, 21 insertions(+), 31 deletions(-) (limited to 'src/Data') diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs index 98d6f94e..ba71d334 100644 --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs @@ -38,23 +38,6 @@ module Data.Torrent , longHex , shortHex - -- * Magnet - -- $magnet-link - , Magnet(..) - , nullMagnet - , simpleMagnet - , detailedMagnet - , parseMagnet - , renderMagnet - - -- ** URN - , URN (..) - , NamespaceId - , btih - , infohashURN - , parseURN - , renderURN - -- * File layout -- ** FileInfo , FileOffset @@ -66,10 +49,10 @@ module Data.Torrent -- ** Layout info , LayoutInfo (..) - , joinFilePath , singleFile , multiFile , rootDirName + , joinFilePath , isSingleFile , isMultiFile , suggestedName @@ -104,11 +87,9 @@ module Data.Torrent -- ** Piece control , HashList (..) , PieceInfo (..) - , pieceCount - - -- ** Lens , pieceLength , pieceHashes + , pieceCount -- ** Validation , pieceHash @@ -116,13 +97,11 @@ module Data.Torrent -- * Info dictionary , InfoDict (..) - , infoDictionary - - -- ** Lenses , infohash , layoutInfo , pieceInfo , isPrivate + , infoDictionary -- * Torrent file , Torrent(..) @@ -139,19 +118,30 @@ module Data.Torrent , publisherURL , signature - -- * Construction + -- ** Utils , nullTorrent - - -- * Mime types , typeTorrent - - -- * File paths , torrentExt , isTorrentPath - - -- * IO , fromFile , toFile + + -- * Magnet + -- $magnet-link + , Magnet(..) + , nullMagnet + , simpleMagnet + , detailedMagnet + , parseMagnet + , renderMagnet + + -- ** URN + , URN (..) + , NamespaceId + , btih + , infohashURN + , parseURN + , renderURN ) where import Prelude hiding (sum) -- cgit v1.2.3 From 264a23390751a8c31e3f20f24c9019a19ef4adf0 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 4 Apr 2014 22:28:48 +0400 Subject: [Torrent] Tidy import list --- src/Data/Torrent.hs | 89 ++++++++++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 45 deletions(-) (limited to 'src/Data') diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs index ba71d334..7c56edf7 100644 --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs @@ -144,38 +144,37 @@ module Data.Torrent , renderURN ) where -import Prelude hiding (sum) +import Prelude import Control.Applicative import Control.DeepSeq import Control.Exception -import Control.Lens hiding (unsnoc) +import Control.Lens import Control.Monad -import qualified Crypto.Hash.SHA1 as C -import qualified Crypto.Hash.SHA1 as SHA1 +import 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 -import Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.Char8 as BC (pack, unpack) -import qualified Data.ByteString.Lazy as BL -import Data.Char -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 -import Data.Serialize as S -import Data.String -import Data.Text as T -import Data.Text.Encoding as T -import Data.Text.Read +import Data.ByteString as BS +import Data.ByteString.Base16 as Base16 +import Data.ByteString.Base32 as Base32 +import Data.ByteString.Base64 as Base64 +import Data.ByteString.Char8 as BC (pack, unpack) +import Data.ByteString.Lazy as BL +import Data.Char +import Data.Convertible +import Data.Default +import Data.Foldable as F +import Data.Hashable as Hashable +import Data.Int +import Data.List as L +import Data.Map as M +import Data.Maybe +import Data.Serialize as S +import Data.String +import Data.Text as T +import Data.Text.Encoding as T +import Data.Text.Read import Data.Time.Clock.POSIX import Data.Typeable import Network (HostName) @@ -330,7 +329,7 @@ data FileInfo a = FileInfo { -- ^ Length of the file in bytes. -- TODO unpacked MD5 sum - , fiMD5Sum :: !(Maybe ByteString) + , fiMD5Sum :: !(Maybe BS.ByteString) -- ^ 32 character long MD5 sum of the file. Used by third-party -- tools, not by bittorrent protocol itself. @@ -361,7 +360,7 @@ instance NFData a => NFData (FileInfo a) where rnf FileInfo {..} = rnf fiName {-# INLINE rnf #-} -instance BEncode (FileInfo [ByteString]) where +instance BEncode (FileInfo [BS.ByteString]) where toBEncode FileInfo {..} = toDict $ "length" .=! fiLength .: "md5sum" .=? fiMD5Sum @@ -377,20 +376,20 @@ instance BEncode (FileInfo [ByteString]) where type Put a = a -> BDict -> BDict -putFileInfoSingle :: Data.Torrent.Put (FileInfo ByteString) +putFileInfoSingle :: Data.Torrent.Put (FileInfo BS.ByteString) putFileInfoSingle FileInfo {..} cont = "length" .=! fiLength .: "md5sum" .=? fiMD5Sum .: "name" .=! fiName .: cont -getFileInfoSingle :: BE.Get (FileInfo ByteString) +getFileInfoSingle :: BE.Get (FileInfo BS.ByteString) getFileInfoSingle = do FileInfo <$>! "length" <*>? "md5sum" <*>! "name" -instance BEncode (FileInfo ByteString) where +instance BEncode (FileInfo BS.ByteString) where toBEncode = toDict . (`putFileInfoSingle` endDict) {-# INLINE toBEncode #-} @@ -406,7 +405,7 @@ instance Pretty (FileInfo BS.ByteString) where ppMD5 md5 = "MD5 : " <> text (show (Base16.encode md5)) -- | Join file path. -joinFilePath :: FileInfo [ByteString] -> FileInfo ByteString +joinFilePath :: FileInfo [BS.ByteString] -> FileInfo BS.ByteString joinFilePath = fmap (BS.intercalate "/") {----------------------------------------------------------------------- @@ -422,15 +421,15 @@ joinFilePath = fmap (BS.intercalate "/") data LayoutInfo = SingleFile { -- | Single file info. - liFile :: !(FileInfo ByteString) + liFile :: !(FileInfo BS.ByteString) } | MultiFile { -- | List of the all files that torrent contains. - liFiles :: ![FileInfo [ByteString]] + liFiles :: ![FileInfo [BS.ByteString]] -- | The /suggested/ name of the root directory in which to -- store all the files. - , liDirName :: !ByteString + , liDirName :: !BS.ByteString } deriving (Show, Read, Eq, Typeable) makeLensesFor @@ -482,7 +481,7 @@ isMultiFile _ = False {-# INLINE isMultiFile #-} -- | Get name of the torrent based on the root path piece. -suggestedName :: LayoutInfo -> ByteString +suggestedName :: LayoutInfo -> BS.ByteString suggestedName (SingleFile FileInfo {..}) = fiName suggestedName MultiFile {..} = liDirName {-# INLINE suggestedName #-} @@ -520,9 +519,9 @@ flatLayout prefixPath SingleFile { liFile = FileInfo {..} } = [(prefixPath BC.unpack fiName, fiLength)] flatLayout prefixPath MultiFile {..} = L.map mkPath liFiles where -- TODO use utf8 encoding in name - mkPath FileInfo {..} = (path, fiLength) + mkPath FileInfo {..} = (_path, fiLength) where - path = prefixPath BC.unpack liDirName + _path = prefixPath BC.unpack liDirName joinPath (L.map BC.unpack fiName) -- | Calculate offset of each file based on its length, incrementally. @@ -597,7 +596,7 @@ defaultPieceSize x = max minPieceSize $ min maxPieceSize $ toPow2 pc -- Piece data -----------------------------------------------------------------------} -type PieceHash = ByteString +type PieceHash = BS.ByteString hashsize :: Int hashsize = 20 @@ -632,7 +631,7 @@ hashPiece Piece {..} = SHA1.hashlazy pieceData -----------------------------------------------------------------------} -- | A flat array of SHA1 hash for each piece. -newtype HashList = HashList { unHashList :: ByteString } +newtype HashList = HashList { unHashList :: BS.ByteString } deriving (Show, Read, Eq, BEncode, Typeable) -- | Empty hash list. @@ -688,7 +687,7 @@ instance BEncode PieceInfo where instance Pretty PieceInfo where pretty PieceInfo {..} = "Piece size: " <> int piPieceLength -slice :: Int -> Int -> ByteString -> ByteString +slice :: Int -> Int -> BS.ByteString -> BS.ByteString slice start len = BS.take len . BS.drop start {-# INLINE slice #-} @@ -773,7 +772,7 @@ putPrivate True = \ cont -> "private" .=! True .: cont -- | Hash lazy bytestring using SHA1 algorithm. hashLazyIH :: BL.ByteString -> InfoHash -hashLazyIH = either (const (error msg)) id . safeConvert . C.hashlazy +hashLazyIH = either (const (error msg)) id . safeConvert . SHA1.hashlazy where msg = "Infohash.hash: impossible: SHA1 is always 20 bytes long" @@ -850,7 +849,7 @@ data Torrent = Torrent -- authority to allow new peers onto the swarm. , tPublisherURL :: !(Maybe URI) - , tSignature :: !(Maybe ByteString) + , tSignature :: !(Maybe BS.ByteString) -- ^ The RSA signature of the info dictionary (specifically, the -- encrypted SHA-1 hash of the info dictionary). } deriving (Show, Eq, Typeable) @@ -1049,15 +1048,15 @@ instance QueryValueLike URN where ----------------------------------------------------------------------- -unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc xs = Just (L.init xs, L.last xs) +_unsnoc :: [a] -> Maybe ([a], a) +_unsnoc [] = Nothing +_unsnoc xs = Just (L.init xs, L.last xs) instance Convertible Text URN where safeConvert t = case T.split (== ':') t of uriScheme : body | T.toLower uriScheme == "urn" -> - case unsnoc body of + case _unsnoc body of Just (namespace, val) -> pure URN { urnNamespace = namespace , urnString = val -- 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 'src/Data') 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 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 'src/Data') 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 11fca56c179ce2da7d279293a6b3c7d1bb35c74c Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 8 Apr 2014 04:53:22 +0400 Subject: Hide Tree.hs module --- bittorrent.cabal | 3 +- src/Data/Torrent/Tree.hs | 83 ---------------------------------------------- src/System/Torrent/Tree.hs | 83 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 85 insertions(+), 84 deletions(-) delete mode 100644 src/Data/Torrent/Tree.hs create mode 100644 src/System/Torrent/Tree.hs (limited to 'src/Data') diff --git a/bittorrent.cabal b/bittorrent.cabal index 292680dd..0ceec550 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -50,7 +50,6 @@ library hs-source-dirs: src exposed-modules: Data.Torrent Data.Torrent.Progress - Data.Torrent.Tree Network.BitTorrent Network.BitTorrent.Address Network.BitTorrent.Client @@ -87,11 +86,13 @@ library Network.BitTorrent.Internal.Cache Network.BitTorrent.Internal.Types System.Torrent.FileMap + System.Torrent.Tree else other-modules: Network.BitTorrent.Internal.Cache Network.BitTorrent.Internal.Types System.Torrent.FileMap + System.Torrent.Tree build-depends: base == 4.* , lifted-base diff --git a/src/Data/Torrent/Tree.hs b/src/Data/Torrent/Tree.hs deleted file mode 100644 index 5825422f..00000000 --- a/src/Data/Torrent/Tree.hs +++ /dev/null @@ -1,83 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Directory tree can be used to easily manipulate file layout info. --- -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Data.Torrent.Tree - ( -- * Directory tree - DirTree (..) - - -- * Construction - , build - - -- * Query - , Data.Torrent.Tree.lookup - , lookupDir - , fileNumber - , dirNumber - ) where - -import Data.ByteString as BS -import Data.ByteString.Char8 as BC -import Data.Foldable -import Data.List as L -import Data.Map as M -import Data.Monoid - -import Data.Torrent - - --- | 'DirTree' is more convenient form of 'LayoutInfo'. -data DirTree a = Dir { children :: Map ByteString (DirTree a) } - | File { node :: FileInfo a } - deriving Show - --- | Build directory tree from a list of files. -build :: LayoutInfo -> DirTree () -build SingleFile {liFile = FileInfo {..}} = Dir - { children = M.singleton fiName (File fi) } - where - fi = FileInfo fiLength fiMD5Sum () -build MultiFile {..} = Dir $ M.singleton liDirName files - where - files = Dir $ M.fromList $ L.map mkFileEntry liFiles - mkFileEntry FileInfo {..} = (L.head fiName, ent) -- TODO FIXME - where - ent = File $ FileInfo fiLength fiMD5Sum () - ---decompress :: DirTree () -> [FileInfo ()] ---decompress = undefined - --- TODO pretty print - --- | Lookup file by path. -lookup :: [FilePath] -> DirTree a -> Maybe (DirTree a) -lookup [] t = Just t -lookup (p : ps) (Dir m) | Just subTree <- M.lookup (BC.pack p) m - = Data.Torrent.Tree.lookup ps subTree -lookup _ _ = Nothing - --- | Lookup directory by path. -lookupDir :: [FilePath] -> DirTree a -> Maybe [(ByteString, DirTree a)] -lookupDir ps d = do - subTree <- Data.Torrent.Tree.lookup ps d - case subTree of - File _ -> Nothing - Dir es -> Just $ M.toList es - --- | Get total count of files in directory and subdirectories. -fileNumber :: DirTree a -> Sum Int -fileNumber File {..} = Sum 1 -fileNumber Dir {..} = foldMap fileNumber children - --- | Get total count of directories in the directory and subdirectories. -dirNumber :: DirTree a -> Sum Int -dirNumber File {..} = Sum 0 -dirNumber Dir {..} = Sum 1 <> foldMap dirNumber children diff --git a/src/System/Torrent/Tree.hs b/src/System/Torrent/Tree.hs new file mode 100644 index 00000000..41cfb360 --- /dev/null +++ b/src/System/Torrent/Tree.hs @@ -0,0 +1,83 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Directory tree can be used to easily manipulate file layout info. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +module System.Torrent.Tree + ( -- * Directory tree + DirTree (..) + + -- * Construction + , build + + -- * Query + , System.Torrent.Tree.lookup + , lookupDir + , fileNumber + , dirNumber + ) where + +import Data.ByteString as BS +import Data.ByteString.Char8 as BC +import Data.Foldable +import Data.List as L +import Data.Map as M +import Data.Monoid + +import Data.Torrent + + +-- | 'DirTree' is more convenient form of 'LayoutInfo'. +data DirTree a = Dir { children :: Map ByteString (DirTree a) } + | File { node :: FileInfo a } + deriving Show + +-- | Build directory tree from a list of files. +build :: LayoutInfo -> DirTree () +build SingleFile {liFile = FileInfo {..}} = Dir + { children = M.singleton fiName (File fi) } + where + fi = FileInfo fiLength fiMD5Sum () +build MultiFile {..} = Dir $ M.singleton liDirName files + where + files = Dir $ M.fromList $ L.map mkFileEntry liFiles + mkFileEntry FileInfo {..} = (L.head fiName, ent) -- TODO FIXME + where + ent = File $ FileInfo fiLength fiMD5Sum () + +--decompress :: DirTree () -> [FileInfo ()] +--decompress = undefined + +-- TODO pretty print + +-- | Lookup file by path. +lookup :: [FilePath] -> DirTree a -> Maybe (DirTree a) +lookup [] t = Just t +lookup (p : ps) (Dir m) | Just subTree <- M.lookup (BC.pack p) m + = System.Torrent.Tree.lookup ps subTree +lookup _ _ = Nothing + +-- | Lookup directory by path. +lookupDir :: [FilePath] -> DirTree a -> Maybe [(ByteString, DirTree a)] +lookupDir ps d = do + subTree <- System.Torrent.Tree.lookup ps d + case subTree of + File _ -> Nothing + Dir es -> Just $ M.toList es + +-- | Get total count of files in directory and subdirectories. +fileNumber :: DirTree a -> Sum Int +fileNumber File {..} = Sum 1 +fileNumber Dir {..} = foldMap fileNumber children + +-- | Get total count of directories in the directory and subdirectories. +dirNumber :: DirTree a -> Sum Int +dirNumber File {..} = Sum 0 +dirNumber Dir {..} = Sum 1 <> foldMap dirNumber children -- 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 'src/Data') 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