diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,14 @@ +2013-11-21 Sam Truzjan + + Version 0.0.0.2 + + * InfoHash.hs: added rendering to Text. + * Torrent.hs: added pretty printing and content type. + * Magnet.hs: added constructors from Torrent datatype. + * New: added Data.Torrent.Client, Data.Torrent.Progress, + Network.Bittorrent.Core.PeerId, Network.BitTorrent.PeerAddr + modules. + +2013-11-01 Sam Truzjan + + Initial version: 0.0.0.1 diff --git a/bittorrent.cabal b/bittorrent.cabal --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -1,5 +1,5 @@ name: bittorrent -version: 0.0.0.1 +version: 0.0.0.2 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -23,7 +23,7 @@ extra-source-files: res/dapper-dvd-amd64.iso.torrent res/pkg.torrent , README.md - , changelog + , ChangeLog source-repository head type: git @@ -33,7 +33,7 @@ type: git location: git://github.com/cobit/bittorrent.git branch: master - tag: v0.0.0.1 + tag: v0.0.0.2 library default-language: Haskell2010 @@ -44,17 +44,21 @@ exposed-modules: Data.Torrent -- , Data.Torrent.Bitfield , Data.Torrent.Block + , Data.Torrent.Client , Data.Torrent.InfoHash , Data.Torrent.Layout , Data.Torrent.Magnet , Data.Torrent.Piece + , Data.Torrent.Progress , Data.Torrent.Tree - + , Network.BitTorrent.Core.PeerId + , 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 @@ -66,6 +70,8 @@ -- , Network.BitTorrent.DHT.Protocol -- , Network.BitTorrent.Sessions -- other-modules: Network.BitTorrent.Sessions.Types +-- Paths_bittorrent + build-depends: base == 4.* , bits-extras , pretty @@ -99,7 +105,7 @@ , vector -- Hashing - , cryptohash + , cryptohash == 0.10.* , hashable -- Codecs & Serialization diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,1 +0,0 @@ -* 0.0.0.1: Initial version. diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs @@ -26,6 +26,7 @@ module Data.Torrent ( -- * Info dictionary InfoDict (..) + , ppInfoDict -- ** Lenses , infohash @@ -35,6 +36,7 @@ -- * Torrent file , Torrent(..) + , ppTorrent -- ** Lenses , announce @@ -51,6 +53,9 @@ -- * Construction , nullTorrent + -- * Mime types + , typeTorrent + -- * File paths , torrentExt , isTorrentPath @@ -82,6 +87,7 @@ import Data.Time.Clock.POSIX import Data.Typeable import Network.URI +import Text.PrettyPrint as PP import System.FilePath import Data.Torrent.InfoHash as IH @@ -149,6 +155,20 @@ where ih = IH.hashlazy (encode dict) +ppPrivacy :: Bool -> Doc +ppPrivacy privacy = + "Privacy: " <> if privacy then "private" else "public" + +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 + {----------------------------------------------------------------------- -- Torrent info -----------------------------------------------------------------------} @@ -263,13 +283,47 @@ <*>? "publisher-url" <*>? "signature" +(<:>) :: Doc -> Doc -> Doc +name <:> v = name <> ":" <+> v + +(<:>?) :: Doc -> Maybe Doc -> Doc +_ <:>? Nothing = PP.empty +name <:>? (Just d) = name <:> d + +ppTorrent :: Torrent -> Doc +ppTorrent Torrent {..} = + "InfoHash: " <> ppInfoHash (idInfoHash tInfoDict) + $$ hang "General" 4 generalInfo + $$ hang "Tracker" 4 trackers + $$ ppInfoDict tInfoDict + where + trackers = case tAnnounceList of + Nothing -> text (show tAnnounce) + Just xxs -> vcat $ L.map ppTier $ L.zip [1..] xxs + where + ppTier (n, xs) = "Tier #" <> int n <:> vcat (L.map (text . show) xs) + + generalInfo = + "Comment" <:>? ((text . T.unpack) <$> tComment) $$ + "Created by" <:>? ((text . T.unpack) <$> tCreatedBy) $$ + "Created on" <:>? ((text . show . posixSecondsToUTCTime) + <$> tCreationDate) $$ + "Encoding" <:>? ((text . T.unpack) <$> tEncoding) $$ + "Publisher" <:>? ((text . show) <$> tPublisher) $$ + "Publisher URL" <:>? ((text . show) <$> tPublisherURL) $$ + "Signature" <:>? ((text . show) <$> tSignature) + -- | A simple torrent contains only required fields. nullTorrent :: URI -> InfoDict -> Torrent nullTorrent ann info = Torrent ann Nothing Nothing Nothing Nothing Nothing info Nothing Nothing Nothing --- | Extension usually used for torrent metafiles. +-- | Mime type of torrent files. +typeTorrent :: BS.ByteString +typeTorrent = "application/x-bittorrent" + +-- | Extension usually used for torrent files. torrentExt :: String torrentExt = "torrent" @@ -285,5 +339,6 @@ 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 diff --git a/src/Data/Torrent/Client.hs b/src/Data/Torrent/Client.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent/Client.hs @@ -0,0 +1,249 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- 'ClientInfo' 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'! +-- +module Data.Torrent.Client + ( -- * Client implementation + ClientImpl (..) + , ppClientImpl + + -- * Client version + , ClientVersion (..) + , ppClientVersion + + -- * Client information + , ClientInfo (..) + , ppClientInfo + , libClientInfo + ) where + +import Control.Applicative +import Data.ByteString as BS +import Data.ByteString.Char8 as BC +import Data.Default +import Data.List as L +import Data.Monoid +import Data.Text as T +import Data.Version +import Text.PrettyPrint hiding ((<>)) +import Paths_bittorrent (version) + + +-- | List of registered client versions + IlibHSbittorrent (this +-- package) + Unknown (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 + | 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 + +-- | Format client implementation info in human-readable form. +ppClientImpl :: ClientImpl -> Doc +ppClientImpl = text . L.tail . show + +-- | Version of client software, normally extracted from peer id. +newtype ClientVersion = ClientVersion { getClientVersion :: Version } + deriving (Show, Eq, Ord) + +-- | Just the '0' version. +instance Default ClientVersion where + def = ClientVersion $ Version [0] [] + +-- | Format client implementation version in human-readable form. +ppClientVersion :: ClientVersion -> Doc +ppClientVersion = text . showVersion . getClientVersion + +-- | The all sensible infomation that can be obtained from a peer +-- identifier or torrent /createdBy/ field. +data ClientInfo = ClientInfo { + ciImpl :: ClientImpl + , ciVersion :: ClientVersion + } deriving (Show, Eq, Ord) + +-- | Unrecognized client implementation. +instance Default ClientInfo where + def = ClientInfo def def + +-- | Format client info in human-readable form. +ppClientInfo :: ClientInfo -> Doc +ppClientInfo ClientInfo {..} = + ppClientImpl ciImpl <+> "version" <+> ppClientVersion 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) + +{----------------------------------------------------------------------- +-- For torrent file +-----------------------------------------------------------------------} + +renderImpl :: ClientImpl -> Text +renderImpl = T.pack . L.tail . show + +renderVersion :: ClientVersion -> 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/Data/Torrent/InfoHash.hs b/src/Data/Torrent/InfoHash.hs --- a/src/Data/Torrent/InfoHash.hs +++ b/src/Data/Torrent/InfoHash.hs @@ -12,10 +12,18 @@ module Data.Torrent.InfoHash ( -- * Info hash InfoHash(..) + + -- * Parsing , textToInfoHash - , addHashToURI + + -- * Rendering + , longHex + , shortHex , ppInfoHash + , addHashToURI + + , Data.Torrent.InfoHash.hash , Data.Torrent.InfoHash.hashlazy ) where @@ -38,7 +46,7 @@ import Data.URLEncoded as URL import Data.Serialize import Data.String -import Data.Text +import Data.Text as T import Data.Text.Encoding as T import Network.URI import Numeric @@ -111,13 +119,13 @@ hashLen = BS.length hashStr hashStr = T.encodeUtf8 text --- | Hash strict bytestring using SHA1 algorithm. -hash :: BS.ByteString -> InfoHash -hash = InfoHash . C.hash +-- | Hex encode infohash to text, full length. +longHex :: InfoHash -> Text +longHex = T.decodeUtf8 . Base16.encode . getInfoHash --- | Hash lazy bytestring using SHA1 algorithm. -hashlazy :: BL.ByteString -> InfoHash -hashlazy = InfoHash . C.hashlazy +-- | 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 @@ -125,6 +133,14 @@ ppHex :: BS.ByteString -> BS.ByteString ppHex = BL.toStrict . B.toLazyByteString . B.byteStringHexFixed + +-- | Hash strict bytestring using SHA1 algorithm. +hash :: BS.ByteString -> InfoHash +hash = InfoHash . C.hash + +-- | Hash lazy bytestring using SHA1 algorithm. +hashlazy :: BL.ByteString -> InfoHash +hashlazy = InfoHash . C.hashlazy -- | Add query info hash parameter to uri. -- 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 @@ -12,6 +12,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -fno-warn-orphans #-} module Data.Torrent.Layout @@ -21,6 +24,7 @@ -- * Single file info , FileInfo (..) + , ppFileInfo -- ** Lens , fileLength @@ -29,6 +33,8 @@ -- * File layout , LayoutInfo (..) + , ppLayoutInfo + , joinFilePath -- ** Lens , singleFile @@ -39,7 +45,8 @@ , isSingleFile , isMultiFile - -- ** Folds + -- ** Query + , suggestedName , contentLength , fileCount , blockCount @@ -64,13 +71,18 @@ import Data.BEncode.Types import Data.ByteString as BS import Data.ByteString.Char8 as BC -import Data.Char +import Data.Char as Char +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 System.FilePath import System.Posix.Types import Data.Torrent.Block +import Data.Torrent.InfoHash {----------------------------------------------------------------------- @@ -110,9 +122,11 @@ -- -- > ["dir1", "dir2", "file.ext"] -- - } deriving (Show, Read, Eq, Typeable) + } deriving (Show, Read, Eq, Typeable + , Functor, Foldable + ) -$(deriveJSON (L.map toLower . L.dropWhile isLower) ''FileInfo) +$(deriveJSON (L.map Char.toLower . L.dropWhile isLower) ''FileInfo) makeLensesFor [ ("fiLength", "fileLength") @@ -161,6 +175,19 @@ fromBEncode = fromDict getFileInfoSingle {-# INLINE fromBEncode #-} +-- | Format 'FileInfo' in human-readable form. +ppFileInfo :: FileInfo ByteString -> Doc +ppFileInfo FileInfo {..} = + "Path: " <> text (T.unpack (T.decodeUtf8 fiName)) + $$ "Size: " <> text (show fiLength) + $$ maybe PP.empty ppMD5 fiMD5Sum + where + ppMD5 md5 = "MD5 : " <> text (show (InfoHash md5)) + +-- | Join file path. +joinFilePath :: FileInfo [ByteString] -> FileInfo ByteString +joinFilePath = fmap (BS.intercalate "/") + {----------------------------------------------------------------------- -- Original torrent file layout info -----------------------------------------------------------------------} @@ -185,7 +212,7 @@ , liDirName :: !ByteString } deriving (Show, Read, Eq, Typeable) -$(deriveJSON (L.map toLower . L.dropWhile isLower) ''LayoutInfo) +$(deriveJSON (L.map Char.toLower . L.dropWhile isLower) ''LayoutInfo) makeLensesFor [ ("liFile" , "singleFile" ) @@ -215,6 +242,11 @@ 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 + -- | Test if this is single file torrent. isSingleFile :: LayoutInfo -> Bool isSingleFile SingleFile {} = True @@ -227,10 +259,16 @@ 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 } = sum (L.map fiLength tfs) +contentLength MultiFile { liFiles = tfs } = L.sum (L.map fiLength tfs) -- | Get number of all files in torrent. fileCount :: LayoutInfo -> Int 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 @@ -13,10 +13,17 @@ -- Bittorrent specific info: -- -- +{-# LANGUAGE NamedFieldPuns #-} module Data.Torrent.Magnet ( -- * Magnet Magnet(..) + + -- * Construction , nullMagnet + , simpleMagnet + , detailedMagnet + + -- * Conversion , parseMagnet , renderMagnet @@ -33,11 +40,13 @@ import Data.URLEncoded as URL import Data.String import Data.Text as T +import Data.Text.Encoding as T import Network.URI import Text.Read +import Data.Torrent import Data.Torrent.InfoHash - +import Data.Torrent.Layout {----------------------------------------------------------------------- -- URN @@ -151,6 +160,24 @@ , exactSource = Nothing , tracker = Nothing , supplement = M.empty + } + +-- | A simple magnet link including infohash ('xt' param) and display +-- name ('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 = Just tAnnounce } fromQuery :: URLEncoded -> Either String 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 @@ -194,8 +194,8 @@ -- | Format piece info in human readable form. Hashes are omitted. ppPieceInfo :: PieceInfo -> Doc -ppPieceInfo PieceInfo { piPieceLength = len } = - "PieceInfo" <+> braces ("length" <+> "=" <+> int len) +ppPieceInfo PieceInfo {..} = + "Piece size: " <> int piPieceLength hashsize :: Int hashsize = 20 diff --git a/src/Data/Torrent/Progress.hs b/src/Data/Torrent/Progress.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent/Progress.hs @@ -0,0 +1,129 @@ +-- | +-- 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 #-} +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 +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.Word + + +-- | 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) +$(deriveJSON L.tail ''Progress) + +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 #-} + +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 #-} + +-- | 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/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs new file mode 100644 --- /dev/null +++ b/src/Network/BitTorrent/Core/PeerAddr.hs @@ -0,0 +1,124 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- 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 #-} +{-# OPTIONS -fno-warn-orphans #-} -- for PortNumber instances +module Network.BitTorrent.Core.PeerAddr + ( -- * Peer address + PeerAddr(..) + , getCompactPeerList + , peerSockAddr + , connectToPeer + , ppPeer + ) where + +import Control.Applicative +import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson.TH +import Data.BEncode as BS +import Data.Bits +import Data.Char +import Data.List as L +import Data.Serialize as S +import Data.Typeable +import Data.Word +import Network.Socket +import Text.PrettyPrint + +import Data.Torrent.Client +import Network.BitTorrent.Core.PeerId + + +deriving instance ToJSON PortNumber +deriving instance FromJSON PortNumber + +instance BEncode PortNumber where + toBEncode = toBEncode . fromEnum + fromBEncode b = toEnum <$> fromBEncode b + +instance Serialize PortNumber where + get = fromIntegral <$> getWord16be + {-# INLINE get #-} + put = putWord16be . fromIntegral + {-# INLINE put #-} + +-- TODO check semantic of ord and eq instances +-- TODO use SockAddr instead of peerIP and peerPort + +-- | Peer address info normally extracted from peer list or peer +-- compact list encoding. +data PeerAddr = PeerAddr { + peerID :: !(Maybe PeerId) + , peerIP :: {-# UNPACK #-} !HostAddress + , peerPort :: {-# UNPACK #-} !PortNumber + } deriving (Show, Eq, Ord, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''PeerAddr) + +-- | The tracker "announce query" compatible encoding. +instance BEncode PeerAddr where + toBEncode (PeerAddr pid pip pport) = toDict $ + "peer id" .=? pid + .: "ip" .=! pip + .: "port" .=! pport + .: endDict + + fromBEncode = fromDict $ do + PeerAddr <$>? "peer id" + <*>! "ip" + <*>! "port" + +-- | The tracker "compact peer list" compatible encoding. The +-- 'peerId' is always 'Nothing'. +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 + +-- TODO make platform independent, clarify htonl + +-- | Convert peer info from tracker response to socket address. Used +-- for establish connection between peers. +-- +peerSockAddr :: PeerAddr -> SockAddr +peerSockAddr = SockAddrInet <$> (g . peerPort) <*> (htonl . peerIP) + where + htonl :: Word32 -> Word32 + htonl d = + ((d .&. 0xff) `shiftL` 24) .|. + (((d `shiftR` 8 ) .&. 0xff) `shiftL` 16) .|. + (((d `shiftR` 16) .&. 0xff) `shiftL` 8) .|. + ((d `shiftR` 24) .&. 0xff) + + g :: PortNumber -> PortNumber + g = id + +-- | Tries to connect to peer using reasonable default parameters. +connectToPeer :: PeerAddr -> IO Socket +connectToPeer p = do + 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 new file mode 100644 --- /dev/null +++ b/src/Network/BitTorrent/Core/PeerId.hs @@ -0,0 +1,279 @@ +-- | +-- 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. (FIX not really) Peer ID is sent in /tracker request/, +-- sent and received in /peer handshakes/ and used in /distributed +-- hash table/ queries. +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Network.BitTorrent.Core.PeerId + ( -- * PeerId + PeerId (getPeerId) + , ppPeerId + + -- * Generation + , genPeerId + , timestamp + , entropy + + -- * Encoding + , azureusStyle + , shadowStyle + + -- * Decoding + , clientInfo + + -- ** Extra + , byteStringPadded + , defaultClientId + , defaultVersionNumber + ) where + +import Control.Applicative +import Data.Aeson +import Data.BEncode as BE +import Data.ByteString 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.Monoid +import Data.Serialize as S +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (formatTime) +import Data.URLEncoded +import Data.Version (Version(Version), versionBranch) +import System.Entropy (getEntropy) +import System.Locale (defaultTimeLocale) +import Text.PrettyPrint hiding ((<>)) +import Text.Read (readMaybe) +import Paths_bittorrent (version) + +import Data.Torrent.Client + +-- TODO use unpacked form (length is known statically) + +-- | Peer identifier is exactly 20 bytes long bytestring. +newtype PeerId = PeerId { getPeerId :: ByteString } + deriving (Show, Eq, Ord, BEncode, ToJSON, FromJSON) + +instance Serialize PeerId where + put = putByteString . getPeerId + get = PeerId <$> getBytes 20 + +instance URLShow PeerId where + urlShow = BC.unpack . getPeerId + +-- | Format peer id in human readable form. +ppPeerId :: PeerId -> Doc +ppPeerId = text . BC.unpack . getPeerId + +{----------------------------------------------------------------------- +-- 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. +defaultVersionNumber :: ByteString +defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $ + versionBranch version + +{----------------------------------------------------------------------- +-- Generation +-----------------------------------------------------------------------} + +-- | Gives 15 characters long decimal timestamp such that: +-- +-- * 6 bytes : first 6 characters from picoseconds obtained with %q. +-- +-- * 1 bytes : 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) and more +-- or less random. +-- +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 Azureus-style encoding with the following args: +-- +-- * 'HS' for the client id. +-- +-- * Version of the package for the version number +-- +-- * UTC time day ++ day time for the random number. +-- +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 "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 + +-- | 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 + mkVer bs = ClientVersion $ Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] []