module Network.BitTorrent.Core.PeerId
(
PeerId (getPeerId)
, genPeerId
, timestamp
, entropy
, azureusStyle
, shadowStyle
, clientInfo
, byteStringPadded
, defaultClientId
, defaultVersionNumber
) where
import Control.Applicative
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.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
import Data.Version (Version(Version), versionBranch)
import System.Entropy (getEntropy)
import System.Locale (defaultTimeLocale)
import Text.PrettyPrint hiding ((<>))
import Text.PrettyPrint.Class
import Text.Read (readMaybe)
import Paths_bittorrent (version)
import Data.Torrent.Client
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
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
byteStringPadded :: ByteString
-> Int
-> Char
-> 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
azureusStyle :: ByteString
-> ByteString
-> ByteString
-> PeerId
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'
shadowStyle :: Char
-> ByteString
-> ByteString
-> PeerId
shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
BS.char8 cid <>
byteStringPadded ver 4 '-' <>
byteStringPadded rnd 15 '0'
defaultClientId :: ByteString
defaultClientId = "HS"
defaultVersionNumber :: ByteString
defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $
versionBranch version
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))
entropy :: IO ByteString
entropy = getEntropy 15
genPeerId :: IO PeerId
genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
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
clientInfo :: PeerId -> ClientInfo
clientInfo pid = either (const def) id $ runGet getCI (getPeerId pid)
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 = 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) []