1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
-- TODO: tests
-- | Recommended method for generation of the peer ID's is 'newPeerID',
-- though this module exports some other goodies for custom generation.
--
module Network.Torrent.PeerID
( PeerID (getPeerID)
-- * Encoding styles
, azureusStyle, shadowStyle
-- * Defaults
, defaultClientID, defaultVersionNumber
-- * Generation
, newPeerID, timestampByteString
-- * Extra
, byteStringPadded
) where
import Control.Applicative
import Data.BEncode
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Builder as B
import Data.Foldable (foldMap)
import Data.Monoid ((<>))
import Data.Serialize
import Data.URLEncoded
import Data.Version (Version(Version), versionBranch)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import System.Locale (defaultTimeLocale)
-- TODO we have linker error here, so manual hardcoded version for a while.
-- import Paths_network_bittorrent (version)
version :: Version
version = Version [0, 10, 0, 0] []
-- | Peer identifier is exactly 20 bytes long bytestring.
newtype PeerID = PeerID { getPeerID :: ByteString }
deriving (Show, Eq, Ord, BEncodable)
instance Serialize PeerID where
put = putByteString . getPeerID
get = PeerID <$> getBytes 20
instance URLShow PeerID where
urlShow = BC.unpack . getPeerID
-- | 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 $ B.toLazyByteString $
B.char8 '-' <>
byteStringPadded cid 2 'H' <>
byteStringPadded ver 4 'X' <>
B.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 $ B.toLazyByteString $
B.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 = B.take 4 (BC.pack (foldMap show (versionBranch version)))
-- | 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.
--
timestampByteString :: IO ByteString
timestampByteString = (BC.pack . format) <$> getCurrentTime
where
format t = take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
take 9 (reverse (formatTime defaultTimeLocale "%s" t))
-- | 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.
--
newPeerID :: IO PeerID
newPeerID = azureusStyle defaultClientID defaultVersionNumber
<$> timestampByteString
-- | 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.
-> B.Builder
byteStringPadded bs s c =
B.byteString (B.take s bs) <>
B.byteString (BC.replicate padLen c)
where
padLen = s - min (B.length bs) s
|
