summaryrefslogtreecommitdiff
path: root/src/Network/Tox/Onion/Handlers.hs
blob: 99ef3c6929286d0b0176235b01c9f7589cf55ab9 (plain)
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
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
{-# LANGUAGE CPP             #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE PatternSynonyms #-}
module Network.Tox.Onion.Handlers where

import Network.Kademlia.Search
import Network.Tox.DHT.Transport
import Network.Tox.DHT.Handlers hiding (Message,Client)
import Network.Tox.Onion.Transport
import Network.QueryResponse as QR hiding (Client)
import qualified Network.QueryResponse as QR (Client)
import Crypto.Tox
import qualified Data.Wrapper.PSQ             as PSQ
         ;import Data.Wrapper.PSQ             (PSQ)
#ifdef CRYPTONITE_BACKPORT
import Crypto.Error.Types                     (CryptoFailable (..),
                                               throwCryptoError)
#else
import Crypto.Error
#endif
import Control.Arrow

import System.IO
import qualified Data.ByteArray               as BA
import Data.Function
import Data.Serialize as S
import qualified Data.Wrapper.PSQInt as Int
import Network.Kademlia
import Network.Address               (WantIP (..), ipFamily, testIdBit)
import qualified Network.Kademlia.Routing as R
import Control.TriadCommittee
import qualified Data.MinMaxPSQ               as MinMaxPSQ
         ;import Data.MinMaxPSQ               (MinMaxPSQ')
import Network.BitTorrent.DHT.Token           as Token

import Control.Exception hiding (Handler)
import Control.Monad
import Control.Concurrent.STM
import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
import Network.Socket
import Data.IP
import Data.Maybe
import Data.Bits
import Data.Ord
import Data.Functor.Identity
import DPut

type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
type Message = OnionMessage Identity

classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message
classify msg = go msg
 where
    go (OnionAnnounce         announce)    = IsQuery AnnounceType
                                                $ TransactionId (snd $ runIdentity $ asymmData announce)
                                                                (asymmNonce announce)
    go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24)
    go (OnionToRoute          {})          = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24))
    go (OnionToRouteResponse  {})          = IsResponse              (TransactionId (Nonce8 0) (Nonce24 zeros24))

