diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2013-11-25 Sam Truzjan + + * Version 0.0.0.3 + * use Pretty class from pretty-class package; + * Data.Torrent.Client.hs: + * /tests/: fixed; + 2013-11-21 Sam Truzjan Version 0.0.0.2 diff --git a/bittorrent.cabal b/bittorrent.cabal --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -1,5 +1,5 @@ name: bittorrent -version: 0.0.0.2 +version: 0.0.0.3 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -33,7 +33,7 @@ type: git location: git://github.com/cobit/bittorrent.git branch: master - tag: v0.0.0.2 + tag: v0.0.0.3 library default-language: Haskell2010 @@ -55,13 +55,11 @@ , Network.BitTorrent.Core.PeerAddr -- , System.IO.MMap.Fixed -- , System.Torrent.Storage - -- Network.BitTorrent -- , Network.BitTorrent.Extension - -- , Network.BitTorrent.Peer -- , Network.BitTorrent.Tracker --- , Network.BitTorrent.Tracker.Protocol +-- , Network.BitTorrent.Tracker.Message -- , Network.BitTorrent.Tracker.HTTP -- , Network.BitTorrent.Tracker.UDP -- , Network.BitTorrent.Exchange @@ -69,12 +67,13 @@ -- , Network.BitTorrent.DHT -- , Network.BitTorrent.DHT.Protocol -- , Network.BitTorrent.Sessions --- other-modules: Network.BitTorrent.Sessions.Types --- Paths_bittorrent +-- Network.BitTorrent.Sessions.Types + other-modules: Paths_bittorrent build-depends: base == 4.* , bits-extras , pretty + , pretty-class -- Control , deepseq @@ -100,6 +99,7 @@ , data-default , IntervalMap , intset + , split , text >= 0.11.0 , unordered-containers , vector @@ -143,10 +143,15 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Spec.hs + other-modules: Data.Torrent.MagnetSpec + Data.Torrent.InfoHashSpec + Data.Torrent.MetainfoSpec + Data.Torrent.ClientSpec build-depends: base == 4.* , bytestring , directory , filepath + , time , aeson , cereal diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs @@ -26,7 +26,7 @@ module Data.Torrent ( -- * Info dictionary InfoDict (..) - , ppInfoDict + , infoDictionary -- ** Lenses , infohash @@ -36,7 +36,6 @@ -- * Torrent file , Torrent(..) - , ppTorrent -- ** Lenses , announce @@ -66,12 +65,10 @@ ) where import Prelude hiding (sum) - import Control.Applicative import Control.DeepSeq import Control.Exception import Control.Lens - import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..), withText) import Data.Aeson.TH import Data.BEncode as BE @@ -88,6 +85,7 @@ import Data.Typeable import Network.URI import Text.PrettyPrint as PP +import Text.PrettyPrint.Class import System.FilePath import Data.Torrent.InfoHash as IH @@ -134,6 +132,13 @@ hash = Hashable.hash . idInfoHash {-# INLINE hash #-} +-- | Smart constructor: add a info hash to info dictionary. +infoDictionary :: LayoutInfo -> PieceInfo -> Bool -> InfoDict +infoDictionary li pinfo private = InfoDict ih li pinfo private + where + ih = IH.hashlazy $ encode $ InfoDict fake_ih li pinfo private + fake_ih = InfoHash "" + getPrivate :: Get Bool getPrivate = (Just True ==) <$>? "private" @@ -156,18 +161,16 @@ ih = IH.hashlazy (encode dict) ppPrivacy :: Bool -> Doc -ppPrivacy privacy = - "Privacy: " <> if privacy then "private" else "public" +ppPrivacy privacy = "Privacy: " <> if privacy then "private" else "public" -ppAdditionalInfo :: InfoDict -> Doc -ppAdditionalInfo layout = PP.empty +--ppAdditionalInfo :: InfoDict -> Doc +--ppAdditionalInfo layout = PP.empty --- | Format info dictionary in human-readable form. -ppInfoDict :: InfoDict -> Doc -ppInfoDict InfoDict {..} = - ppLayoutInfo idLayoutInfo $$ - ppPieceInfo idPieceInfo $$ - ppPrivacy idPrivate +instance Pretty InfoDict where + pretty InfoDict {..} = + pretty idLayoutInfo $$ + pretty idPieceInfo $$ + ppPrivacy idPrivate {----------------------------------------------------------------------- -- Torrent info @@ -251,6 +254,9 @@ fromBEncode b = decodingError $ "url <" ++ show b ++ ">" {-# INLINE fromBEncode #-} +--pico2uni :: Pico -> Uni +--pico2uni = undefined + -- TODO move to bencoding instance BEncode POSIXTime where toBEncode pt = toBEncode (floor pt :: Integer) @@ -290,13 +296,13 @@ _ <:>? Nothing = PP.empty name <:>? (Just d) = name <:> d -ppTorrent :: Torrent -> Doc -ppTorrent Torrent {..} = - "InfoHash: " <> ppInfoHash (idInfoHash tInfoDict) +instance Pretty Torrent where + pretty Torrent {..} = + "InfoHash: " <> pretty (idInfoHash tInfoDict) $$ hang "General" 4 generalInfo $$ hang "Tracker" 4 trackers - $$ ppInfoDict tInfoDict - where + $$ pretty tInfoDict + where trackers = case tAnnounceList of Nothing -> text (show tAnnounce) Just xxs -> vcat $ L.map ppTier $ L.zip [1..] xxs diff --git a/src/Data/Torrent/Block.hs b/src/Data/Torrent/Block.hs --- a/src/Data/Torrent/Block.hs +++ b/src/Data/Torrent/Block.hs @@ -9,6 +9,7 @@ -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} module Data.Torrent.Block ( -- * Piece attributes PieceIx @@ -22,31 +23,26 @@ -- * Block index , BlockIx(..) - , ppBlockIx , blockIxRange -- * Block data , Block(..) - , ppBlock , blockIx , blockSize , blockRange ) where import Control.Applicative - import Data.Aeson.TH import qualified Data.ByteString.Lazy as Lazy import Data.Char import Data.List as L - import Data.Binary as B import Data.Binary.Get as B import Data.Binary.Put as B import Data.Serialize as S - import Text.PrettyPrint - +import Text.PrettyPrint.Class {----------------------------------------------------------------------- -- Piece attributes @@ -147,12 +143,11 @@ putIntB ixOffset putIntB ixLength --- | Format block index in human readable form. -ppBlockIx :: BlockIx -> Doc -ppBlockIx BlockIx {..} = - "piece = " <> int ixPiece <> "," <+> - "offset = " <> int ixOffset <> "," <+> - "length = " <> int ixLength +instance Pretty BlockIx where + pretty BlockIx {..} = + "piece = " <> int ixPiece <> "," <+> + "offset = " <> int ixOffset <> "," <+> + "length = " <> int ixLength -- | Get location of payload bytes in the torrent content. blockIxRange :: (Num a, Integral a) => PieceSize -> BlockIx -> (a, a) @@ -178,10 +173,10 @@ , blkData :: !payload } deriving (Show, Eq) --- | Format block in human readable form. Payload is ommitted. -ppBlock :: Block Lazy.ByteString -> Doc -ppBlock = ppBlockIx . blockIx -{-# INLINE ppBlock #-} +-- | Payload is ommitted. +instance Pretty (Block Lazy.ByteString) where + pretty = pretty . blockIx + {-# INLINE pretty #-} -- | Get size of block /payload/ in bytes. blockSize :: Block Lazy.ByteString -> BlockSize diff --git a/src/Data/Torrent/Client.hs b/src/Data/Torrent/Client.hs --- a/src/Data/Torrent/Client.hs +++ b/src/Data/Torrent/Client.hs @@ -21,17 +21,8 @@ -- done using 'Network.BitTorrent.Extension'! -- module Data.Torrent.Client - ( -- * Client implementation - ClientImpl (..) - , ppClientImpl - - -- * Client version - , ClientVersion (..) - , ppClientVersion - - -- * Client information + ( ClientImpl (..) , ClientInfo (..) - , ppClientInfo , libClientInfo ) where @@ -40,10 +31,15 @@ import Data.ByteString.Char8 as BC import Data.Default import Data.List as L +import Data.List.Split as L +import Data.Maybe import Data.Monoid +import Data.String import Data.Text as T import Data.Version import Text.PrettyPrint hiding ((<>)) +import Text.PrettyPrint.Class +import Text.Read (readMaybe) import Paths_bittorrent (version) @@ -54,6 +50,22 @@ -- data ClientImpl = IUnknown + + | IMainline + + | IABC + | IOspreyPermaseed + | IBTQueue + | ITribler + | IShadow + | IBitTornado + +-- UPnP(!) Bit Torrent !??? +-- 'U' - UPnP NAT Bit Torrent + | IBitLord + | IOpera + | IMLdonkey + | IAres | IArctic | IAvicora @@ -117,45 +129,62 @@ -- | Used to represent a not recognized implementation instance Default ClientImpl where def = IUnknown + {-# INLINE def #-} --- | Format client implementation info in human-readable form. -ppClientImpl :: ClientImpl -> Doc -ppClientImpl = text . L.tail . show +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) --- | Version of client software, normally extracted from peer id. -newtype ClientVersion = ClientVersion { getClientVersion :: Version } - deriving (Show, Eq, Ord) +instance Pretty ClientImpl where + pretty = text . L.tail . show -- | Just the '0' version. -instance Default ClientVersion where - def = ClientVersion $ Version [0] [] +instance Default Version where + def = Version [0] [] + {-# INLINE def #-} --- | Format client implementation version in human-readable form. -ppClientVersion :: ClientVersion -> Doc -ppClientVersion = text . showVersion . getClientVersion +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 ClientInfo = ClientInfo { ciImpl :: ClientImpl - , ciVersion :: ClientVersion + , ciVersion :: Version } deriving (Show, Eq, Ord) -- | Unrecognized client implementation. instance Default ClientInfo where def = ClientInfo def def + {-# INLINE def #-} --- | Format client info in human-readable form. -ppClientInfo :: ClientInfo -> Doc -ppClientInfo ClientInfo {..} = - ppClientImpl ciImpl <+> "version" <+> ppClientVersion ciVersion +instance IsString ClientInfo where + fromString str + | _ : ver <- _ver = ClientInfo (fromString impl) (fromString ver) + | otherwise = error $ "fromString: invalid client info string" ++ str + where + (impl, _ver) = L.span ((/=) '-') str +instance Pretty ClientInfo where + pretty ClientInfo {..} = pretty ciImpl <+> "version" <+> pretty ciVersion + -- | Client info of this (the bittorrent library) package. Normally, -- applications should introduce its own idenitifiers, otherwise they -- can use 'libClientInfo' value. -- libClientInfo :: ClientInfo -libClientInfo = ClientInfo IlibHSbittorrent (ClientVersion version) +libClientInfo = ClientInfo IlibHSbittorrent version {----------------------------------------------------------------------- -- For torrent file @@ -164,7 +193,7 @@ renderImpl :: ClientImpl -> Text renderImpl = T.pack . L.tail . show -renderVersion :: ClientVersion -> Text +renderVersion :: Version -> Text renderVersion = undefined renderClientInfo :: ClientInfo -> Text diff --git a/src/Data/Torrent/InfoHash.hs b/src/Data/Torrent/InfoHash.hs --- a/src/Data/Torrent/InfoHash.hs +++ b/src/Data/Torrent/InfoHash.hs @@ -19,11 +19,9 @@ -- * Rendering , longHex , shortHex - , ppInfoHash , addHashToURI - , Data.Torrent.InfoHash.hash , Data.Torrent.InfoHash.hashlazy ) where @@ -52,6 +50,7 @@ import Numeric import Text.ParserCombinators.ReadP as P import Text.PrettyPrint +import Text.PrettyPrint.Class -- | Exactly 20 bytes long SHA1 hash of the info part of torrent file. @@ -60,7 +59,7 @@ -- | for hex encoded strings instance Show InfoHash where - show = render . ppInfoHash + show = render . pretty -- | for hex encoded strings instance Read InfoHash where @@ -106,6 +105,10 @@ instance URLShow InfoHash where urlShow = show +-- | base16 encoded. +instance Pretty InfoHash where + pretty = text . BC.unpack . ppHex . getInfoHash + -- | Tries both base16 and base32 while decoding info hash. textToInfoHash :: Text -> Maybe InfoHash textToInfoHash text @@ -126,10 +129,6 @@ -- | The same as 'longHex', but 7 character long. shortHex :: InfoHash -> Text shortHex = T.take 7 . longHex - --- | Pretty print info hash in hexadecimal format. -ppInfoHash :: InfoHash -> Doc -ppInfoHash = text . BC.unpack . ppHex . getInfoHash ppHex :: BS.ByteString -> BS.ByteString ppHex = BL.toStrict . B.toLazyByteString . B.byteStringHexFixed diff --git a/src/Data/Torrent/Layout.hs b/src/Data/Torrent/Layout.hs --- a/src/Data/Torrent/Layout.hs +++ b/src/Data/Torrent/Layout.hs @@ -24,7 +24,6 @@ -- * Single file info , FileInfo (..) - , ppFileInfo -- ** Lens , fileLength @@ -33,7 +32,6 @@ -- * File layout , LayoutInfo (..) - , ppLayoutInfo , joinFilePath -- ** Lens @@ -78,6 +76,7 @@ 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 @@ -175,13 +174,12 @@ fromBEncode = fromDict getFileInfoSingle {-# INLINE fromBEncode #-} --- | Format 'FileInfo' in human-readable form. -ppFileInfo :: FileInfo ByteString -> Doc -ppFileInfo FileInfo {..} = +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 + where ppMD5 md5 = "MD5 : " <> text (show (InfoHash md5)) -- | Join file path. @@ -242,10 +240,9 @@ toBEncode = toDict . (`putLayoutInfo` endDict) fromBEncode = fromDict getLayoutInfo --- | Format 'LayoutInfo' in human readable form. -ppLayoutInfo :: LayoutInfo -> Doc -ppLayoutInfo SingleFile {..} = ppFileInfo liFile -ppLayoutInfo MultiFile {..} = vcat $ L.map (ppFileInfo . joinFilePath) liFiles +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 diff --git a/src/Data/Torrent/Magnet.hs b/src/Data/Torrent/Magnet.hs --- a/src/Data/Torrent/Magnet.hs +++ b/src/Data/Torrent/Magnet.hs @@ -43,6 +43,8 @@ import Data.Text.Encoding as T import Network.URI import Text.Read +import Text.PrettyPrint as PP +import Text.PrettyPrint.Class import Data.Torrent import Data.Torrent.InfoHash @@ -147,6 +149,9 @@ instance URLEncode Magnet where urlEncode = toQuery {-# INLINE urlEncode #-} + +instance Pretty Magnet where + pretty = PP.text . renderMagnet -- | Set exact topic only, other params are empty. nullMagnet :: InfoHash -> Magnet diff --git a/src/Data/Torrent/Piece.hs b/src/Data/Torrent/Piece.hs --- a/src/Data/Torrent/Piece.hs +++ b/src/Data/Torrent/Piece.hs @@ -21,13 +21,12 @@ -- * Piece data , Piece (..) - , ppPiece , pieceSize , isPiece -- * Piece control + , HashArray (..) , PieceInfo (..) - , ppPieceInfo , pieceCount -- * Lens @@ -61,6 +60,7 @@ import Data.Text.Encoding as T import Data.Typeable import Text.PrettyPrint +import Text.PrettyPrint.Class import Data.Torrent.Block @@ -121,10 +121,9 @@ instance NFData (Piece a) --- | Format piece in human readable form. Payload bytes are omitted. -ppPiece :: Piece a -> Doc -ppPiece Piece {..} - = "Piece" <+> braces ("index" <+> "=" <+> int pieceIndex) +-- | 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 @@ -140,6 +139,7 @@ -- Piece control -----------------------------------------------------------------------} +-- | A flat array of SHA1 sums of each piece. newtype HashArray = HashArray { unHashArray :: ByteString } deriving (Show, Read, Eq, BEncode) @@ -192,10 +192,9 @@ toBEncode = toDict . (`putPieceInfo` endDict) fromBEncode = fromDict getPieceInfo --- | Format piece info in human readable form. Hashes are omitted. -ppPieceInfo :: PieceInfo -> Doc -ppPieceInfo PieceInfo {..} = - "Piece size: " <> int piPieceLength +-- | Hashes are omitted. +instance Pretty PieceInfo where + pretty PieceInfo {..} = "Piece size: " <> int piPieceLength hashsize :: Int hashsize = 20 diff --git a/src/Data/Torrent/Progress.hs b/src/Data/Torrent/Progress.hs --- a/src/Data/Torrent/Progress.hs +++ b/src/Data/Torrent/Progress.hs @@ -34,14 +34,17 @@ ) where import Control.Applicative -import Control.Lens +import Control.Lens hiding ((%=)) import Data.Aeson.TH import Data.Default import Data.List as L import Data.Monoid import Data.Serialize as S import Data.Ratio +import Data.URLEncoded import Data.Word +import Text.PrettyPrint as PP +import Text.PrettyPrint.Class -- | Progress data is considered as dynamic within one client @@ -58,6 +61,7 @@ $(makeLenses ''Progress) $(deriveJSON L.tail ''Progress) +-- | UDP tracker compatible encoding. instance Serialize Progress where put Progress {..} = do putWord64be $ fromIntegral _downloaded @@ -73,6 +77,7 @@ def = Progress 0 0 0 {-# INLINE def #-} +-- | Can be used to aggregate total progress. instance Monoid Progress where mempty = def {-# INLINE mempty #-} @@ -83,6 +88,25 @@ , _uploaded = ua + ub } {-# INLINE mappend #-} + +instance URLShow Word64 where + urlShow = show + {-# INLINE urlShow #-} + +-- | HTTP Tracker protocol compatible encoding. +instance URLEncode Progress where + urlEncode Progress {..} = mconcat + [ s "uploaded" %= _uploaded + , s "left" %= _left + , s "downloaded" %= _downloaded + ] + where s :: String -> String; s = id; {-# INLINE s #-} + +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. -- diff --git a/src/Data/Torrent/Tree.hs b/src/Data/Torrent/Tree.hs --- a/src/Data/Torrent/Tree.hs +++ b/src/Data/Torrent/Tree.hs @@ -55,6 +55,8 @@ --decompress :: DirTree () -> [FileInfo ()] --decompress = undefined +-- TODO pretty print + -- | Lookup file by path. lookup :: [FilePath] -> DirTree a -> Maybe (DirTree a) lookup [] t = Just t diff --git a/src/Network/BitTorrent/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs --- a/src/Network/BitTorrent/Core/PeerAddr.hs +++ b/src/Network/BitTorrent/Core/PeerAddr.hs @@ -16,10 +16,9 @@ module Network.BitTorrent.Core.PeerAddr ( -- * Peer address PeerAddr(..) - , getCompactPeerList + , defaultPorts , peerSockAddr , connectToPeer - , ppPeer ) where import Control.Applicative @@ -34,6 +33,7 @@ import Data.Word import Network.Socket import Text.PrettyPrint +import Text.PrettyPrint.Class import Data.Torrent.Client import Network.BitTorrent.Core.PeerId @@ -80,16 +80,26 @@ -- | The tracker "compact peer list" compatible encoding. The -- 'peerId' is always 'Nothing'. +-- +-- For more info see: +-- instance Serialize PeerAddr where put PeerAddr {..} = put peerID >> put peerPort {-# INLINE put #-} get = PeerAddr Nothing <$> get <*> get {-# INLINE get #-} --- | For more info see: -getCompactPeerList :: S.Get [PeerAddr] -getCompactPeerList = many get +instance Pretty PeerAddr where + pretty p @ PeerAddr {..} + | Just pid <- peerID = pretty (clientInfo pid) <+> "at" <+> paddr + | otherwise = paddr + where + paddr = text (show (peerSockAddr p)) +-- | Ports typically reserved for bittorrent P2P listener. +defaultPorts :: [PortNumber] +defaultPorts = [6881..6889] + -- TODO make platform independent, clarify htonl -- | Convert peer info from tracker response to socket address. Used @@ -114,11 +124,3 @@ sock <- socket AF_INET Stream Network.Socket.defaultProtocol connect sock (peerSockAddr p) return sock - --- | Pretty print peer address in human readable form. -ppPeer :: PeerAddr -> Doc -ppPeer p @ PeerAddr {..} - | Just pid <- peerID = ppClientInfo (clientInfo pid) <+> "at" <+> paddr - | otherwise = paddr - where - paddr = text (show (peerSockAddr p)) diff --git a/src/Network/BitTorrent/Core/PeerId.hs b/src/Network/BitTorrent/Core/PeerId.hs --- a/src/Network/BitTorrent/Core/PeerId.hs +++ b/src/Network/BitTorrent/Core/PeerId.hs @@ -16,7 +16,6 @@ module Network.BitTorrent.Core.PeerId ( -- * PeerId PeerId (getPeerId) - , ppPeerId -- * Generation , genPeerId @@ -40,15 +39,18 @@ import Data.Aeson 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.Default import Data.Foldable (foldMap) import Data.List as L -import Data.Maybe (fromMaybe) +import Data.List.Split as L +import Data.Maybe (fromMaybe, catMaybes) import Data.Monoid import Data.Serialize as S +import Data.String import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime) import Data.URLEncoded @@ -56,6 +58,7 @@ import System.Entropy (getEntropy) import System.Locale (defaultTimeLocale) import Text.PrettyPrint hiding ((<>)) +import Text.PrettyPrint.Class import Text.Read (readMaybe) import Paths_bittorrent (version) @@ -74,10 +77,17 @@ instance URLShow PeerId where urlShow = BC.unpack . getPeerId --- | Format peer id in human readable form. -ppPeerId :: PeerId -> Doc -ppPeerId = text . BC.unpack . getPeerId +instance IsString PeerId where + fromString str + | BS.length bs == 20 = 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 + {----------------------------------------------------------------------- -- Encoding -----------------------------------------------------------------------} @@ -237,6 +247,7 @@ f "MO" = IMonoTorrent f "MP" = IMooPolice f "MR" = IMiro + f "ML" = IMLdonkey f "MT" = IMoonlightTorrent f "NX" = INetTransport f "PD" = IPando @@ -265,15 +276,74 @@ 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'. -- clientInfo :: PeerId -> ClientInfo clientInfo pid = either (const def) id $ runGet getCI (getPeerId pid) - where -- TODO other styles - getCI = getWord8 >> ClientInfo <$> getClientImpl <*> getClientVersion - getClientImpl = parseImpl <$> getByteString 2 - getClientVersion = mkVer <$> getByteString 4 + where + getCI = do + leading <- BS.w2c <$> getWord8 + case leading of + '-' -> ClientInfo <$> getAzureusImpl <*> getAzureusVersion + 'M' -> ClientInfo <$> pure IMainline <*> getMainlineVersion + 'e' -> ClientInfo <$> getBitCometImpl <*> getBitCometVersion + 'F' -> ClientInfo <$> getBitCometImpl <*> getBitCometVersion + c -> do + c1 <- w2c <$> lookAhead getWord8 + if c1 == 'P' + then do + _ <- getWord8 + ClientInfo <$> pure IOpera <*> getOperaVersion + else ClientInfo <$> 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 = ClientVersion $ Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] [] + mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] [] + + getBitCometImpl = do + bs <- getByteString 3 + 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/tests/Data/Torrent/ClientSpec.hs b/tests/Data/Torrent/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Torrent/ClientSpec.hs @@ -0,0 +1,33 @@ +-- | see +module Data.Torrent.ClientSpec (spec) where +import Test.Hspec +import Network.BitTorrent.Core.PeerId + +spec :: Spec +spec = do + describe "client info" $ do + it "decode mainline encoded peer id" $ do + clientInfo "M4-3-6--xxxxxxxxxxxx" `shouldBe` "Mainline-4.3.6" + clientInfo "M4-20-8-xxxxxxxxxxxx" `shouldBe` "Mainline-4.20.8" + + it "decode azureus encoded peer id" $ do + clientInfo "-AZ2060-xxxxxxxxxxxx" `shouldBe` "Azureus-2060" + clientInfo "-BS0000-xxxxxxxxxxxx" `shouldBe` "BTSlave-0" + + it "decode Shad0w style peer id" $ do + clientInfo "S58B-----xxxxxxxxxxx" `shouldBe` "Shadow-5.8.11" + clientInfo "T58B-----xxxxxxxxxxx" `shouldBe` "BitTornado-5.8.11" + + it "decode bitcomet style peer id" $ do + clientInfo "exbc01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49" + clientInfo "FUTB01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49" + clientInfo "exbc01LORDxxxxxxxxxx" `shouldBe` "BitLord-48.49" + + it "decode opera style peer id" $ do + clientInfo "OP0123xxxxxxxxxxxxxx" `shouldBe` "Opera-123" + + it "decode ML donkey style peer id" $ do + clientInfo "-ML2.7.2-xxxxxxxxxxx" `shouldBe` "MLdonkey-0" + +-- TODO XBT, Bits on Wheels, Queen Bee, BitTyrant, TorrenTopia, +-- BitSpirit, Rufus, G3 Torrent, FlashGet diff --git a/tests/Data/Torrent/InfoHashSpec.hs b/tests/Data/Torrent/InfoHashSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Torrent/InfoHashSpec.hs @@ -0,0 +1,36 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Data.Torrent.InfoHashSpec (spec) where + +import Control.Applicative +import System.FilePath +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Data.Torrent +import Data.Torrent.InfoHash as IH + + +instance Arbitrary InfoHash where + arbitrary = IH.hash <$> arbitrary + +type TestPair = (FilePath, String) + +-- TODO add a few more torrents here +torrentList :: [TestPair] +torrentList = + [ ( "res" "dapper-dvd-amd64.iso.torrent" + , "0221caf96aa3cb94f0f58d458e78b0fc344ad8bf") + ] + +infohashSpec :: (FilePath, String) -> Spec +infohashSpec (filepath, expectedHash) = do + it ("should match " ++ filepath) $ do + torrent <- fromFile filepath + let actualHash = show $ idInfoHash $ tInfoDict torrent + actualHash `shouldBe` expectedHash + +spec :: Spec +spec = do + describe "info hash" $ do + mapM_ infohashSpec torrentList diff --git a/tests/Data/Torrent/MagnetSpec.hs b/tests/Data/Torrent/MagnetSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Torrent/MagnetSpec.hs @@ -0,0 +1,45 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Data.Torrent.MagnetSpec (spec) where + +import Control.Applicative +import Data.Maybe +import Data.Monoid +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Network.URI + +import Data.Torrent.InfoHash +import Data.Torrent.Magnet +import Data.Torrent.InfoHashSpec () + + +instance Arbitrary URIAuth where + arbitrary = URIAuth <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary URI where + arbitrary + = pure $ fromJust $ parseURI "http://ietf.org/1737.txt?a=1&b=h#123" + +instance Arbitrary Magnet where + arbitrary = Magnet <$> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> pure mempty + +magnetEncoding :: Magnet -> Bool +magnetEncoding m = parseMagnet (renderMagnet m) == Just m + +spec :: Spec +spec = do + describe "Magnet" $ do + it "properly encoded" $ property $ magnetEncoding + + it "parse base32" $ do + let magnet = "magnet:?xt=urn:btih:CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6" + let ih = InfoHash "\DC4\255\229\221#\CAN\143\213\203S\161\212\DEL\DC2\137\219p\171\243\RS" + parseMagnet magnet `shouldBe` Just (nullMagnet ih) + + it "parse base16" $ do + let magnet = "magnet:?xt=urn:btih:0123456789abcdef0123456789abcdef01234567" + let ih = InfoHash "\SOH#Eg\137\171\205\239\SOH#Eg\137\171\205\239\SOH#Eg" + parseMagnet magnet `shouldBe` Just (nullMagnet ih) diff --git a/tests/Data/Torrent/MetainfoSpec.hs b/tests/Data/Torrent/MetainfoSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Torrent/MetainfoSpec.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS -fno-warn-orphans #-} +module Data.Torrent.MetainfoSpec (spec) where + +import Control.Applicative +import Data.ByteString as BS +import Data.ByteString.Lazy as BL +import Data.BEncode +import Data.Maybe +import Data.Time +import Network.URI +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Data.Torrent.Piece +import Data.Torrent.Layout +import Data.Torrent + + +{----------------------------------------------------------------------- +-- Common +-----------------------------------------------------------------------} + +data T a = T + +prop_properBEncode :: Show a => BEncode a => Eq a + => T a -> a -> IO () +prop_properBEncode _ expected = actual `shouldBe` Right expected + where + actual = decode $ BL.toStrict $ encode expected + +instance Arbitrary URI where + arbitrary = pure $ fromJust + $ parseURI "http://exsample.com:80/123365_asd" + +{----------------------------------------------------------------------- +-- Instances +-----------------------------------------------------------------------} + +instance Arbitrary FileSize where + arbitrary = fromIntegral <$> (arbitrary :: Gen Int) + +instance Arbitrary a => Arbitrary (FileInfo a) where + arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary LayoutInfo where + arbitrary = oneof + [ SingleFile <$> arbitrary + , MultiFile <$> arbitrary <*> arbitrary + ] + +instance Arbitrary HashArray where + arbitrary = HashArray <$> arbitrary + +instance Arbitrary PieceInfo where + arbitrary = PieceInfo <$> arbitrary <*> arbitrary + +instance Arbitrary InfoDict where + arbitrary = infoDictionary <$> arbitrary <*> arbitrary <*> arbitrary + +pico :: Gen (Maybe NominalDiffTime) +pico = oneof + [ pure Nothing + , (Just . fromIntegral) <$> (arbitrary :: Gen Int) + ] + +instance Arbitrary Torrent where + arbitrary = Torrent <$> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> pico <*> arbitrary <*> arbitrary + <*> arbitrary <*> pure Nothing <*> arbitrary + +{----------------------------------------------------------------------- +-- Spec +-----------------------------------------------------------------------} + +spec :: Spec +spec = do + describe "FileInfo" $ do + it "properly bencoded" $ property $ + prop_properBEncode (T :: T (FileInfo BS.ByteString)) + + describe "LayoutInfo" $ do + it "properly bencoded" $ property $ + prop_properBEncode (T :: T LayoutInfo) + + describe "Torrent" $ do + it "property bencoded" $ property $ + prop_properBEncode (T :: T Torrent)