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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
-- |
-- Copyright : (c) Sam Truzjan 2013
-- License : BSD3
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- The return value for a query for peers includes an opaque value
-- known as the 'Token'. For a node to announce that its controlling
-- peer is downloading a torrent, it must present the token received
-- from the same queried node in a recent query for peers. When a node
-- attempts to \"announce\" a torrent, the queried node checks the
-- token against the querying node's 'IP' address. This is to prevent
-- malicious hosts from signing up other hosts for torrents. Since the
-- token is merely returned by the querying node to the same node it
-- received the token from, the implementation is not defined. Tokens
-- must be accepted for a reasonable amount of time after they have
-- been distributed.
--
{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-}
module Network.BitTorrent.DHT.Token
( -- * Token
Token
-- * Session tokens
, TokenMap
, SessionTokens
, nullSessionTokens
, checkToken
, grantToken
-- ** Construction
, Network.BitTorrent.DHT.Token.tokens
-- ** Query
, Network.BitTorrent.DHT.Token.lookup
, Network.BitTorrent.DHT.Token.member
-- ** Modification
, Network.BitTorrent.DHT.Token.defaultUpdateInterval
, Network.BitTorrent.DHT.Token.update
) where
import Control.Monad.State
#ifdef VERSION_bencoding
import Data.BEncode (BEncode)
#endif
import Data.ByteString as BS
import Data.ByteString.Char8 as B8
import Data.ByteString.Lazy as BL
import Data.ByteString.Lazy.Builder as BS
import qualified Data.ByteString.Base16 as Base16
import Data.Default
import Data.List as L
import Data.Hashable
import Data.String
import Data.Time
import System.Random
import Control.Concurrent.STM
import Network.Address
-- TODO use ShortByteString
-- | An opaque value.
newtype Token = Token BS.ByteString
deriving ( Eq, IsString
#ifdef VERSION_bencoding
, BEncode
#endif
)
instance Show Token where
show (Token bs) = B8.unpack $ Base16.encode bs
-- | Meaningless token, for testing purposes only.
instance Default Token where
def = Token "0xdeadbeef"
-- | The secret value used as salt.
type Secret = Int
-- The BitTorrent implementation uses the SHA1 hash of the IP address
-- concatenated onto a secret, we use hashable instead.
makeToken :: Hashable a => a -> Secret -> Token
makeToken n s = Token $ toBS $ hashWithSalt s n
where
toBS = toStrict . toLazyByteString . int64BE . fromIntegral
-- | Constant space 'Node' to 'Token' map based on the secret value.
data TokenMap = TokenMap
{ prevSecret :: {-# UNPACK #-} !Secret
, curSecret :: {-# UNPACK #-} !Secret
, generator :: {-# UNPACK #-} !StdGen
} deriving Show
-- | A new token map based on the specified seed value. Returned token
-- map should be periodicatically 'update'd.
--
-- Normally, the seed value should vary between invocations of the
-- client software.
tokens :: Int -> TokenMap
tokens seed = (`evalState` mkStdGen seed) $
TokenMap <$> state next
<*> state next
<*> get
-- | Get token for the given node. A token becomes invalid after 2
-- 'update's.
--
-- Typically used to handle find_peers query.
lookup :: Hashable a => a -> TokenMap -> Token
lookup addr TokenMap {..} = makeToken addr curSecret
-- | Check if token is valid.
--
-- Typically used to handle 'Network.DHT.Mainline.Announce'
-- query. If token is invalid the 'Network.KRPC.ProtocolError' should
-- be sent back to the malicious node.
member :: Hashable a => a -> Token -> TokenMap -> Bool
member addr token TokenMap {..} = token `L.elem` valid
where valid = makeToken addr <$> [curSecret, prevSecret]
-- | Secret changes every five minutes and tokens up to ten minutes old
-- are accepted.
defaultUpdateInterval :: NominalDiffTime
defaultUpdateInterval = 5 * 60
-- | Update current tokens.
update :: TokenMap -> TokenMap
update TokenMap {..} = TokenMap
{ prevSecret = curSecret
, curSecret = newSecret
, generator = newGen
}
where
(newSecret, newGen) = next generator
data SessionTokens = SessionTokens
{ tokenMap :: !TokenMap
, lastUpdate :: !UTCTime
, maxInterval :: !NominalDiffTime
}
nullSessionTokens :: IO SessionTokens
nullSessionTokens = SessionTokens
<$> (tokens <$> randomIO)
<*> getCurrentTime
<*> pure defaultUpdateInterval
-- TODO invalidate *twice* if needed
invalidateTokens :: UTCTime -> SessionTokens -> SessionTokens
invalidateTokens curTime ts @ SessionTokens {..}
| curTime `diffUTCTime` lastUpdate > maxInterval = SessionTokens
{ tokenMap = update tokenMap
, lastUpdate = curTime
, maxInterval = maxInterval
}
| otherwise = ts
{-----------------------------------------------------------------------
-- Tokens
-----------------------------------------------------------------------}
tryUpdateSecret :: TVar SessionTokens -> IO ()
tryUpdateSecret toks = do
curTime <- getCurrentTime
atomically $ modifyTVar' toks (invalidateTokens curTime)
grantToken :: Hashable addr => TVar SessionTokens -> addr -> IO Token
grantToken sessionTokens addr = do
tryUpdateSecret sessionTokens
toks <- readTVarIO sessionTokens
return $ Network.BitTorrent.DHT.Token.lookup addr $ tokenMap toks
-- | Throws 'HandlerError' if the token is invalid or already
-- expired. See 'TokenMap' for details.
checkToken :: Hashable addr => TVar SessionTokens -> addr -> Token -> IO Bool
checkToken sessionTokens addr questionableToken = do
tryUpdateSecret sessionTokens
toks <- readTVarIO sessionTokens
return $ member addr questionableToken (tokenMap toks)
|