-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
-- some secret bytes generated when the instance is created, the current time
-- divided by a 20 second timeout, the public key of the requester and the source
-- ip/port that the packet was received from. Since the ip/port that the packet
-- was received from is in the `ping_id`, the announce packets being sent with a
-- ping id must be sent using the same path as the packet that we received the
-- `ping_id` from or announcing will fail.
--
-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
-- time (20 to 40 seconds) for a peer to announce himself while taking in count
-- all the possible delays with some extra seconds.
announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
announceH routing toks keydb oaddr req = do
    case () of
        _ | announcePingId req == zeros32
          -> go False

        _ -> let Nonce32 bs = announcePingId req
                 tok        = fromPaddedByteString 32 bs
             in checkToken toks (onionNodeInfo oaddr) tok >>= go
        `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e)
 where
    go withTok = do
        let naddr = onionNodeInfo oaddr
        ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
        tm <- getPOSIXTime

        let storing = case oaddr of
                        OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
                        _                  -> Nothing
        dput XAnnounce   $ unlines [ "announceH: nodeId          = " ++ show (nodeId naddr)
                                   , "           announceSeeking = " ++ show (announceSeeking req)
                                   , "           withTok         = " ++ show withTok
                                   , "           storing         = " ++ maybe "False" (const "True") storing
                                   ]
        record <- atomically $ do
            forM_ storing $ \retpath -> when withTok $ do
                let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
                    -- Note: The following distance calculation assumes that
                    -- our nodeid doesn't change and is the same for both
                    -- routing4 and routing6.
                    d = xorNodeId (nodeId (tentativeId routing))
                                  (announceSeeking req)
                modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
            ks <- readTVar keydb
            return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
        newtok <- maybe (return $ zeros32)
                        (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
                        storing
        let k = case record of
                Nothing                    -> NotStored newtok
                Just _  | isJust storing   -> Acknowledged newtok
                Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
        let response = AnnounceResponse k ns
        dput XAnnounce $ unwords ["Announce:", show req, "-reply->", show response]
        return response

dataToRouteH ::
          TVar AnnouncedKeys
          -> Transport err (OnionDestination r) (OnionMessage f)
          -> addr
          -> OnionMessage f
          -> IO ()
dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do
    let k = key2id pub
    dput XOnion $ "dataToRouteH "++ show k
    mb <- atomically $ do
        ks <- readTVar keydb
        forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
            writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
            return rpath
    dput XOnion $ "dataToRouteH "++ show (fmap (const ()) mb)
    forM_ mb $ \rpath -> do
        -- forward
        dput XOnion $ "dataToRouteH sendMessage"
        sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm
        dput XOnion $ "Forwarding data-to-route -->"++show k

type NodeDistance = NodeId

data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3)

toOnionDestination :: AnnouncedRoute -> OnionDestination r
toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath

-- |
-- The type 'NodeId' was originally made for the DHT key, but here
-- we reuse it for user keys (public key/real key).
--
-- To find someone using their user (public) key, you search for it on
-- kademlia. At each iteration of the search, you get a response with
-- closest known nodes(DHT keys) to the key you are searching for.
--
-- To do an 'Announce' so your friends can find you, you do a search to
-- find the closest nodes to your own user(public) key. At those nodes,
-- you store a route back to yourself (using Announce message) so your
-- friends can contact you. This means each node needs to store the
-- saved routes, and that is the purpose of the 'AnnouncedKeys' data
-- structure.
--
data AnnouncedKeys = AnnouncedKeys
    { keyByAge :: !(PSQ NodeId (Down POSIXTime{-Time at which they announced to you-})) -- TODO: timeout of 300 seconds
    , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute))
        -- ^ PSQ using NodeId(user/public key) as Key
        --   and using 'NodeDistance' as priority.
        --   (smaller number is higher priority)
        --
        --  Keeping in a MinMaxPSQ will help us later when we want to make the structure
        --  bounded. (We simply throw away the most NodeDistant keys.
    }


insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
insertKey tm pub toxpath d keydb = AnnouncedKeys
    { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
    , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
                    Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
                    Nothing          -> MinMaxPSQ.insert' pub (0  ,toxpath) d (keyAssoc keydb)
    }

areq :: Message -> Either String AnnounceRequest
areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm
areq _                     = Left "Unexpected non-announce OnionMessage"

handlers :: Transport err (OnionDestination r) Message
            -> Routing
            -> TVar SessionTokens
            -> TVar AnnouncedKeys
            -> PacketKind
            -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message)
handlers net routing toks keydb AnnounceType
    = Just
    $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
    $ announceH routing toks keydb
handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net


toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
               -> TransportCrypto
               -> Client r
               -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
toxidSearch getTimeout crypto client = Search
    { searchSpace       = toxSpace
    , searchNodeAddress = nodeIP &&& nodePort
    , searchQuery       = getRendezvous getTimeout crypto client
    }

announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
                   -> MethodSerializer
                        TransactionId
                        (OnionDestination r)
                        (OnionMessage Identity)
                        PacketKind
                        AnnounceRequest
                        (Maybe AnnounceResponse)
announceSerializer getTimeout = MethodSerializer
    { methodTimeout = getTimeout
    , method = AnnounceType
    , wrapQuery = \(TransactionId n8 n24) src dst req ->
        -- :: tid -> addr -> addr -> a -> OnionMessage Identity
        OnionAnnounce $ Asymm
            { -- The public key is our real long term public key if we want to
              -- announce ourselves, a temporary one if we are searching for
              -- friends.
              senderKey = onionKey src
            , asymmNonce = n24
            , asymmData = Identity (req, n8)
            }
    , unwrapResponse = \case -- :: OnionMessage Identity -> b
        OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
        _                              -> Nothing
    }

unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
    = case is_stored of
        NotStored n32    -> ( ns , []                                                        , Just n32)
        SendBackKey k    -> ( ns , [Rendezvous k ni]                                         , Nothing )
        Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32)

-- TODO Announce key to announce peers.
--
--   Announce Peers are only put in the 8 closest peers array if they respond
--   to an announce request. If the peers fail to respond to 3 announce
--   requests they are deemed timed out and removed.
--
--   ...
--
--   For this reason, after the peer is announced successfully for 17 seconds,
--   announce packets are sent aggressively every 3 seconds to each known close
--   peer (in the list of 8 peers) to search aggressively for peers that know
--   the peer we are searching for.

-- TODO
-- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will
-- aggressively reannounce itself and search for friends as if it was just
-- started.


sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
            -> Client r
            -> AnnounceRequest
            -> OnionDestination r
            -> (NodeInfo -> AnnounceResponse -> t)
            -> IO (Maybe t)
sendOnion getTimeout client req oaddr unwrap =
    -- Four tries and then we tap out.
    flip fix 4 $ \loop n -> do
    mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr
    maybe (if n>0 then loop $! n - 1 else return Nothing)
          (return . Just . unwrap (onionNodeInfo oaddr))
          $ join mb

-- | Lookup the secret counterpart for a given alias key.
getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
            -> TransportCrypto
            -> Client r
            -> NodeId
            -> NodeInfo
            -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32))
getRendezvous getTimeout crypto client nid ni = do
    asel <- atomically $ selectAlias crypto nid
    let oaddr = OnionDestination asel ni Nothing
        rkey  = case asel of
                    SearchingAlias -> Nothing
                    _              -> Just $ key2id $ rendezvousPublic crypto
    sendOnion getTimeout client
        (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
        oaddr
        (unwrapAnnounceResponse rkey)

putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
               -> TransportCrypto
               -> Client r
               -> PublicKey
               -> Nonce32
               -> NodeInfo
               -> IO (Maybe (Rendezvous, AnnounceResponse))
putRendezvous getTimeout crypto client pubkey nonce32 ni = do
    let longTermKey   = key2id pubkey
        rkey          = rendezvousPublic crypto
        rendezvousKey = key2id rkey
    asel <- atomically $ selectAlias crypto longTermKey
    let oaddr = OnionDestination asel ni Nothing
    sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr
        $ \ni resp -> (Rendezvous rkey ni, resp)