diff options
author | James Crayne <jim.crayne@gmail.com> | 2019-09-28 13:43:29 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:27:53 -0500 |
commit | 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch) | |
tree | 5716463275c2d3e902889db619908ded2a73971c /src/Network/Tox | |
parent | add2c76bced51fde5e9917e7449ef52be70faf87 (diff) |
Factor out some new libraries
word64-map:
Data.Word64Map
network-addr:
Network.Address
tox-crypto:
Crypto.Tox
lifted-concurrent:
Control.Concurrent.Lifted.Instrument
Control.Concurrent.Async.Lifted.Instrument
psq-wrap:
Data.Wrapper.PSQInt
Data.Wrapper.PSQ
minmax-psq:
Data.MinMaxPSQ
tasks:
Control.Concurrent.Tasks
kad:
Network.Kademlia
Network.Kademlia.Bootstrap
Network.Kademlia.Routing
Network.Kademlia.CommonAPI
Network.Kademlia.Persistence
Network.Kademlia.Search
Diffstat (limited to 'src/Network/Tox')
-rw-r--r-- | src/Network/Tox/AggregateSession.hs | 374 | ||||
-rw-r--r-- | src/Network/Tox/Avahi.hs | 65 | ||||
-rw-r--r-- | src/Network/Tox/ContactInfo.hs | 172 | ||||
-rw-r--r-- | src/Network/Tox/Crypto/Transport.hs | 1029 | ||||
-rw-r--r-- | src/Network/Tox/DHT/Handlers.hs | 573 | ||||
-rw-r--r-- | src/Network/Tox/DHT/Transport.hs | 460 | ||||
-rw-r--r-- | src/Network/Tox/Handshake.hs | 125 | ||||
-rw-r--r-- | src/Network/Tox/NodeId.hs | 731 | ||||
-rw-r--r-- | src/Network/Tox/Onion/Handlers.hs | 369 | ||||
-rw-r--r-- | src/Network/Tox/Onion/Transport.hs | 119 | ||||
-rw-r--r-- | src/Network/Tox/Relay.hs | 235 | ||||
-rw-r--r-- | src/Network/Tox/Session.hs | 243 | ||||
-rw-r--r-- | src/Network/Tox/TCP.hs | 313 | ||||
-rw-r--r-- | src/Network/Tox/Transport.hs | 86 |
14 files changed, 0 insertions, 4894 deletions
diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs deleted file mode 100644 index 8c728660..00000000 --- a/src/Network/Tox/AggregateSession.hs +++ /dev/null | |||
@@ -1,374 +0,0 @@ | |||
1 | -- | This module aggregates all sessions to the same remote Tox contact into a | ||
2 | -- single online/offline presence. This allows multiple lossless links to the | ||
3 | -- same identity at different addresses, or even to the same address. | ||
4 | {-# LANGUAGE CPP #-} | ||
5 | {-# LANGUAGE GADTs #-} | ||
6 | {-# LANGUAGE LambdaCase #-} | ||
7 | {-# LANGUAGE PatternSynonyms #-} | ||
8 | module Network.Tox.AggregateSession | ||
9 | ( AggregateSession | ||
10 | , newAggregateSession | ||
11 | , aggregateStatus | ||
12 | , checkCompatible | ||
13 | , compatibleKeys | ||
14 | , AddResult(..) | ||
15 | , addSession | ||
16 | , DelResult(..) | ||
17 | , delSession | ||
18 | , closeAll | ||
19 | , awaitAny | ||
20 | , dispatchMessage | ||
21 | ) where | ||
22 | |||
23 | |||
24 | import Control.Concurrent.STM | ||
25 | import Control.Concurrent.STM.TMChan | ||
26 | import Control.Monad | ||
27 | import Data.Dependent.Sum | ||
28 | import Data.Function | ||
29 | import qualified Data.IntMap.Strict as IntMap | ||
30 | ;import Data.IntMap.Strict (IntMap) | ||
31 | import Data.List | ||
32 | import Data.Time.Clock.POSIX | ||
33 | import System.IO.Error | ||
34 | |||
35 | #ifdef THREAD_DEBUG | ||
36 | import Control.Concurrent.Lifted.Instrument | ||
37 | #else | ||
38 | import Control.Concurrent.Lifted | ||
39 | import GHC.Conc (labelThread) | ||
40 | #endif | ||
41 | |||
42 | import Connection (Status (..)) | ||
43 | import Crypto.Tox (PublicKey, toPublic) | ||
44 | import Data.Tox.Msg | ||
45 | import Data.Wrapper.PSQInt as PSQ | ||
46 | import DPut | ||
47 | import DebugTag | ||
48 | import Network.QueryResponse | ||
49 | import Network.Tox.Crypto.Transport | ||
50 | import Network.Tox.DHT.Transport (key2id) | ||
51 | import Network.Tox.NodeId (ToxProgress (..)) | ||
52 | import Network.Tox.Session | ||
53 | |||
54 | -- | For each component session, we track the current status. | ||
55 | data SingleCon = SingleCon | ||
56 | { singleSession :: Session -- ^ A component session. | ||
57 | , singleStatus :: TVar (Status ToxProgress) -- ^ Either 'AwaitingSessionPacket' or 'Established'. | ||
58 | } | ||
59 | |||
60 | -- | A collection of sessions between the same local and remote identities. | ||
61 | data AggregateSession = AggregateSession | ||
62 | { -- | The set of component sessions indexed by their ID. | ||
63 | contactSession :: TVar (IntMap SingleCon) | ||
64 | -- | Each inbound packets is written to this channel with the session ID | ||
65 | -- from which it came originally. | ||
66 | , contactChannel :: TMChan (Int,CryptoMessage) | ||
67 | -- | The set of 'Established' sessions IDs. | ||
68 | , contactEstablished :: TVar (IntMap ()) | ||
69 | -- | Callback for state-change notifications. | ||
70 | , notifyState :: AggregateSession -> Session -> Status ToxProgress -> STM () | ||
71 | } | ||
72 | |||
73 | |||
74 | -- | Create a new empty aggregate session. The argument is a callback to | ||
75 | -- receive notifications when the new session changes status. There are three | ||
76 | -- possible status values: | ||
77 | -- | ||
78 | -- [ Dormant ] - No pending or established sessions. | ||
79 | -- | ||
80 | -- [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are | ||
81 | -- fully established. | ||
82 | -- | ||
83 | -- [ Established ] - At least one session is fully established and we can | ||
84 | -- send and receive packets via this aggregate. | ||
85 | -- | ||
86 | -- The 'Session' object is provided to the callback so that it can determine the | ||
87 | -- current remote and local identities for this AggregateSession. It may not even | ||
88 | -- be Established, so do not use it to send or receive packets. | ||
89 | newAggregateSession :: (AggregateSession -> Session -> Status ToxProgress -> STM ()) | ||
90 | -> STM AggregateSession | ||
91 | newAggregateSession notify = do | ||
92 | vimap <- newTVar IntMap.empty | ||
93 | chan <- newTMChan | ||
94 | vemap <- newTVar IntMap.empty | ||
95 | return AggregateSession | ||
96 | { contactSession = vimap | ||
97 | , contactChannel = chan | ||
98 | , contactEstablished = vemap | ||
99 | , notifyState = notify | ||
100 | } | ||
101 | |||
102 | -- | Information returned from 'addSession'. Note that a value other than | ||
103 | -- 'RejectedSession' does not mean there is any 'Established' session in the | ||
104 | -- Aggregate. Sessions are in 'AwaitingSessionPacket' state until a single | ||
105 | -- packet is received from the remote end. | ||
106 | data AddResult = FirstSession -- ^ Initial connection with this contact. | ||
107 | | AddedSession -- ^ Added another connection to active session. | ||
108 | | RejectedSession -- ^ Failed to add session (wrong contact / closed session). | ||
109 | |||
110 | -- | The 'keepAlive' thread juggles three scheduled tasks. | ||
111 | data KeepAliveEvents = DoTimeout -- ^ A session timed-out, close it. | ||
112 | | DoAlive -- ^ Send a the keep-alive becon for a session. | ||
113 | | DoRequestMissing -- ^ Detect and request lost packets. | ||
114 | deriving Enum | ||
115 | |||
116 | -- | This call loops until the provided sesison is closed or times out. It | ||
117 | -- monitors the provided (non-empty) priority queue for scheduled tasks (see | ||
118 | -- 'KeepAliveEvents') to perform for the connection. | ||
119 | keepAlive :: Session -> TVar (PSQ POSIXTime) -> IO () | ||
120 | keepAlive s q = do | ||
121 | myThreadId >>= flip labelThread | ||
122 | (intercalate "." ["beacon" | ||
123 | , take 8 $ show $ key2id $ sTheirUserKey s | ||
124 | , show $ sSessionID s]) | ||
125 | |||
126 | let -- outPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e | ||
127 | unexpected e = dput XUnexpected $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e | ||
128 | |||
129 | doAlive = do | ||
130 | -- outPrint $ "Beacon" | ||
131 | sendMessage (sTransport s) () (Pkt ALIVE ==> ()) | ||
132 | |||
133 | doRequestMissing = do | ||
134 | (ns,nmin) <- sMissingInbound s | ||
135 | -- outPrint $ "PacketRequest " ++ show (nmin,ns) | ||
136 | sendMessage (sTransport s) () (Pkt PacketRequest ==> MissingPackets ns) | ||
137 | `catchIOError` \e -> do | ||
138 | unexpected $ "PacketRequest " ++ take 200 (show (nmin,length ns,ns)) | ||
139 | unexpected $ "PacketRequest: " ++ show e | ||
140 | -- Quit thread by scheduling a timeout event. | ||
141 | now <- getPOSIXTime | ||
142 | atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) now | ||
143 | |||
144 | re tm again e io = do | ||
145 | io | ||
146 | atomically $ modifyTVar' q $ PSQ.insert (fromEnum e) tm | ||
147 | again | ||
148 | |||
149 | doEvent again now e = case e of | ||
150 | DoTimeout -> do dput XNetCrypto $ "TIMEOUT: " ++ show (sSessionID s) | ||
151 | sClose s | ||
152 | DoAlive -> re (now + 10) again e doAlive | ||
153 | DoRequestMissing -> re (now + 5) again e doRequestMissing -- tox-core does this at 1 second intervals | ||
154 | |||
155 | fix $ \again -> do | ||
156 | |||
157 | now <- getPOSIXTime | ||
158 | join $ atomically $ do | ||
159 | PSQ.findMin <$> readTVar q >>= \case | ||
160 | Nothing -> error "keepAlive: unexpected empty PSQ." | ||
161 | Just ( k :-> tm ) -> | ||
162 | return $ if now < tm then threadDelay (toMicroseconds $ tm - now) >> again | ||
163 | else doEvent again now (toEnum k) | ||
164 | |||
165 | |||
166 | -- | This function forks two threads: the 'keepAlive' beacon-sending thread and | ||
167 | -- a thread to read all packets from the provided 'Session' and forward them to | ||
168 | -- 'contactChannel' for a containing 'AggregateSession' | ||
169 | forkSession :: AggregateSession -> Session -> (Status ToxProgress -> STM ()) -> IO ThreadId | ||
170 | forkSession c s setStatus = forkIO $ do | ||
171 | myThreadId >>= flip labelThread | ||
172 | (intercalate "." ["s" | ||
173 | , take 8 $ show $ key2id $ sTheirUserKey s | ||
174 | , show $ sSessionID s]) | ||
175 | |||
176 | q <- atomically $ newTVar $ fromList | ||
177 | [ fromEnum DoAlive :-> 0 | ||
178 | , fromEnum DoRequestMissing :-> 0 | ||
179 | ] | ||
180 | |||
181 | let sendPacket :: CryptoMessage -> STM () | ||
182 | sendPacket msg = writeTMChan (contactChannel c) (sSessionID s, msg) | ||
183 | |||
184 | inPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " --> " ++ e | ||
185 | |||
186 | bump = do | ||
187 | -- inPrint $ "BUMP: " ++ show (sSessionID s) | ||
188 | now <- getPOSIXTime | ||
189 | atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) (now + 15) | ||
190 | |||
191 | onPacket body loop Nothing = return () | ||
192 | onPacket body loop (Just (Left e)) = inPrint e >> loop | ||
193 | onPacket body loop (Just (Right x)) = body loop x | ||
194 | |||
195 | awaitPacket body = fix $ awaitMessage (sTransport s) . onPacket body | ||
196 | |||
197 | atomically $ setStatus $ InProgress AwaitingSessionPacket | ||
198 | awaitPacket $ \_ (online,()) -> do | ||
199 | when (msgID online /= M ONLINE) $ do | ||
200 | inPrint $ "Unexpected initial packet: " ++ show (msgID online) | ||
201 | atomically $ do setStatus Established | ||
202 | sendPacket online | ||
203 | bump | ||
204 | beacon <- forkIO $ keepAlive s q | ||
205 | awaitPacket $ \awaitNext (x,()) -> do | ||
206 | bump | ||
207 | case msgID x of | ||
208 | M ALIVE -> return () | ||
209 | M KillPacket -> sClose s | ||
210 | _ -> atomically $ sendPacket x | ||
211 | awaitNext | ||
212 | atomically $ setStatus Dormant | ||
213 | killThread beacon | ||
214 | |||
215 | -- | Add a new session (in 'AwaitingSessionPacket' state) to the | ||
216 | -- 'AggregateSession'. If the supplied session is not compatible because it is | ||
217 | -- between the wrong ToxIDs or because the AggregateSession is closed, | ||
218 | -- 'RejectedSession' will be returned. Otherwise, the operation is successful. | ||
219 | -- | ||
220 | -- The status-change callback may be triggered by this call as the aggregate | ||
221 | -- may transition from 'Dormant' (empty) to 'AwaitingSessionPacket' (at least | ||
222 | -- one active session). | ||
223 | addSession :: AggregateSession -> Session -> IO AddResult | ||
224 | addSession c s = do | ||
225 | (result,mcon,replaced) <- atomically $ do | ||
226 | let them = sTheirUserKey s | ||
227 | me = toPublic $ sOurKey s | ||
228 | compat <- checkCompatible me them c | ||
229 | let result = case compat of | ||
230 | Nothing -> FirstSession | ||
231 | Just True -> AddedSession | ||
232 | Just False -> RejectedSession | ||
233 | case result of | ||
234 | RejectedSession -> return (result,Nothing,Nothing) | ||
235 | _ -> do | ||
236 | statvar <- newTVar Dormant | ||
237 | imap <- readTVar (contactSession c) | ||
238 | let con = SingleCon s statvar | ||
239 | s0 = IntMap.lookup (sSessionID s) imap | ||
240 | imap' = IntMap.insert (sSessionID s) con imap | ||
241 | writeTVar (contactSession c) imap' | ||
242 | return (result,Just con,s0) | ||
243 | |||
244 | mapM_ (sClose . singleSession) replaced | ||
245 | forM_ mcon $ \con -> | ||
246 | forkSession c s $ \progress -> do | ||
247 | writeTVar (singleStatus con) progress | ||
248 | emap <- readTVar (contactEstablished c) | ||
249 | emap' <- case progress of | ||
250 | Established -> do | ||
251 | when (IntMap.null emap) $ notifyState c c s Established | ||
252 | return $ IntMap.insert (sSessionID s) () emap | ||
253 | _ -> do | ||
254 | let emap' = IntMap.delete (sSessionID s) emap | ||
255 | when (IntMap.null emap' && not (IntMap.null emap)) $ do | ||
256 | imap <- readTVar (contactSession c) | ||
257 | notifyState c c s | ||
258 | $ if IntMap.null imap then Dormant | ||
259 | else InProgress AwaitingSessionPacket | ||
260 | return emap' | ||
261 | writeTVar (contactEstablished c) emap' | ||
262 | return result | ||
263 | |||
264 | -- | Information returned from 'delSession'. | ||
265 | data DelResult = NoSession -- ^ Contact is completely disconnected. | ||
266 | | DeletedSession -- ^ Connection removed but session remains active. | ||
267 | |||
268 | -- | Close and remove the componenent session corresponding to the provided | ||
269 | -- Session ID. | ||
270 | -- | ||
271 | -- The status-change callback may be triggered as the aggregate may may | ||
272 | -- transition to 'Dormant' (empty) or 'AwaitingSessionPacket' (if the last | ||
273 | -- 'Established' session is closed). | ||
274 | delSession :: AggregateSession -> Int -> IO DelResult | ||
275 | delSession c sid = do | ||
276 | (con, r) <- atomically $ do | ||
277 | imap <- readTVar (contactSession c) | ||
278 | emap <- readTVar (contactEstablished c) | ||
279 | let emap' = IntMap.delete sid emap | ||
280 | imap' = IntMap.delete sid imap | ||
281 | case IntMap.toList emap of | ||
282 | (sid0,_):_ | IntMap.null emap' | ||
283 | , let s = singleSession $ imap IntMap.! sid0 | ||
284 | -> notifyState c c s | ||
285 | $ if IntMap.null imap' then Dormant | ||
286 | else InProgress AwaitingSessionPacket | ||
287 | _ -> return () | ||
288 | writeTVar (contactSession c) imap' | ||
289 | writeTVar (contactEstablished c) emap' | ||
290 | return ( IntMap.lookup sid imap, IntMap.null imap') | ||
291 | mapM_ (sClose . singleSession) con | ||
292 | return $ if r then NoSession | ||
293 | else DeletedSession | ||
294 | |||
295 | -- | Send a packet to one or all of the component sessions in the aggregate. | ||
296 | dispatchMessage :: AggregateSession -> Maybe Int -- ^ 'Nothing' to broadcast, otherwise SessionID. | ||
297 | -> CryptoMessage -> IO () | ||
298 | dispatchMessage c msid msg = join $ atomically $ do | ||
299 | imap <- readTVar (contactSession c) | ||
300 | let go = case msid of Nothing -> forM_ imap | ||
301 | Just sid -> forM_ (IntMap.lookup sid imap) | ||
302 | return $ go $ \con -> sendMessage (sTransport $ singleSession con) () msg | ||
303 | |||
304 | -- | Retry until: | ||
305 | -- | ||
306 | -- * a packet arrives (with component session ID) arrives. | ||
307 | -- | ||
308 | -- * the 'AggregateSession' is closed with 'closeAll'. | ||
309 | awaitAny :: AggregateSession -> STM (Maybe (Int,CryptoMessage)) | ||
310 | awaitAny c = readTMChan (contactChannel c) | ||
311 | |||
312 | -- | Close all connections associated with the aggregate. No new sessions will | ||
313 | -- be accepted after this, and the notify callback will be informed that we've | ||
314 | -- transitioned to 'Dormant'. | ||
315 | closeAll :: AggregateSession -> IO () | ||
316 | closeAll c = join $ atomically $ do | ||
317 | imap <- readTVar (contactSession c) | ||
318 | closeTMChan (contactChannel c) | ||
319 | return $ forM_ (IntMap.keys imap) $ \sid -> delSession c sid | ||
320 | |||
321 | -- | Query the current status of the aggregate, there are three possible | ||
322 | -- values: | ||
323 | -- | ||
324 | -- [ Dormant ] - No pending or established sessions. | ||
325 | -- | ||
326 | -- [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are | ||
327 | -- fully established. | ||
328 | -- | ||
329 | -- [ Established ] - At least one session is fully established and we can | ||
330 | -- send and receive packets via this aggregate. | ||
331 | -- | ||
332 | aggregateStatus :: AggregateSession -> STM (Status ToxProgress) | ||
333 | aggregateStatus c = do | ||
334 | isclosed <- isClosedTMChan (contactChannel c) | ||
335 | imap <- readTVar (contactSession c) | ||
336 | emap <- readTVar (contactEstablished c) | ||
337 | return $ case () of | ||
338 | _ | isclosed -> Dormant | ||
339 | | not (IntMap.null emap) -> Established | ||
340 | | not (IntMap.null imap) -> InProgress AwaitingSessionPacket | ||
341 | | otherwise -> Dormant | ||
342 | |||
343 | -- | Query whether the supplied ToxID keys are compatible with this aggregate. | ||
344 | -- | ||
345 | -- [ Nothing ] Any keys would be compatible because there is not yet any | ||
346 | -- sessions in progress. | ||
347 | -- | ||
348 | -- [ Just True ] The supplied keys match the session in progress. | ||
349 | -- | ||
350 | -- [ Just False ] The supplied keys are incompatible. | ||
351 | checkCompatible :: PublicKey -- ^ Local Tox key (for which we know the secret). | ||
352 | -> PublicKey -- ^ Remote Tox key. | ||
353 | -> AggregateSession -> STM (Maybe Bool) | ||
354 | checkCompatible me them c = do | ||
355 | isclosed <- isClosedTMChan (contactChannel c) | ||
356 | imap <- readTVar (contactSession c) | ||
357 | return $ case IntMap.elems imap of | ||
358 | _ | isclosed -> Just False -- All keys are incompatible (closed). | ||
359 | con:_ -> Just $ sTheirUserKey (singleSession con) == them | ||
360 | && toPublic (sOurKey $ singleSession con) == me | ||
361 | [] -> Nothing | ||
362 | |||
363 | -- | Returns the local and remote keys that are compatible with this aggregate. | ||
364 | -- If 'Nothing' Is returned, then either no key is compatible ('closeAll' was | ||
365 | -- called) or all keys are compatible because no sessions have been associated. | ||
366 | compatibleKeys :: AggregateSession -> STM (Maybe (PublicKey,PublicKey)) | ||
367 | compatibleKeys c = do | ||
368 | isclosed <- isClosedTMChan (contactChannel c) | ||
369 | imap <- readTVar (contactSession c) | ||
370 | return $ case IntMap.elems imap of | ||
371 | _ | isclosed -> Nothing -- none. | ||
372 | con:_ -> Just ( toPublic (sOurKey $ singleSession con) | ||
373 | , sTheirUserKey (singleSession con)) | ||
374 | [] -> Nothing -- any. | ||
diff --git a/src/Network/Tox/Avahi.hs b/src/Network/Tox/Avahi.hs deleted file mode 100644 index 635ba656..00000000 --- a/src/Network/Tox/Avahi.hs +++ /dev/null | |||
@@ -1,65 +0,0 @@ | |||
1 | {-# OPTIONS_GHC -Wall #-} | ||
2 | {-# LANGUAGE RecordWildCards #-} | ||
3 | {-# LANGUAGE ViewPatterns #-} | ||
4 | module Network.Tox.Avahi | ||
5 | ( module Network.Tox.Avahi | ||
6 | , NodeInfo(..) | ||
7 | , NodeId | ||
8 | ) where | ||
9 | |||
10 | import Control.Applicative | ||
11 | import Data.Foldable | ||
12 | import Network.Address | ||
13 | import Network.Avahi | ||
14 | import Network.BSD (getHostName) | ||
15 | import Network.Tox.NodeId | ||
16 | import Text.Read | ||
17 | |||
18 | toxServiceName :: String | ||
19 | toxServiceName = "_tox_dht._udp" | ||
20 | |||
21 | toxServiceDomain :: String | ||
22 | toxServiceDomain = "local" | ||
23 | |||
24 | (<.>) :: String -> String -> String | ||
25 | a <.> b = a ++ "." ++ b | ||
26 | |||
27 | toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service | ||
28 | toxService hostname (fromIntegral -> port) dhtkey toxid = | ||
29 | Service { | ||
30 | serviceProtocol = PROTO_UNSPEC, | ||
31 | serviceName = "Tox DHT @ " ++ hostname, | ||
32 | serviceType = toxServiceName, | ||
33 | serviceDomain = toxServiceDomain, | ||
34 | serviceHost = if null hostname then "" else hostname <.> toxServiceDomain, | ||
35 | serviceAddress = Nothing, | ||
36 | servicePort = port, | ||
37 | serviceText = maybe (show dhtkey) (show . ((,) dhtkey)) toxid | ||
38 | } | ||
39 | |||
40 | announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO () | ||
41 | announceToxServiceWithHostname = (boobs.boobs) announce toxService | ||
42 | where boobs = ((.).(.)) | ||
43 | |||
44 | announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO () | ||
45 | announceToxService a b c = do | ||
46 | h <- getHostName | ||
47 | announceToxServiceWithHostname h a b c | ||
48 | |||
49 | queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO () | ||
50 | queryToxService cb = | ||
51 | browse $ | ||
52 | BrowseQuery | ||
53 | { lookupProtocol = PROTO_UNSPEC | ||
54 | , lookupServiceName = toxServiceName | ||
55 | , lookupDomain = toxServiceDomain | ||
56 | , lookupCallback = runCallback | ||
57 | } | ||
58 | where | ||
59 | runCallback Service {..} = do | ||
60 | let both :: Maybe (NodeId, NodeId) | ||
61 | both = readMaybe serviceText | ||
62 | nid = (fst <$> both) <|> readMaybe serviceText | ||
63 | addr = readMaybe =<< serviceAddress | ||
64 | p = fromIntegral servicePort | ||
65 | forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both) | ||
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs deleted file mode 100644 index e7cb48c1..00000000 --- a/src/Network/Tox/ContactInfo.hs +++ /dev/null | |||
@@ -1,172 +0,0 @@ | |||
1 | {-# LANGUAGE NamedFieldPuns #-} | ||
2 | {-# LANGUAGE LambdaCase #-} | ||
3 | module Network.Tox.ContactInfo where | ||
4 | |||
5 | import Connection | ||
6 | |||
7 | import Data.Time.Clock.POSIX | ||
8 | import Control.Concurrent.STM | ||
9 | import Control.Monad | ||
10 | import Crypto.PubKey.Curve25519 | ||
11 | import qualified Data.HashMap.Strict as HashMap | ||
12 | ;import Data.HashMap.Strict (HashMap) | ||
13 | import Data.Maybe | ||
14 | import Network.Tox.DHT.Transport as DHT | ||
15 | import Network.Tox.NodeId (id2key) | ||
16 | import Network.Tox.Onion.Transport as Onion | ||
17 | import DPut | ||
18 | import DebugTag | ||
19 | |||
20 | newtype ContactInfo extra = ContactInfo | ||
21 | -- | Map our toxid public key to an Account record. | ||
22 | { accounts :: TVar (HashMap NodeId{-my userkey-} (Account extra)) | ||
23 | } | ||
24 | |||
25 | data Account extra = Account | ||
26 | { userSecret :: SecretKey -- local secret key | ||
27 | , contacts :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info | ||
28 | , accountExtra :: TVar extra | ||
29 | , eventChan :: TChan ContactEvent | ||
30 | } | ||
31 | |||
32 | data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData } | ||
33 | | PolicyChange { contact :: PublicKey, policyChange :: Policy } | ||
34 | | AddrChange { contact :: PublicKey, addrChange :: NodeInfo } | ||
35 | | SessionEstablished { contact :: PublicKey } | ||
36 | | SessionTerminated { contact :: PublicKey } | ||
37 | |||
38 | data Contact = Contact | ||
39 | { contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey)) | ||
40 | , contactLastSeenAddr :: TVar (Maybe (POSIXTime,NodeInfo)) | ||
41 | , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest)) | ||
42 | , contactPolicy :: TVar (Maybe Connection.Policy) | ||
43 | } | ||
44 | |||
45 | newContactInfo :: IO (ContactInfo extra) | ||
46 | newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty | ||
47 | |||
48 | myKeyPairs :: ContactInfo extra -> STM [(SecretKey,PublicKey)] | ||
49 | myKeyPairs (ContactInfo accounts) = do | ||
50 | acnts <- readTVar accounts | ||
51 | forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do | ||
52 | return (userSecret,id2key nid) | ||
53 | |||
54 | updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO () | ||
55 | updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do | ||
56 | dput XMisc "updateContactInfo!!!" | ||
57 | now <- getPOSIXTime | ||
58 | atomically $ do | ||
59 | as <- readTVar (accounts roster) | ||
60 | maybe (return ()) | ||
61 | (updateAccount now remoteUserKey omsg) | ||
62 | $ HashMap.lookup (key2id localUserKey) as | ||
63 | |||
64 | initContact :: STM Contact | ||
65 | initContact = Contact <$> newTVar Nothing | ||
66 | <*> newTVar Nothing | ||
67 | <*> newTVar Nothing | ||
68 | <*> newTVar Nothing | ||
69 | |||
70 | getContact :: PublicKey -> Account extra -> STM (Maybe Contact) | ||
71 | getContact remoteUserKey acc = do | ||
72 | let rkey = key2id remoteUserKey | ||
73 | cmap <- readTVar (contacts acc) | ||
74 | return $ HashMap.lookup rkey cmap | ||
75 | |||
76 | updateAccount' :: PublicKey -> Account extra -> (Contact -> STM ()) -> STM () | ||
77 | updateAccount' remoteUserKey acc updater = do | ||
78 | let rkey = key2id remoteUserKey | ||
79 | cmap <- readTVar (contacts acc) | ||
80 | contact <- case HashMap.lookup rkey cmap of | ||
81 | Just contact -> return contact | ||
82 | Nothing -> do contact <- initContact | ||
83 | writeTVar (contacts acc) $ HashMap.insert rkey contact cmap | ||
84 | return contact | ||
85 | updater contact | ||
86 | |||
87 | updateAccount :: POSIXTime -> PublicKey -> Onion.OnionData -> Account extra -> STM () | ||
88 | updateAccount now remoteUserKey omsg acc = do | ||
89 | updateAccount' remoteUserKey acc $ onionUpdate now omsg | ||
90 | writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg | ||
91 | |||
92 | onionUpdate :: POSIXTime -> OnionData -> Contact -> STM () | ||
93 | onionUpdate now (Onion.OnionDHTPublicKey dhtpk) contact | ||
94 | = writeTVar (contactKeyPacket contact) $ Just (now,dhtpk) | ||
95 | onionUpdate now (Onion.OnionFriendRequest fr) contact | ||
96 | = writeTVar (contactFriendRequest contact) $ Just (now,fr) | ||
97 | |||
98 | policyUpdate :: Policy -> Contact -> STM () | ||
99 | policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy | ||
100 | |||
101 | addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM () | ||
102 | addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr) | ||
103 | |||
104 | setContactPolicy :: PublicKey -> Policy -> Account extra -> STM () | ||
105 | setContactPolicy remoteUserKey policy acc = do | ||
106 | updateAccount' remoteUserKey acc $ policyUpdate policy | ||
107 | writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy | ||
108 | |||
109 | setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM () | ||
110 | setContactAddr now remoteUserKey addr acc = do | ||
111 | contact <- getContact remoteUserKey acc | ||
112 | let update = updateAccount' remoteUserKey acc $ addrUpdate now addr | ||
113 | let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr | ||
114 | join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case | ||
115 | Just (_, a) | addr == a -> update -- updates time only | ||
116 | Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old | ||
117 | Nothing -> update >> notify -- or if we don't have any | ||
118 | _ -> return () -- otherwise just wait | ||
119 | |||
120 | setEstablished :: PublicKey -> Account extra -> STM () | ||
121 | setEstablished remoteUserKey acc = | ||
122 | writeTChan (eventChan acc) $ SessionEstablished remoteUserKey | ||
123 | |||
124 | setTerminated :: PublicKey -> Account extra -> STM () | ||
125 | setTerminated remoteUserKey acc = | ||
126 | writeTChan (eventChan acc) $ SessionTerminated remoteUserKey | ||
127 | |||
128 | |||
129 | addContactInfo :: ContactInfo extra -> SecretKey -> extra -> STM () | ||
130 | addContactInfo (ContactInfo as) sk extra = do | ||
131 | a <- newAccount sk extra | ||
132 | modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a | ||
133 | |||
134 | delContactInfo :: ContactInfo extra -> PublicKey -> STM () | ||
135 | delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk) | ||
136 | |||
137 | newAccount :: SecretKey -> extra -> STM (Account extra) | ||
138 | newAccount sk extra = Account sk <$> newTVar HashMap.empty | ||
139 | <*> newTVar extra | ||
140 | <*> newBroadcastTChan | ||
141 | |||
142 | dnsPresentation :: ContactInfo extra -> STM String | ||
143 | dnsPresentation (ContactInfo accsvar) = do | ||
144 | accs <- readTVar accsvar | ||
145 | ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do | ||
146 | cs <- readTVar cvar | ||
147 | rs <- forM (HashMap.toList cs) $ \(nid,c) -> do | ||
148 | mkpkt <- readTVar (contactKeyPacket c) | ||
149 | return $ fmap (\(_,d) -> (nid,d)) mkpkt | ||
150 | return $ | ||
151 | "; local key = " ++ show (key2id $ toPublic sec) ++ "\n" | ||
152 | ++ concatMap dnsPresentation1 (catMaybes rs) | ||
153 | return $ concat ms | ||
154 | |||
155 | dnsPresentation1 :: (NodeId,DHTPublicKey) -> String | ||
156 | dnsPresentation1 (nid,dk) = unlines | ||
157 | [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ] | ||
158 | ] | ||
159 | |||
160 | type LocalKey = NodeId | ||
161 | type RemoteKey = NodeId | ||
162 | |||
163 | friendRequests :: ContactInfo extra -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)]) | ||
164 | friendRequests (ContactInfo roster) = do | ||
165 | accs <- readTVar roster | ||
166 | forM accs $ \Account { userSecret = sec, contacts = cvar } -> do | ||
167 | cs <- readTVar cvar | ||
168 | rs <- forM (HashMap.toList cs) $ \(nid,c) -> do | ||
169 | mfr <- readTVar (contactFriendRequest c) | ||
170 | return $ fmap (\(_,x) -> (nid,x)) mfr | ||
171 | return $ catMaybes rs | ||
172 | |||
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs deleted file mode 100644 index a18b550d..00000000 --- a/src/Network/Tox/Crypto/Transport.hs +++ /dev/null | |||
@@ -1,1029 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE DataKinds #-} | ||
3 | {-# LANGUAGE FlexibleInstances #-} | ||
4 | {-# LANGUAGE GADTs #-} | ||
5 | {-# LANGUAGE KindSignatures #-} | ||
6 | {-# LANGUAGE LambdaCase #-} | ||
7 | {-# LANGUAGE NamedFieldPuns #-} | ||
8 | {-# LANGUAGE PatternSynonyms #-} | ||
9 | {-# LANGUAGE StandaloneDeriving #-} | ||
10 | {-# LANGUAGE TupleSections #-} | ||
11 | {-# LANGUAGE ViewPatterns #-} | ||
12 | module Network.Tox.Crypto.Transport | ||
13 | ( showCryptoMsg | ||
14 | , parseCrypto | ||
15 | , encodeCrypto | ||
16 | , unpadCryptoMsg | ||
17 | , decodeRawCryptoMsg | ||
18 | , parseHandshakes | ||
19 | , encodeHandshakes | ||
20 | , CryptoData(..) | ||
21 | , CryptoMessage(..) | ||
22 | , MessageName(..) | ||
23 | , CryptoPacket(..) | ||
24 | , HandshakeData(..) | ||
25 | , Handshake(..) | ||
26 | , PeerInfo(..) | ||
27 | , UserStatus(..) | ||
28 | , TypingStatus(..) | ||
29 | , GroupChatId(..) | ||
30 | , MessageType(..) | ||
31 | , isKillPacket, isOFFLINE | ||
32 | , KnownLossyness(..) | ||
33 | , AsWord16(..) | ||
34 | , AsWord64(..) | ||
35 | -- feild name classes | ||
36 | , HasGroupChatID(..) | ||
37 | , HasGroupNumber(..) | ||
38 | , HasPeerNumber(..) | ||
39 | , HasMessageNumber(..) | ||
40 | , HasMessageName(..) | ||
41 | , HasMessageData(..) | ||
42 | , HasName(..) | ||
43 | , HasTitle(..) | ||
44 | , HasMessage(..) | ||
45 | , HasMessageType(..) | ||
46 | -- lenses | ||
47 | #ifdef USE_lens | ||
48 | , groupNumber, groupNumberToJoin, peerNumber, messageNumber | ||
49 | , messageName, messageData, name, title, message, messageType | ||
50 | #endif | ||
51 | -- constructor | ||
52 | -- utils | ||
53 | , sizedN | ||
54 | , sizedAtLeastN | ||
55 | , isIndirectGrpChat | ||
56 | , fromEnum8 | ||
57 | , fromEnum16 | ||
58 | , toEnum8 | ||
59 | , getCryptoMessage | ||
60 | , putCryptoMessage | ||
61 | ) where | ||
62 | |||
63 | import Crypto.Tox | ||
64 | import Data.Tox.Msg | ||
65 | import Network.Tox.DHT.Transport (Cookie) | ||
66 | import Network.Tox.NodeId | ||
67 | import DPut | ||
68 | import DebugTag | ||
69 | import Data.PacketBuffer as PB | ||
70 | |||
71 | import Network.Socket | ||
72 | import Data.ByteArray | ||
73 | import Data.Dependent.Sum | ||
74 | |||
75 | import Control.Monad | ||
76 | import Data.ByteString as B | ||
77 | import Data.Function | ||
78 | import Data.Maybe | ||
79 | import Data.Monoid | ||
80 | import Data.Word | ||
81 | import Data.Bits | ||
82 | import Crypto.Hash | ||
83 | import Data.Functor.Contravariant | ||
84 | import Data.Functor.Identity | ||
85 | import Data.Text as T | ||
86 | import Data.Text.Encoding as T | ||
87 | import Data.Serialize as S | ||
88 | import Control.Arrow | ||
89 | import GHC.TypeNats | ||
90 | |||
91 | showCryptoMsg :: Word32 -> CryptoMessage -> [Char] | ||
92 | showCryptoMsg _ msg = show msg | ||
93 | |||
94 | parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) | ||
95 | parseCrypto (bbs,saddr) = case B.uncons bbs of | ||
96 | Just (0x1b,bs) -> case runGet get bs of | ||
97 | Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet. | ||
98 | Left _ -> Right (bs,saddr) -- Failed parse, strip first byte and pass it on. | ||
99 | _ -> Right (bbs,saddr) -- Type-code mismatch, pass it on. | ||
100 | |||
101 | encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr) | ||
102 | encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr) | ||
103 | |||
104 | parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr) | ||
105 | parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseHandshakes: "++) $ (,saddr) <$> runGet get pkt | ||
106 | parseHandshakes bs _ = Left $ "parseHandshakes_: " ++ show (B.unpack $ B.take 1 bs) | ||
107 | |||
108 | encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr) | ||
109 | encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr) | ||
110 | |||
111 | {- | ||
112 | createRequestPacket :: Word32 -> [Word32] -> CryptoMessage | ||
113 | createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns) | ||
114 | in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r | ||
115 | where | ||
116 | ys = Prelude.map (subtract (seqno - 1)) xs | ||
117 | reduceToSums [] = [] | ||
118 | reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs) | ||
119 | makeZeroes :: Word32 -> [Word32] | ||
120 | -- makeZeroes 0 = [] | ||
121 | makeZeroes x | ||
122 | = let (d,m)= x `divMod` 255 | ||
123 | zeros= Prelude.replicate (fromIntegral d) 0 | ||
124 | in zeros ++ [m] | ||
125 | ns :: [Word8] | ||
126 | ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes) | ||
127 | -} | ||
128 | |||
129 | data Handshake (f :: * -> *) = Handshake | ||
130 | { -- The cookie is a cookie obtained by | ||
131 | -- sending a cookie request packet to the peer and getting a cookie | ||
132 | -- response packet with a cookie in it. It may also be obtained in the | ||
133 | -- handshake packet by a peer receiving a handshake packet (Other | ||
134 | -- Cookie). | ||
135 | handshakeCookie :: Cookie f | ||
136 | -- The nonce is a nonce used to encrypt the encrypted part of the handshake | ||
137 | -- packet. | ||
138 | , handshakeNonce :: Nonce24 | ||
139 | -- The encrypted part of the handshake packet is encrypted with the long | ||
140 | -- term user-keys of both peers. | ||
141 | , handshakeData :: f HandshakeData | ||
142 | } | ||
143 | |||
144 | instance Serialize (Handshake Encrypted) where | ||
145 | get = Handshake <$> get <*> get <*> get | ||
146 | put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta | ||
147 | |||
148 | data HandshakeData = HandshakeData | ||
149 | { baseNonce :: Nonce24 | ||
150 | -- ^ 24 bytes base nonce, recipient uses this to encrypt packets sent to the one who sent this handshake | ||
151 | -- adding one each time, so it can double as something like an approximate packet number | ||
152 | , sessionKey :: PublicKey | ||
153 | -- ^ session public key of the peer (32 bytes) | ||
154 | -- The recipient of the handshake encrypts using this public key when sending CryptoPackets | ||
155 | , cookieHash :: Digest SHA512 | ||
156 | -- ^ sha512 hash of the entire Cookie sitting outside the encrypted part | ||
157 | -- This prevents a replay attack where a new cookie is inserted into | ||
158 | -- an old valid handshake packet | ||
159 | , otherCookie :: Cookie Encrypted | ||
160 | -- ^ Other Cookie (used by the recipient to respond to the handshake packet) | ||
161 | } | ||
162 | deriving (Eq,Ord,Show) | ||
163 | |||
164 | instance Sized HandshakeData where | ||
165 | size = contramap baseNonce size | ||
166 | <> contramap (key2id . sessionKey) size | ||
167 | <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512) | ||
168 | <> contramap otherCookie size | ||
169 | |||
170 | instance Serialize HandshakeData where | ||
171 | get = HandshakeData <$> get | ||
172 | <*> getPublicKey | ||
173 | <*> (fromJust . digestFromByteString <$> getBytes 64) | ||
174 | <*> get | ||
175 | put (HandshakeData n k h c) = do | ||
176 | put n | ||
177 | putPublicKey k | ||
178 | putByteString (convert h) | ||
179 | put c | ||
180 | |||
181 | data CryptoPacket (f :: * -> *) = CryptoPacket | ||
182 | { -- | The last 2 bytes of the nonce used to encrypt 'pktData' | ||
183 | pktNonce :: Word16 | ||
184 | -- The payload is encrypted with the session key and 'baseNonce' set by | ||
185 | -- the receiver in their handshake + packet number (starting at 0, big | ||
186 | -- endian math). | ||
187 | , pktData :: f CryptoData | ||
188 | } | ||
189 | |||
190 | deriving instance Show (CryptoPacket Encrypted) | ||
191 | |||
192 | instance Sized CryptoData where | ||
193 | size = contramap bufferStart size | ||
194 | <> contramap bufferEnd size | ||
195 | <> contramap bufferData size | ||
196 | |||
197 | instance Serialize (CryptoPacket Encrypted) where | ||
198 | get = CryptoPacket <$> get <*> get | ||
199 | put (CryptoPacket n16 dta) = put n16 >> put dta | ||
200 | |||
201 | data CryptoData = CryptoData | ||
202 | { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)] | ||
203 | bufferStart :: Word32 | ||
204 | -- | [ uint32_t packet number if lossless | ||
205 | -- , sendbuffer buffer_end if lossy , (big endian)] | ||
206 | , bufferEnd :: Word32 | ||
207 | -- | [data] (TODO See Note [Padding]) | ||
208 | , bufferData :: CryptoMessage | ||
209 | } deriving (Eq,Show) | ||
210 | |||
211 | {- | ||
212 | Note [Padding] | ||
213 | |||
214 | TODO: The 'bufferData' field of 'CryptoData' should probably be something like | ||
215 | /Padded CryptoMessage/ because c-toxcore strips leading zeros on incoming and | ||
216 | pads leading zeros on outgoing packets. | ||
217 | |||
218 | After studying c-toxcore (at commit c49a6e7f5bc245a51a3c85cc2c8b7f881c412998), | ||
219 | I've determined the following behavior. | ||
220 | |||
221 | Incoming: All leading zero bytes are stripped until possibly the whole packet | ||
222 | is consumed (in which case it is discarded). This happens at | ||
223 | toxcore/net_crypto.c:1366:handle_data_packet_core(). | ||
224 | |||
225 | Outgoing: The number of zeros added is: | ||
226 | |||
227 | padding_length len = (1373 - len) `mod` 8 where | ||
228 | |||
229 | where /len/ is the size of the non-padded CryptoMessage. This happens at | ||
230 | toxcore/net_crypto.c:936:send_data_packet_helper() | ||
231 | |||
232 | The number 1373 is written in C as MAX_CRYPTO_DATA_SIZE which is defined in | ||
233 | terms of the max /NetCrypto/ packet size (1400) minus the minimum possible size | ||
234 | of an id-byte (1) and a /CryptoPacket Encrypted/ ( 2 + 4 + 4 + 16 ). | ||
235 | |||
236 | One effect of this is that short messages will be padded to at least 5 bytes. | ||
237 | -} | ||
238 | |||
239 | instance Serialize CryptoData where | ||
240 | get = do | ||
241 | ack <- get | ||
242 | seqno <- get | ||
243 | cm <- getCryptoMessage ack | ||
244 | return $ CryptoData ack seqno cm | ||
245 | put (CryptoData ack seqno dta) = do | ||
246 | put ack | ||
247 | put seqno | ||
248 | putCryptoMessage ack dta | ||
249 | |||
250 | data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum) | ||
251 | instance Serialize TypingStatus where | ||
252 | get = do | ||
253 | x <- get :: Get Word8 | ||
254 | return (toEnum8 x) | ||
255 | put x = put (fromEnum8 x :: Word8) | ||
256 | |||
257 | unpadCryptoMsg :: CryptoMessage -> CryptoMessage | ||
258 | unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) = | ||
259 | let unpadded = B.dropWhile (== msgbyte Padding) bs | ||
260 | in either (const msg) id $ runGet (getCryptoMessage 0) unpadded | ||
261 | unpadCryptoMsg msg = msg | ||
262 | |||
263 | decodeRawCryptoMsg :: CryptoData -> CryptoMessage | ||
264 | decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm | ||
265 | |||
266 | instance Sized CryptoMessage where | ||
267 | size = VarSize $ \case | ||
268 | Pkt t :=> Identity x -> case sizeFor t of | ||
269 | ConstSize sz -> 1 + sz | ||
270 | VarSize f -> 1 + f x | ||
271 | |||
272 | sizeFor :: Sized x => p x -> Size x | ||
273 | sizeFor _ = size | ||
274 | |||
275 | |||
276 | getCryptoMessage :: Word32 -> Get CryptoMessage | ||
277 | getCryptoMessage seqno = fix $ \stripPadding -> do | ||
278 | t <- getWord8 | ||
279 | case msgTag t of | ||
280 | Just (M Padding) -> stripPadding | ||
281 | Just (M msg) -> do x <- getPacket seqno | ||
282 | return $ Pkt msg ==> x | ||
283 | Nothing -> return $ Pkt MESSAGE ==> "Unhandled packet: " <> T.pack (show t) -- $ Pkt Padding ==> Padded mempty | ||
284 | |||
285 | putCryptoMessage :: Word32 -> CryptoMessage -> Put | ||
286 | putCryptoMessage seqno (Pkt t :=> Identity x) = do | ||
287 | putWord8 (msgbyte t) | ||
288 | putPacket seqno x | ||
289 | |||
290 | |||
291 | #ifdef USE_lens | ||
292 | erCompat :: String -> a | ||
293 | erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type" | ||
294 | #endif | ||
295 | |||
296 | |||
297 | newtype GroupChatId = GrpId ByteString -- 33 bytes | ||
298 | deriving (Show,Eq) | ||
299 | |||
300 | class HasGroupChatID x where | ||
301 | getGroupChatID :: x -> GroupChatId | ||
302 | setGroupChatID :: x -> GroupChatId -> x | ||
303 | |||
304 | sizedN :: Int -> ByteString -> ByteString | ||
305 | sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) | ||
306 | else B.take n bs | ||
307 | |||
308 | sizedAtLeastN :: Int -> ByteString -> ByteString | ||
309 | sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) | ||
310 | else bs | ||
311 | |||
312 | {- | ||
313 | instance HasGroupChatID CryptoMessage where | ||
314 | -- Get | ||
315 | getGroupChatID (Pkt INVITE_CONFERENCE :=> Identity payload) | ||
316 | = let (xs,ys) = B.splitAt 1 payload' | ||
317 | payload' = sizedN 38 payload | ||
318 | in case B.unpack xs of | ||
319 | [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number | ||
320 | [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers | ||
321 | _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message" | ||
322 | |||
323 | getGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload)) | ||
324 | getGroupChatID _ = error "getGroupChatID on non-groupchat message." | ||
325 | |||
326 | -- Set | ||
327 | setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity payload) (GrpId newid) | ||
328 | = let (xs,ys) = B.splitAt 1 payload' | ||
329 | payload' = sizedN 38 payload | ||
330 | in case B.unpack xs of | ||
331 | [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number | ||
332 | [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers | ||
333 | _ -> msg -- unexpected condition, leave unchanged | ||
334 | |||
335 | setGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt ONLINE_PACKET ==> (B.concat [B.take 2 payload, sizedN 33 newid]) | ||
336 | setGroupChatID _ _= error "setGroupChatID on non-groupchat message." | ||
337 | -} | ||
338 | |||
339 | #ifdef USE_lens | ||
340 | groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x) | ||
341 | groupChatID = lens getGroupChatID setGroupChatID | ||
342 | #endif | ||
343 | |||
344 | type GroupNumber = Word16 | ||
345 | type PeerNumber = Word16 | ||
346 | type MessageNumber = Word32 | ||
347 | |||
348 | class HasGroupNumber x where | ||
349 | getGroupNumber :: x -> GroupNumber | ||
350 | setGroupNumber :: x -> GroupNumber -> x | ||
351 | |||
352 | {- | ||
353 | instance HasGroupNumber CryptoMessage where | ||
354 | getGroupNumber (Pkt INVITE_CONFERENCE :=> Identity (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1 | ||
355 | = let twobytes = B.take 2 xs | ||
356 | Right n = S.decode twobytes | ||
357 | in n | ||
358 | getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63 | ||
359 | = let Right n = S.decode twobytes in n | ||
360 | getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes)) | ||
361 | = let Right n = S.decode twobytes in n | ||
362 | |||
363 | getGroupNumber _ = error "getGroupNumber on CryptoMessage without group number field." | ||
364 | |||
365 | setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum | ||
366 | = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs))) | ||
367 | setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum | ||
368 | | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs) | ||
369 | | x == 0xC7 = UpToN xE (B.append (S.encode groupnum) xs) | ||
370 | setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field." | ||
371 | -} | ||
372 | |||
373 | #ifdef USE_lens | ||
374 | groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x) | ||
375 | groupNumber = lens getGroupNumber setGroupNumber | ||
376 | #endif | ||
377 | |||
378 | class HasGroupNumberToJoin x where | ||
379 | getGroupNumberToJoin :: x -> GroupNumber | ||
380 | setGroupNumberToJoin :: x -> GroupNumber -> x | ||
381 | |||
382 | {- | ||
383 | instance HasGroupNumberToJoin CryptoMessage where | ||
384 | getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join | ||
385 | = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local) | ||
386 | Right n = S.decode twobytes | ||
387 | in n | ||
388 | getGroupNumberToJoin _ = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field." | ||
389 | setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum | ||
390 | = let (a,b) = B.splitAt 2 xs | ||
391 | (twoBytes,c) = B.splitAt 2 b | ||
392 | twoBytes' = S.encode groupnum | ||
393 | in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c])) | ||
394 | setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field." | ||
395 | -} | ||
396 | |||
397 | #ifdef USE_lens | ||
398 | groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x) | ||
399 | groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin | ||
400 | #endif | ||
401 | |||
402 | class HasPeerNumber x where | ||
403 | getPeerNumber :: x -> PeerNumber | ||
404 | setPeerNumber :: x -> PeerNumber -> x | ||
405 | |||
406 | {- | ||
407 | instance HasPeerNumber CryptoMessage where | ||
408 | getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) | ||
409 | = let Right n = S.decode twobytes in n | ||
410 | getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) | ||
411 | = let Right n = S.decode twobytes in n | ||
412 | getPeerNumber _ = error "getPeerNumber on CryptoMessage without peer number field." | ||
413 | |||
414 | setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum | ||
415 | = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) | ||
416 | setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum | ||
417 | = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) | ||
418 | setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field." | ||
419 | -} | ||
420 | |||
421 | #ifdef USE_lens | ||
422 | peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x) | ||
423 | peerNumber = lens getPeerNumber setPeerNumber | ||
424 | #endif | ||
425 | |||
426 | class HasMessageNumber x where | ||
427 | getMessageNumber :: x -> MessageNumber | ||
428 | setMessageNumber :: x -> MessageNumber -> x | ||
429 | |||
430 | {- | ||
431 | instance HasMessageNumber CryptoMessage where | ||
432 | getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) | ||
433 | = let Right n = S.decode fourbytes in n | ||
434 | getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) | ||
435 | = let Right n = S.decode fourbytes in n | ||
436 | getMessageNumber _ = error "getMessageNumber on CryptoMessage without message number field." | ||
437 | |||
438 | setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum | ||
439 | = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) | ||
440 | setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum | ||
441 | = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) | ||
442 | setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field." | ||
443 | -} | ||
444 | |||
445 | #ifdef USE_lens | ||
446 | messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x) | ||
447 | messageNumber = lens getMessageNumber setMessageNumber | ||
448 | #endif | ||
449 | |||
450 | class HasMessageName x where | ||
451 | getMessageName :: x -> MessageName | ||
452 | setMessageName :: x -> MessageName -> x | ||
453 | |||
454 | {- | ||
455 | instance HasMessageName CryptoMessage where | ||
456 | getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) | ||
457 | = let [n] = B.unpack onebyte | ||
458 | in toEnum . fromIntegral $ n | ||
459 | getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) | ||
460 | = let [n] = B.unpack onebyte | ||
461 | in toEnum . fromIntegral $ n | ||
462 | getMessageName _ = error "getMessageName on CryptoMessage without message name field." | ||
463 | |||
464 | setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename | ||
465 | = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) | ||
466 | setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename | ||
467 | = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) | ||
468 | setMessageName _ _ = error "setMessageName on CryptoMessage without message name field." | ||
469 | -} | ||
470 | |||
471 | #ifdef USE_lens | ||
472 | messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x) | ||
473 | messageName = lens getMessageName setMessageName | ||
474 | #endif | ||
475 | |||
476 | data KnownLossyness = KnownLossy | KnownLossless | ||
477 | deriving (Eq,Ord,Show,Enum) | ||
478 | |||
479 | data MessageType = Msg Word8 | ||
480 | | GrpMsg KnownLossyness MessageName | ||
481 | deriving (Eq,Show) | ||
482 | |||
483 | class AsWord16 a where | ||
484 | toWord16 :: a -> Word16 | ||
485 | fromWord16 :: Word16 -> a | ||
486 | |||
487 | class AsWord64 a where | ||
488 | toWord64 :: a -> Word64 | ||
489 | fromWord64 :: Word64 -> a | ||
490 | |||
491 | |||
492 | fromEnum16 :: Enum a => a -> Word16 | ||
493 | fromEnum16 = fromIntegral . fromEnum | ||
494 | |||
495 | fromEnum64 :: Enum a => a -> Word64 | ||
496 | fromEnum64 = fromIntegral . fromEnum | ||
497 | |||
498 | |||
499 | -- MessageType, for our client keep it inside 16 bits | ||
500 | -- but we should extend it to 32 or even 64 on the wire. | ||
501 | -- Bits: 000000glxxxxxxxx, x = message id or extension specific, l = if extended, lossy/lossless, g = if extended, nongroup/group | ||
502 | -- (at least one bit set in high byte means extended, if none but the g flag and possibly l flag, assume default grp extension) | ||
503 | instance AsWord16 MessageType where | ||
504 | toWord16 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8) | ||
505 | toWord16 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromEnum8 msgName) | ||
506 | fromWord16 x | x < 256 = Msg (toEnum $ fromIntegral x) | ||
507 | fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x) | ||
508 | fromWord16 x = error "Not clear how to convert Word16 to MessageType" | ||
509 | |||
510 | instance AsWord64 MessageType where | ||
511 | toWord64 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8) | ||
512 | toWord64 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum64 lsy) + fromIntegral (fromEnum8 msgName) | ||
513 | fromWord64 x | x < 256 = Msg (toEnum $ fromIntegral x) | ||
514 | fromWord64 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x) | ||
515 | fromWord64 x = error "Not clear how to convert Word64 to MessageType" | ||
516 | |||
517 | #ifdef USE_lens | ||
518 | word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x) | ||
519 | word16 = lens toWord16 (\_ x -> fromWord16 x) | ||
520 | #endif | ||
521 | |||
522 | instance Ord MessageType where | ||
523 | compare (Msg x) (Msg y) = compare x y | ||
524 | compare (GrpMsg lx x) (GrpMsg ly y) = let r1 = compare lx ly | ||
525 | in if r1==EQ then compare x y else r1 | ||
526 | compare (Msg _) (GrpMsg _ _) = LT | ||
527 | compare (GrpMsg _ _) (Msg _) = GT | ||
528 | |||
529 | class HasMessageType x where | ||
530 | getMessageType :: x -> MessageType | ||
531 | setMessageType :: x -> MessageType -> x | ||
532 | |||
533 | {- | ||
534 | instance HasMessageType CryptoMessage where | ||
535 | getMessageType (OneByte mid) = Msg mid | ||
536 | getMessageType (TwoByte mid _) = Msg mid | ||
537 | getMessageType m@(UpToN MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m) | ||
538 | getMessageType m@(UpToN LOSSY_GROUPCHAT _) = GrpMsg KnownLossy (getMessageName m) | ||
539 | getMessageType (UpToN mid _) = Msg mid | ||
540 | |||
541 | setMessageType (OneByte _ ) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty ) mname | ||
542 | setMessageType (TwoByte _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname | ||
543 | setMessageType (OneByte _ ) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT B.empty ) mname | ||
544 | setMessageType (TwoByte _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT (B.singleton x)) mname | ||
545 | setMessageType (UpToN _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname | ||
546 | setMessageType (UpToN _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT x) mname | ||
547 | setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid | ||
548 | setMessageType (OneByte mid0 ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0 | ||
549 | setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x | ||
550 | setMessageType (UpToN mid0 x) (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x) | ||
551 | setMessageType (OneByte mid0) (Msg mid) = UpToN mid B.empty | ||
552 | setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x) | ||
553 | setMessageType (UpToN mid0 x) (Msg mid) = UpToN mid x | ||
554 | -} | ||
555 | |||
556 | {- | ||
557 | instance HasMessageType CryptoData where | ||
558 | getMessageType (CryptoData { bufferData }) = getMessageType bufferData | ||
559 | setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ } | ||
560 | -} | ||
561 | |||
562 | #ifdef USE_lens | ||
563 | -- | This lens should always succeed on CryptoMessage | ||
564 | messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x) | ||
565 | messageType = lens getMessageType setMessageType | ||
566 | #endif | ||
567 | |||
568 | type MessageData = B.ByteString | ||
569 | |||
570 | class HasMessageData x where | ||
571 | getMessageData :: x -> MessageData | ||
572 | setMessageData :: x -> MessageData -> x | ||
573 | |||
574 | {- | ||
575 | instance HasMessageData CryptoMessage where | ||
576 | getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata | ||
577 | getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata | ||
578 | getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos | ||
579 | -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8 | ||
580 | getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title | ||
581 | getMessageData _ = error "getMessageData on CryptoMessage without message data field." | ||
582 | |||
583 | setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT | ||
584 | = UpToN xE (B.concat [bs,messagedata]) | ||
585 | setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT | ||
586 | = UpToN xE (B.concat [bs,messagedata]) | ||
587 | setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets | ||
588 | = UpToN xE (B.concat [bs,peerinfosOrTitle]) | ||
589 | setMessageData _ _ = error "setMessageData on CryptoMessage without message data field." | ||
590 | -} | ||
591 | |||
592 | #ifdef USE_lens | ||
593 | messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x) | ||
594 | messageData = lens getMessageData setMessageData | ||
595 | #endif | ||
596 | |||
597 | class HasTitle x where | ||
598 | getTitle :: x -> Text | ||
599 | setTitle :: x -> Text -> x | ||
600 | |||
601 | {- | ||
602 | instance HasTitle CryptoMessage where | ||
603 | getTitle (UpToN xE bs) | ||
604 | | DIRECT_GROUPCHAT {-0x62-} <- xE, | ||
605 | (_,0x0a,mdata) <- splitByteAt 2 bs = decodeUtf8 mdata | ||
606 | | isIndirectGrpChat xE, | ||
607 | let (_,nmb,mdata) = splitByteAt 8 bs | ||
608 | nm = toEnum (fromIntegral nmb), | ||
609 | GroupchatTitleChange <- nm = decodeUtf8 mdata | ||
610 | getTitle _ = error "getTitle on CryptoMessage without title field." | ||
611 | |||
612 | setTitle (UpToN xE bs) msgdta | ||
613 | | DIRECT_GROUPCHAT {-0x62-} <- xE | ||
614 | = let (pre,_,_) = splitByteAt 2 bs | ||
615 | nm = 0x0a | ||
616 | in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) | ||
617 | | isIndirectGrpChat xE | ||
618 | = let (pre,_,_) = splitByteAt 8 bs | ||
619 | nm = fromIntegral $ fromEnum GroupchatTitleChange | ||
620 | in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) | ||
621 | setTitle _ _ = error "setTitle on CryptoMessage without title field." | ||
622 | -} | ||
623 | |||
624 | #ifdef USE_lens | ||
625 | title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) | ||
626 | title = lens getTitle setTitle | ||
627 | #endif | ||
628 | |||
629 | class HasMessage x where | ||
630 | getMessage :: x -> Text | ||
631 | setMessage :: x -> Text -> x | ||
632 | |||
633 | splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString) | ||
634 | splitByteAt n bs = (fixed,w8,bs') | ||
635 | where | ||
636 | (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs | ||
637 | |||
638 | {- | ||
639 | instance HasMessage CryptoMessage where | ||
640 | getMessage (UpToN xE bs) | ||
641 | | MESSAGE <- xE = T.decodeUtf8 bs | ||
642 | | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs | ||
643 | getMessage _ = error "getMessage on CryptoMessage without message field." | ||
644 | |||
645 | setMessage (UpToN xE bs) message | ||
646 | | MESSAGE <- xE | ||
647 | = UpToN xE $ T.encodeUtf8 message | ||
648 | | isIndirectGrpChat xE | ||
649 | = let (pre8,nm0,xs) = splitByteAt 8 bs | ||
650 | nm = if nm0 == 0 then 0x40 else nm0 | ||
651 | prefix x = pre8 <> B.cons nm x | ||
652 | in UpToN xE $ prefix $ T.encodeUtf8 message | ||
653 | setMessage _ _ = error "setMessage on CryptoMessage without message field." | ||
654 | -} | ||
655 | |||
656 | #ifdef USE_lens | ||
657 | message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) | ||
658 | message = lens getMessage setMessage | ||
659 | #endif | ||
660 | |||
661 | class HasName x where | ||
662 | getName :: x -> Text | ||
663 | setName :: x -> Text -> x | ||
664 | |||
665 | |||
666 | {- | ||
667 | instance HasName CryptoMessage where | ||
668 | -- Only MESSAGE_GROUPCHAT:NameChange has Name field | ||
669 | getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata | ||
670 | getName _ = error "getName on CryptoMessage without name field." | ||
671 | |||
672 | -- If its not NameChange, this setter will set it to NameChange | ||
673 | setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name | ||
674 | | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)]) | ||
675 | setName _ _ = error "setName on CryptoMessage without name field." | ||
676 | -} | ||
677 | |||
678 | #ifdef USE_lens | ||
679 | name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) | ||
680 | name = lens getTitle setTitle | ||
681 | #endif | ||
682 | |||
683 | data PeerInfo | ||
684 | = PeerInfo | ||
685 | { piPeerNum :: PeerNumber | ||
686 | , piUserKey :: PublicKey | ||
687 | , piDHTKey :: PublicKey | ||
688 | , piName :: ByteString -- byte-prefix for length | ||
689 | } deriving (Eq,Show) | ||
690 | |||
691 | instance HasPeerNumber PeerInfo where | ||
692 | getPeerNumber = piPeerNum | ||
693 | setPeerNumber x n = x { piPeerNum = n } | ||
694 | |||
695 | instance Serialize PeerInfo where | ||
696 | get = do | ||
697 | w16 <- get | ||
698 | ukey <- getPublicKey | ||
699 | dkey <- getPublicKey | ||
700 | w8 <- get :: Get Word8 | ||
701 | PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8) | ||
702 | |||
703 | put (PeerInfo w16 ukey dkey bs) = do | ||
704 | put w16 | ||
705 | putPublicKey ukey | ||
706 | putPublicKey dkey | ||
707 | let sz :: Word8 | ||
708 | sz = case B.length bs of | ||
709 | n | n <= 255 -> fromIntegral n | ||
710 | | otherwise -> 255 | ||
711 | put sz | ||
712 | putByteString $ B.take (fromIntegral sz) bs | ||
713 | |||
714 | |||
715 | {- | ||
716 | -- | | ||
717 | -- default constructor, handy for formations such as: | ||
718 | -- | ||
719 | -- > userStatus .~ Busy $ msg USERSTATUS | ||
720 | -- | ||
721 | msg :: MessageID -> CryptoMessage | ||
722 | msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid | ||
723 | | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 | ||
724 | | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty | ||
725 | | otherwise = UpToN mid B.empty | ||
726 | -} | ||
727 | |||
728 | {- | ||
729 | leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage | ||
730 | leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) | ||
731 | peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) | ||
732 | -} | ||
733 | |||
734 | {- | ||
735 | -- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as | ||
736 | -- the maximum allowed size for the message Payload (message minus id) | ||
737 | -- Or Nothing if unknown/unimplemented. | ||
738 | msgSizeParam :: MessageID -> Maybe (Bool,Int) | ||
739 | msgSizeParam ONLINE = Just (True ,0) | ||
740 | msgSizeParam OFFLINE = Just (True ,0) | ||
741 | msgSizeParam USERSTATUS = Just (True ,1) | ||
742 | msgSizeParam TYPING = Just (True ,1) | ||
743 | msgSizeParam NICKNAME = Just (False,128) | ||
744 | msgSizeParam STATUSMESSAGE = Just (False,1007) | ||
745 | msgSizeParam MESSAGE = Just (False,1372) | ||
746 | msgSizeParam ACTION = Just (False,1372) | ||
747 | msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373 | ||
748 | msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301 | ||
749 | msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4 | ||
750 | msgSizeParam INVITE_GROUPCHAT = Just (False,38) | ||
751 | msgSizeParam ONLINE_PACKET = Just (True ,35) | ||
752 | msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets | ||
753 | msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable | ||
754 | msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable | ||
755 | msgSizeParam _ = Nothing | ||
756 | -} | ||
757 | |||
758 | isIndirectGrpChat :: Msg n t -> Bool | ||
759 | isIndirectGrpChat MESSAGE_CONFERENCE = True | ||
760 | isIndirectGrpChat LOSSY_CONFERENCE = True | ||
761 | isIndirectGrpChat _ = False | ||
762 | |||
763 | isKillPacket :: SomeMsg -> Bool | ||
764 | isKillPacket (M KillPacket) = True | ||
765 | isKillPacket _ = False | ||
766 | |||
767 | isOFFLINE :: SomeMsg -> Bool | ||
768 | isOFFLINE (M OFFLINE) = True | ||
769 | isOFFLINE _ = False | ||
770 | |||
771 | |||
772 | data MessageName = Ping -- 0x00 | ||
773 | | MessageName0x01 | ||
774 | | MessageName0x02 | ||
775 | | MessageName0x03 | ||
776 | | MessageName0x04 | ||
777 | | MessageName0x05 | ||
778 | | MessageName0x06 | ||
779 | | MessageName0x07 | ||
780 | | MessageName0x08 | ||
781 | | MessageName0x09 | ||
782 | | MessageName0x0a | ||
783 | | MessageName0x0b | ||
784 | | MessageName0x0c | ||
785 | | MessageName0x0d | ||
786 | | MessageName0x0e | ||
787 | | MessageName0x0f | ||
788 | | NewPeer -- 0x10 | ||
789 | | KillPeer -- 0x11 | ||
790 | | MessageName0x12 | ||
791 | | MessageName0x13 | ||
792 | | MessageName0x14 | ||
793 | | MessageName0x15 | ||
794 | | MessageName0x16 | ||
795 | | MessageName0x17 | ||
796 | | MessageName0x18 | ||
797 | | MessageName0x19 | ||
798 | | MessageName0x1a | ||
799 | | MessageName0x1b | ||
800 | | MessageName0x1c | ||
801 | | MessageName0x1d | ||
802 | | MessageName0x1e | ||
803 | | MessageName0x1f | ||
804 | | MessageName0x20 | ||
805 | | MessageName0x21 | ||
806 | | MessageName0x22 | ||
807 | | MessageName0x23 | ||
808 | | MessageName0x24 | ||
809 | | MessageName0x25 | ||
810 | | MessageName0x26 | ||
811 | | MessageName0x27 | ||
812 | | MessageName0x28 | ||
813 | | MessageName0x29 | ||
814 | | MessageName0x2a | ||
815 | | MessageName0x2b | ||
816 | | MessageName0x2c | ||
817 | | MessageName0x2d | ||
818 | | MessageName0x2e | ||
819 | | MessageName0x2f | ||
820 | | NameChange -- 0x30 | ||
821 | | GroupchatTitleChange -- 0x31 | ||
822 | | MessageName0x32 | ||
823 | | MessageName0x33 | ||
824 | | MessageName0x34 | ||
825 | | MessageName0x35 | ||
826 | | MessageName0x36 | ||
827 | | MessageName0x37 | ||
828 | | MessageName0x38 | ||
829 | | MessageName0x39 | ||
830 | | MessageName0x3a | ||
831 | | MessageName0x3b | ||
832 | | MessageName0x3c | ||
833 | | MessageName0x3d | ||
834 | | MessageName0x3e | ||
835 | | MessageName0x3f | ||
836 | | ChatMessage -- 0x40 | ||
837 | | Action -- 0x41 | ||
838 | | MessageName0x42 | ||
839 | | MessageName0x43 | ||
840 | | MessageName0x44 | ||
841 | | MessageName0x45 | ||
842 | | MessageName0x46 | ||
843 | | MessageName0x47 | ||
844 | | MessageName0x48 | ||
845 | | MessageName0x49 | ||
846 | | MessageName0x4a | ||
847 | | MessageName0x4b | ||
848 | | MessageName0x4c | ||
849 | | MessageName0x4d | ||
850 | | MessageName0x4e | ||
851 | | MessageName0x4f | ||
852 | | MessageName0x50 | ||
853 | | MessageName0x51 | ||
854 | | MessageName0x52 | ||
855 | | MessageName0x53 | ||
856 | | MessageName0x54 | ||
857 | | MessageName0x55 | ||
858 | | MessageName0x56 | ||
859 | | MessageName0x57 | ||
860 | | MessageName0x58 | ||
861 | | MessageName0x59 | ||
862 | | MessageName0x5a | ||
863 | | MessageName0x5b | ||
864 | | MessageName0x5c | ||
865 | | MessageName0x5d | ||
866 | | MessageName0x5e | ||
867 | | MessageName0x5f | ||
868 | | MessageName0x60 | ||
869 | | MessageName0x61 | ||
870 | | MessageName0x62 | ||
871 | | MessageName0x63 | ||
872 | | MessageName0x64 | ||
873 | | MessageName0x65 | ||
874 | | MessageName0x66 | ||
875 | | MessageName0x67 | ||
876 | | MessageName0x68 | ||
877 | | MessageName0x69 | ||
878 | | MessageName0x6a | ||
879 | | MessageName0x6b | ||
880 | | MessageName0x6c | ||
881 | | MessageName0x6d | ||
882 | | MessageName0x6e | ||
883 | | MessageName0x6f | ||
884 | | MessageName0x70 | ||
885 | | MessageName0x71 | ||
886 | | MessageName0x72 | ||
887 | | MessageName0x73 | ||
888 | | MessageName0x74 | ||
889 | | MessageName0x75 | ||
890 | | MessageName0x76 | ||
891 | | MessageName0x77 | ||
892 | | MessageName0x78 | ||
893 | | MessageName0x79 | ||
894 | | MessageName0x7a | ||
895 | | MessageName0x7b | ||
896 | | MessageName0x7c | ||
897 | | MessageName0x7d | ||
898 | | MessageName0x7e | ||
899 | | MessageName0x7f | ||
900 | | MessageName0x80 | ||
901 | | MessageName0x81 | ||
902 | | MessageName0x82 | ||
903 | | MessageName0x83 | ||
904 | | MessageName0x84 | ||
905 | | MessageName0x85 | ||
906 | | MessageName0x86 | ||
907 | | MessageName0x87 | ||
908 | | MessageName0x88 | ||
909 | | MessageName0x89 | ||
910 | | MessageName0x8a | ||
911 | | MessageName0x8b | ||
912 | | MessageName0x8c | ||
913 | | MessageName0x8d | ||
914 | | MessageName0x8e | ||
915 | | MessageName0x8f | ||
916 | | MessageName0x90 | ||
917 | | MessageName0x91 | ||
918 | | MessageName0x92 | ||
919 | | MessageName0x93 | ||
920 | | MessageName0x94 | ||
921 | | MessageName0x95 | ||
922 | | MessageName0x96 | ||
923 | | MessageName0x97 | ||
924 | | MessageName0x98 | ||
925 | | MessageName0x99 | ||
926 | | MessageName0x9a | ||
927 | | MessageName0x9b | ||
928 | | MessageName0x9c | ||
929 | | MessageName0x9d | ||
930 | | MessageName0x9e | ||
931 | | MessageName0x9f | ||
932 | | MessageName0xa0 | ||
933 | | MessageName0xa1 | ||
934 | | MessageName0xa2 | ||
935 | | MessageName0xa3 | ||
936 | | MessageName0xa4 | ||
937 | | MessageName0xa5 | ||
938 | | MessageName0xa6 | ||
939 | | MessageName0xa7 | ||
940 | | MessageName0xa8 | ||
941 | | MessageName0xa9 | ||
942 | | MessageName0xaa | ||
943 | | MessageName0xab | ||
944 | | MessageName0xac | ||
945 | | MessageName0xad | ||
946 | | MessageName0xae | ||
947 | | MessageName0xaf | ||
948 | | MessageName0xb0 | ||
949 | | MessageName0xb1 | ||
950 | | MessageName0xb2 | ||
951 | | MessageName0xb3 | ||
952 | | MessageName0xb4 | ||
953 | | MessageName0xb5 | ||
954 | | MessageName0xb6 | ||
955 | | MessageName0xb7 | ||
956 | | MessageName0xb8 | ||
957 | | MessageName0xb9 | ||
958 | | MessageName0xba | ||
959 | | MessageName0xbb | ||
960 | | MessageName0xbc | ||
961 | | MessageName0xbd | ||
962 | | MessageName0xbe | ||
963 | | MessageName0xbf | ||
964 | | MessageName0xc0 | ||
965 | | MessageName0xc1 | ||
966 | | MessageName0xc2 | ||
967 | | MessageName0xc3 | ||
968 | | MessageName0xc4 | ||
969 | | MessageName0xc5 | ||
970 | | MessageName0xc6 | ||
971 | | MessageName0xc7 | ||
972 | | MessageName0xc8 | ||
973 | | MessageName0xc9 | ||
974 | | MessageName0xca | ||
975 | | MessageName0xcb | ||
976 | | MessageName0xcc | ||
977 | | MessageName0xcd | ||
978 | | MessageName0xce | ||
979 | | MessageName0xcf | ||
980 | | MessageName0xd0 | ||
981 | | MessageName0xd1 | ||
982 | | MessageName0xd2 | ||
983 | | MessageName0xd3 | ||
984 | | MessageName0xd4 | ||
985 | | MessageName0xd5 | ||
986 | | MessageName0xd6 | ||
987 | | MessageName0xd7 | ||
988 | | MessageName0xd8 | ||
989 | | MessageName0xd9 | ||
990 | | MessageName0xda | ||
991 | | MessageName0xdb | ||
992 | | MessageName0xdc | ||
993 | | MessageName0xdd | ||
994 | | MessageName0xde | ||
995 | | MessageName0xdf | ||
996 | | MessageName0xe0 | ||
997 | | MessageName0xe1 | ||
998 | | MessageName0xe2 | ||
999 | | MessageName0xe3 | ||
1000 | | MessageName0xe4 | ||
1001 | | MessageName0xe5 | ||
1002 | | MessageName0xe6 | ||
1003 | | MessageName0xe7 | ||
1004 | | MessageName0xe8 | ||
1005 | | MessageName0xe9 | ||
1006 | | MessageName0xea | ||
1007 | | MessageName0xeb | ||
1008 | | MessageName0xec | ||
1009 | | MessageName0xed | ||
1010 | | MessageName0xee | ||
1011 | | MessageName0xef | ||
1012 | | MessageName0xf0 | ||
1013 | | MessageName0xf1 | ||
1014 | | MessageName0xf2 | ||
1015 | | MessageName0xf3 | ||
1016 | | MessageName0xf4 | ||
1017 | | MessageName0xf5 | ||
1018 | | MessageName0xf6 | ||
1019 | | MessageName0xf7 | ||
1020 | | MessageName0xf8 | ||
1021 | | MessageName0xf9 | ||
1022 | | MessageName0xfa | ||
1023 | | MessageName0xfb | ||
1024 | | MessageName0xfc | ||
1025 | | MessageName0xfd | ||
1026 | | MessageName0xfe | ||
1027 | | MessageName0xff | ||
1028 | deriving (Show,Eq,Ord,Enum,Bounded) | ||
1029 | |||
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs deleted file mode 100644 index 1eec93b9..00000000 --- a/src/Network/Tox/DHT/Handlers.hs +++ /dev/null | |||
@@ -1,573 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
3 | {-# LANGUAGE NamedFieldPuns #-} | ||
4 | {-# LANGUAGE PatternSynonyms #-} | ||
5 | {-# LANGUAGE TupleSections #-} | ||
6 | module Network.Tox.DHT.Handlers where | ||
7 | |||
8 | import Debug.Trace | ||
9 | import Network.Tox.DHT.Transport as DHTTransport | ||
10 | import Network.QueryResponse as QR hiding (Client) | ||
11 | import qualified Network.QueryResponse as QR (Client) | ||
12 | import Crypto.Tox | ||
13 | import Network.Kademlia.Search | ||
14 | import qualified Data.Wrapper.PSQInt as Int | ||
15 | import Network.Kademlia | ||
16 | import Network.Kademlia.Bootstrap | ||
17 | import Network.Address (WantIP (..), ipFamily, fromSockAddr, sockAddrPort) | ||
18 | import qualified Network.Kademlia.Routing as R | ||
19 | import Control.TriadCommittee | ||
20 | import System.Global6 | ||
21 | import DPut | ||
22 | import DebugTag | ||
23 | |||
24 | import qualified Data.ByteArray as BA | ||
25 | import qualified Data.ByteString.Char8 as C8 | ||
26 | import qualified Data.ByteString.Base16 as Base16 | ||
27 | import Control.Arrow | ||
28 | import Control.Monad | ||
29 | import Control.Concurrent.Lifted.Instrument | ||
30 | import Control.Concurrent.STM | ||
31 | import Data.Hashable | ||
32 | import Data.Ord | ||
33 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) | ||
34 | import Network.Socket | ||
35 | import qualified Data.HashMap.Strict as HashMap | ||
36 | ;import Data.HashMap.Strict (HashMap) | ||
37 | #if MIN_VERSION_iproute(1,7,4) | ||
38 | import Data.IP hiding (fromSockAddr) | ||
39 | #else | ||
40 | import Data.IP | ||
41 | #endif | ||
42 | import Data.Maybe | ||
43 | import Data.Serialize (Serialize) | ||
44 | import Data.Word | ||
45 | |||
46 | data TransactionId = TransactionId | ||
47 | { transactionKey :: Nonce8 -- ^ Used to lookup pending query. | ||
48 | , cryptoNonce :: Nonce24 -- ^ Used during the encryption layer. | ||
49 | } | ||
50 | deriving (Eq,Ord,Show) | ||
51 | |||
52 | newtype PacketKind = PacketKind Word8 | ||
53 | deriving (Eq, Ord, Serialize) | ||
54 | |||
55 | pattern OnionRequest0Type = PacketKind 128 -- 0x80 Onion Request 0 | ||
56 | pattern OnionRequest1Type = PacketKind 129 -- 0x81 Onion Request 1 | ||
57 | pattern OnionRequest2Type = PacketKind 130 -- 0x82 Onion Request 2 | ||
58 | pattern AnnounceType = PacketKind 131 -- 0x83 Announce Request | ||
59 | pattern AnnounceResponseType = PacketKind 132 -- 0x84 Announce Response | ||
60 | |||
61 | pattern DataRequestType = PacketKind 133 -- 0x85 Onion Data Request (data to route request packet) | ||
62 | pattern DataResponseType = PacketKind 134 -- 0x86 Onion Data Response (data to route response packet) | ||
63 | -- 0x8c Onion Response 3 | ||
64 | -- 0x8d Onion Response 2 | ||
65 | pattern OnionResponse3Type = PacketKind 140 -- 0x8c Onion Response 3 | ||
66 | pattern OnionResponse2Type = PacketKind 141 -- 0x8d Onion Response 2 | ||
67 | pattern OnionResponse1Type = PacketKind 142 -- 0x8e Onion Response 1 | ||
68 | -- 0xf0 Bootstrap Info | ||
69 | |||
70 | pattern DHTRequestType = PacketKind 32 -- 0x20 DHT Request | ||
71 | |||
72 | pattern CookieRequestType = PacketKind 0x18 | ||
73 | pattern CookieResponseType = PacketKind 0x19 | ||
74 | |||
75 | pattern PingType = PacketKind 0 -- 0x00 Ping Request | ||
76 | pattern PongType = PacketKind 1 -- 0x01 Ping Response | ||
77 | pattern GetNodesType = PacketKind 2 -- 0x02 Nodes Request | ||
78 | pattern SendNodesType = PacketKind 4 -- 0x04 Nodes Response | ||
79 | |||
80 | |||
81 | instance Show PacketKind where | ||
82 | showsPrec d PingType = mappend "PingType" | ||
83 | showsPrec d PongType = mappend "PongType" | ||
84 | showsPrec d GetNodesType = mappend "GetNodesType" | ||
85 | showsPrec d SendNodesType = mappend "SendNodesType" | ||
86 | showsPrec d DHTRequestType = mappend "DHTRequestType" | ||
87 | showsPrec d OnionRequest0Type = mappend "OnionRequest0Type" | ||
88 | showsPrec d OnionResponse1Type = mappend "OnionResponse1Type" | ||
89 | showsPrec d OnionResponse3Type = mappend "OnionResponse3Type" | ||
90 | showsPrec d AnnounceType = mappend "AnnounceType" | ||
91 | showsPrec d AnnounceResponseType = mappend "AnnounceResponseType" | ||
92 | showsPrec d DataRequestType = mappend "DataRequestType" | ||
93 | showsPrec d DataResponseType = mappend "DataResponseType" | ||
94 | showsPrec d CookieRequestType = mappend "CookieRequestType" | ||
95 | showsPrec d CookieResponseType = mappend "CookieResponseType" | ||
96 | showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x | ||
97 | |||
98 | msgType :: ( Serialize (f DHTRequest) | ||
99 | , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest) | ||
100 | , Serialize (f SendNodes), Serialize (f GetNodes) | ||
101 | , Serialize (f Pong), Serialize (f Ping) | ||
102 | ) => DHTMessage f -> PacketKind | ||
103 | msgType msg = PacketKind $ fst $ dhtMessageType msg | ||
104 | |||
105 | classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message | ||
106 | classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client) | ||
107 | classify client msg = fromMaybe (IsUnknown "unknown") | ||
108 | $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg | ||
109 | where | ||
110 | go (DHTPing {}) = IsQuery PingType | ||
111 | go (DHTGetNodes {}) = IsQuery GetNodesType | ||
112 | go (DHTPong {}) = IsResponse | ||
113 | go (DHTSendNodes {}) = IsResponse | ||
114 | go (DHTCookieRequest {}) = IsQuery CookieRequestType | ||
115 | go (DHTCookie {}) = IsResponse | ||
116 | go (DHTDHTRequest {}) = IsQuery DHTRequestType | ||
117 | |||
118 | data NodeInfoCallback = NodeInfoCallback | ||
119 | { interestingNodeId :: NodeId | ||
120 | , listenerId :: Int | ||
121 | , observedAddress :: POSIXTime -> NodeInfo -- Address and port for interestingNodeId | ||
122 | -> STM () | ||
123 | , rumoredAddress :: POSIXTime -> SockAddr -- source of information | ||
124 | -> NodeInfo -- Address and port for interestingNodeId | ||
125 | -> STM () | ||
126 | } | ||
127 | |||
128 | data Routing = Routing | ||
129 | { tentativeId :: NodeInfo | ||
130 | , committee4 :: TriadCommittee NodeId SockAddr | ||
131 | , committee6 :: TriadCommittee NodeId SockAddr | ||
132 | , refresher4 :: BucketRefresher NodeId NodeInfo | ||
133 | , refresher6 :: BucketRefresher NodeId NodeInfo | ||
134 | , nodesOfInterest :: TVar (HashMap NodeId [NodeInfoCallback]) | ||
135 | } | ||
136 | |||
137 | registerNodeCallback :: Routing -> NodeInfoCallback -> STM () | ||
138 | registerNodeCallback Routing{nodesOfInterest} cb = do | ||
139 | cbm <- readTVar nodesOfInterest | ||
140 | let ns = fromMaybe [] $ HashMap.lookup (interestingNodeId cb) cbm | ||
141 | bs = filter nonMatching ns | ||
142 | where nonMatching n = (listenerId n /= listenerId cb) | ||
143 | writeTVar nodesOfInterest $ HashMap.insert (interestingNodeId cb) | ||
144 | (cb : bs) | ||
145 | cbm | ||
146 | |||
147 | unregisterNodeCallback :: Int -> Routing -> NodeId -> STM () | ||
148 | unregisterNodeCallback callbackId Routing{nodesOfInterest} nid = do | ||
149 | cbm <- readTVar nodesOfInterest | ||
150 | let ns = fromMaybe [] $ HashMap.lookup nid cbm | ||
151 | bs = filter nonMatching ns | ||
152 | where nonMatching n = (listenerId n /= callbackId) | ||
153 | writeTVar nodesOfInterest | ||
154 | $ if null bs | ||
155 | then HashMap.delete nid cbm | ||
156 | else HashMap.insert nid bs cbm | ||
157 | |||
158 | |||
159 | sched4 :: Routing -> TVar (Int.PSQ POSIXTime) | ||
160 | sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue | ||
161 | |||
162 | sched6 :: Routing -> TVar (Int.PSQ POSIXTime) | ||
163 | sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue | ||
164 | |||
165 | routing4 :: Routing -> TVar (R.BucketList NodeInfo) | ||
166 | routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets | ||
167 | |||
168 | routing6 :: Routing -> TVar (R.BucketList NodeInfo) | ||
169 | routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets | ||
170 | |||
171 | newRouting :: SockAddr -> TransportCrypto | ||
172 | -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv4 change | ||
173 | -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv6 change | ||
174 | -> IO (Client -> Routing) | ||
175 | newRouting addr crypto update4 update6 = do | ||
176 | let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr) | ||
177 | tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr) | ||
178 | tentative_info = NodeInfo | ||
179 | { nodeId = key2id $ transportPublic crypto | ||
180 | , nodeIP = fromMaybe (toEnum 0) (fromSockAddr addr) | ||
181 | , nodePort = fromMaybe 0 $ sockAddrPort addr | ||
182 | } | ||
183 | tentative_info4 = tentative_info { nodeIP = tentative_ip4 } | ||
184 | tentative_info6 <- | ||
185 | maybe (tentative_info { nodeIP = tentative_ip6 }) | ||
186 | (\ip6 -> tentative_info { nodeIP = IPv6 ip6 }) | ||
187 | <$> case addr of | ||
188 | SockAddrInet {} -> return Nothing | ||
189 | _ -> global6 | ||
190 | atomically $ do | ||
191 | -- We defer initializing the refreshSearch and refreshPing until we | ||
192 | -- have a client to send queries with. | ||
193 | let nullPing = const $ return False | ||
194 | nullSearch = Search | ||
195 | { searchSpace = toxSpace | ||
196 | , searchNodeAddress = nodeIP &&& nodePort | ||
197 | , searchQuery = Left $ \_ _ -> return Nothing | ||
198 | , searchAlpha = 1 | ||
199 | , searchK = 2 | ||
200 | } | ||
201 | tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 R.defaultBucketCount | ||
202 | tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount | ||
203 | refresher4 <- newBucketRefresher tbl4 nullSearch nullPing | ||
204 | refresher6 <- newBucketRefresher tbl6 nullSearch nullPing | ||
205 | committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4 | ||
206 | committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6 | ||
207 | cbvar <- newTVar HashMap.empty | ||
208 | return $ \client -> | ||
209 | -- Now we have a client, so tell the BucketRefresher how to search and ping. | ||
210 | let updIO r = updateRefresherIO (nodeSearch client cbvar) (ping client) r | ||
211 | in Routing { tentativeId = tentative_info | ||
212 | , committee4 = committee4 | ||
213 | , committee6 = committee6 | ||
214 | , refresher4 = updIO refresher4 | ||
215 | , refresher6 = updIO refresher6 | ||
216 | , nodesOfInterest = cbvar | ||
217 | } | ||
218 | |||
219 | |||
220 | -- TODO: This should cover more cases | ||
221 | isLocal :: IP -> Bool | ||
222 | isLocal (IPv6 ip6) = (ip6 == toEnum 0) | ||
223 | isLocal (IPv4 ip4) = (ip4 == toEnum 0) | ||
224 | |||
225 | isGlobal :: IP -> Bool | ||
226 | isGlobal = not . isLocal | ||
227 | |||
228 | prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP | ||
229 | prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp | ||
230 | |||
231 | toxSpace :: R.KademliaSpace NodeId NodeInfo | ||
232 | toxSpace = R.KademliaSpace | ||
233 | { R.kademliaLocation = nodeId | ||
234 | , R.kademliaTestBit = testNodeIdBit | ||
235 | , R.kademliaXor = xorNodeId | ||
236 | , R.kademliaSample = sampleNodeId | ||
237 | } | ||
238 | |||
239 | |||
240 | pingH :: NodeInfo -> Ping -> IO Pong | ||
241 | pingH _ Ping = return Pong | ||
242 | |||
243 | getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes | ||
244 | getNodesH routing addr (GetNodes nid) = do | ||
245 | let preferred = prefer4or6 addr Nothing | ||
246 | |||
247 | (append4,append6) <- atomically $ do | ||
248 | ni4 <- R.thisNode <$> readTVar (routing4 routing) | ||
249 | ni6 <- R.thisNode <$> readTVar (routing6 routing) | ||
250 | return $ case ipFamily (nodeIP addr) of | ||
251 | Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6])) | ||
252 | Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id) | ||
253 | _ -> (id, id) | ||
254 | ks <- go append4 $ routing4 routing | ||
255 | ks6 <- go append6 $ routing6 routing | ||
256 | let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks) | ||
257 | Want_IP4 -> (ks,ks6) | ||
258 | Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ | ||
259 | return $ SendNodes | ||
260 | $ if null ns2 then ns1 | ||
261 | else take 4 (take 3 ns1 ++ ns2) | ||
262 | where | ||
263 | go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var) | ||
264 | |||
265 | k = 4 | ||
266 | |||
267 | createCookie :: TransportCrypto -> NodeInfo -> PublicKey -> IO (Cookie Encrypted) | ||
268 | createCookie crypto ni remoteUserKey = do | ||
269 | (n24,sym) <- atomically $ do | ||
270 | n24 <- transportNewNonce crypto | ||
271 | sym <- transportSymmetric crypto | ||
272 | return (n24,sym) | ||
273 | timestamp <- round . (* 1000000) <$> getPOSIXTime | ||
274 | let dta = encodePlain $ CookieData | ||
275 | { cookieTime = timestamp | ||
276 | , longTermKey = remoteUserKey | ||
277 | , dhtKey = id2key $ nodeId ni -- transportPublic crypto | ||
278 | } | ||
279 | edta = encryptSymmetric sym n24 dta | ||
280 | return $ Cookie n24 edta | ||
281 | |||
282 | createCookieSTM :: POSIXTime -> TransportCrypto -> NodeInfo -> PublicKey -> STM (Cookie Encrypted) | ||
283 | createCookieSTM now crypto ni remoteUserKey = do | ||
284 | let dmsg msg = trace msg (return ()) | ||
285 | (n24,sym) <- do | ||
286 | n24 <- transportNewNonce crypto | ||
287 | sym <- transportSymmetric crypto | ||
288 | return (n24,sym) | ||
289 | let timestamp = round (now * 1000000) | ||
290 | let dta = encodePlain $ CookieData | ||
291 | { cookieTime = timestamp | ||
292 | , longTermKey = remoteUserKey | ||
293 | , dhtKey = id2key $ nodeId ni -- transportPublic crypto | ||
294 | } | ||
295 | edta = encryptSymmetric sym n24 dta | ||
296 | return $ Cookie n24 edta | ||
297 | |||
298 | cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO (Cookie Encrypted) | ||
299 | cookieRequestH crypto ni (CookieRequest remoteUserKey) = do | ||
300 | dput XNetCrypto $ unlines | ||
301 | [ show (nodeAddr ni) ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey) | ||
302 | , show (nodeAddr ni) ++ " --> sender=" ++ show (nodeId ni) ] | ||
303 | x <- createCookie crypto ni remoteUserKey | ||
304 | dput XNetCrypto $ show (nodeAddr ni) ++ " <-- cookie " ++ show (key2id remoteUserKey) | ||
305 | return x | ||
306 | |||
307 | lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message)) | ||
308 | lanDiscoveryH client _ ni = do | ||
309 | dput XLan $ show (nodeAddr ni) ++ " --> LanAnnounce " ++ show (nodeId ni) | ||
310 | forkIO $ do | ||
311 | myThreadId >>= flip labelThread "lan-discover-ping" | ||
312 | ping client ni | ||
313 | return () | ||
314 | return Nothing | ||
315 | |||
316 | type Message = DHTMessage ((,) Nonce8) | ||
317 | |||
318 | type Client = QR.Client String PacketKind TransactionId NodeInfo Message | ||
319 | |||
320 | |||
321 | wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta | ||
322 | wrapAsymm (TransactionId n8 n24) src dst dta = Asymm | ||
323 | { senderKey = id2key $ nodeId src | ||
324 | , asymmNonce = n24 | ||
325 | , asymmData = dta n8 | ||
326 | } | ||
327 | |||
328 | serializer :: PacketKind | ||
329 | -> (Asymm (Nonce8,ping) -> Message) | ||
330 | -> (Message -> Maybe (Asymm (Nonce8,pong))) | ||
331 | -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong) | ||
332 | serializer pktkind mkping mkpong = MethodSerializer | ||
333 | { methodTimeout = \tid addr -> return (addr, 5000000) | ||
334 | , method = pktkind | ||
335 | -- wrapQuery :: tid -> addr -> addr -> qry -> x | ||
336 | , wrapQuery = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping) | ||
337 | -- unwrapResponse :: x -> b | ||
338 | , unwrapResponse = fmap (snd . asymmData) . mkpong | ||
339 | } | ||
340 | |||
341 | |||
342 | unpong :: Message -> Maybe (Asymm (Nonce8,Pong)) | ||
343 | unpong (DHTPong asymm) = Just asymm | ||
344 | unpong _ = Nothing | ||
345 | |||
346 | ping :: Client -> NodeInfo -> IO Bool | ||
347 | ping client addr = do | ||
348 | dput XPing $ show addr ++ " <-- ping" | ||
349 | reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr | ||
350 | dput XPing $ show addr ++ " -pong-> " ++ show reply | ||
351 | maybe (return False) (\Pong -> return True) $ join reply | ||
352 | |||
353 | |||
354 | saveCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM () | ||
355 | saveCookieKey var saddr pk = do | ||
356 | cookiekeys <- readTVar var | ||
357 | case break (\(stored,_) -> stored == saddr) cookiekeys of | ||
358 | (xs,[]) -> writeTVar var $ (saddr, (1 ,pk)) : xs | ||
359 | (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c+1,pk)) : xs ++ ys | ||
360 | _ -> retry -- Wait for requests to this address | ||
361 | -- under a different key to time out | ||
362 | -- before we try this key. | ||
363 | |||
364 | loseCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM () | ||
365 | loseCookieKey var saddr pk = do | ||
366 | cookiekeys <- readTVar var | ||
367 | case break (\(stored,_) -> stored == saddr) cookiekeys of | ||
368 | (xs,(_,(1,stored)):ys) | stored == pk -> writeTVar var $ xs ++ ys | ||
369 | (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c-1,pk)) : xs ++ ys | ||
370 | _ -> return () -- unreachable? | ||
371 | |||
372 | |||
373 | cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe (Cookie Encrypted)) | ||
374 | cookieRequest crypto client localUserKey addr = do | ||
375 | let sockAddr = nodeAddr addr | ||
376 | nid = id2key $ nodeId addr | ||
377 | cookieSerializer | ||
378 | = MethodSerializer | ||
379 | { methodTimeout = \tid addr -> return (addr, 5000000) | ||
380 | , method = CookieRequestType | ||
381 | , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr) | ||
382 | , unwrapResponse = fmap snd . unCookie | ||
383 | } | ||
384 | cookieRequest = CookieRequest localUserKey | ||
385 | atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid | ||
386 | dput XNetCrypto $ show addr ++ " <-- cookieRequest" | ||
387 | reply <- QR.sendQuery client cookieSerializer cookieRequest addr | ||
388 | atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid | ||
389 | dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply | ||
390 | return $ join reply | ||
391 | |||
392 | unCookie :: DHTMessage t -> Maybe (t (Cookie Encrypted)) | ||
393 | unCookie (DHTCookie n24 fcookie) = Just fcookie | ||
394 | unCookie _ = Nothing | ||
395 | |||
396 | unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes)) | ||
397 | unsendNodes (DHTSendNodes asymm) = Just asymm | ||
398 | unsendNodes _ = Nothing | ||
399 | |||
400 | unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () ) | ||
401 | unwrapNodes (SendNodes ns) = (ns,ns,Just ()) | ||
402 | |||
403 | data SendableQuery x a b = SendableQuery | ||
404 | { sendableSerializer :: MethodSerializer TransactionId NodeInfo Message PacketKind a (Maybe x) | ||
405 | , sendableQuery :: NodeId -> a | ||
406 | , sendableResult :: Maybe (Maybe x) -> IO b | ||
407 | } | ||
408 | |||
409 | sendQ :: SendableQuery x a b | ||
410 | -> QR.Client err PacketKind TransactionId NodeInfo Message | ||
411 | -> NodeId | ||
412 | -> NodeInfo | ||
413 | -> IO b | ||
414 | sendQ s client nid addr = do | ||
415 | reply <- QR.sendQuery client (sendableSerializer s) (sendableQuery s nid) addr | ||
416 | sendableResult s reply | ||
417 | |||
418 | asyncQ :: SendableQuery x a b | ||
419 | -> QR.Client err PacketKind TransactionId NodeInfo Message | ||
420 | -> NodeId | ||
421 | -> NodeInfo | ||
422 | -> (b -> IO ()) | ||
423 | -> IO () | ||
424 | asyncQ s client nid addr go = do | ||
425 | QR.asyncQuery client (sendableSerializer s) (sendableQuery s nid) addr | ||
426 | $ sendableResult s >=> go | ||
427 | |||
428 | getNodesSendable :: TVar (HashMap NodeId [NodeInfoCallback]) | ||
429 | -> NodeInfo | ||
430 | -> SendableQuery SendNodes GetNodes (Maybe ([NodeInfo], [NodeInfo], Maybe ())) | ||
431 | getNodesSendable cbvar addr = SendableQuery (serializer GetNodesType DHTGetNodes unsendNodes) | ||
432 | GetNodes | ||
433 | go | ||
434 | where | ||
435 | go reply = do | ||
436 | forM_ (join reply) $ \(SendNodes ns) -> | ||
437 | forM_ ns $ \n -> do | ||
438 | now <- getPOSIXTime | ||
439 | atomically $ do | ||
440 | mcbs <- HashMap.lookup (nodeId n) <$> readTVar cbvar | ||
441 | forM_ mcbs $ \cbs -> do | ||
442 | forM_ cbs $ \cb -> do | ||
443 | rumoredAddress cb now (nodeAddr addr) n | ||
444 | return $ fmap unwrapNodes $ join reply | ||
445 | |||
446 | getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | ||
447 | getNodes client cbvar nid addr = | ||
448 | sendQ (getNodesSendable cbvar addr) client nid addr | ||
449 | |||
450 | asyncGetNodes :: QR.Client err PacketKind TransactionId NodeInfo Message | ||
451 | -> TVar (HashMap NodeId [NodeInfoCallback]) | ||
452 | -> NodeId | ||
453 | -> NodeInfo | ||
454 | -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ()) | ||
455 | -> IO () | ||
456 | asyncGetNodes client cbvar nid addr go = | ||
457 | asyncQ (getNodesSendable cbvar addr) client nid addr go | ||
458 | |||
459 | updateRouting :: Client -> Routing | ||
460 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
461 | -> NodeInfo | ||
462 | -> Message | ||
463 | -> IO () | ||
464 | updateRouting client routing orouter naddr msg | ||
465 | | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery | ||
466 | -- Ignore lan announcements until they reply to our ping. | ||
467 | -- We do this because the lan announce is not authenticated. | ||
468 | return () | ||
469 | | otherwise = do | ||
470 | now <- getPOSIXTime | ||
471 | atomically $ do | ||
472 | m <- HashMap.lookup (nodeId naddr) <$> readTVar (nodesOfInterest routing) | ||
473 | forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do | ||
474 | when (interestingNodeId == nodeId naddr) | ||
475 | $ observedAddress now naddr | ||
476 | case prefer4or6 naddr Nothing of | ||
477 | Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing) | ||
478 | Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing) | ||
479 | Want_Both -> do dput XMisc "BUG:unreachable" | ||
480 | error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ | ||
481 | |||
482 | updateTable :: Client -> NodeInfo | ||
483 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
484 | -> TriadCommittee NodeId SockAddr | ||
485 | -> BucketRefresher NodeId NodeInfo | ||
486 | -> IO () | ||
487 | updateTable client naddr orouter committee refresher = do | ||
488 | self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher) | ||
489 | -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr) | ||
490 | when (self /= naddr) $ do | ||
491 | -- TODO: IP address vote? | ||
492 | insertNode (toxKademlia client committee orouter refresher) naddr | ||
493 | |||
494 | toxKademlia :: Client | ||
495 | -> TriadCommittee NodeId SockAddr | ||
496 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
497 | -> BucketRefresher NodeId NodeInfo | ||
498 | -> Kademlia NodeId NodeInfo | ||
499 | toxKademlia client committee orouter refresher | ||
500 | = Kademlia quietInsertions | ||
501 | toxSpace | ||
502 | (vanillaIO (refreshBuckets refresher) $ ping client) | ||
503 | { tblTransition = \tr -> do | ||
504 | io1 <- transitionCommittee committee tr | ||
505 | io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr | ||
506 | -- hookBucketList toxSpace (refreshBuckets refresher) orouter tr | ||
507 | orouter (refreshBuckets refresher) tr | ||
508 | return $ do | ||
509 | io1 >> io2 | ||
510 | {- | ||
511 | dput XMisc $ unwords | ||
512 | [ show (transitionedTo tr) | ||
513 | , show (transitioningNode tr) | ||
514 | ] | ||
515 | -} | ||
516 | return () | ||
517 | } | ||
518 | |||
519 | transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ()) | ||
520 | transitionCommittee committee (RoutingTransition ni Stranger) = do | ||
521 | delVote committee (nodeId ni) | ||
522 | return $ do | ||
523 | -- dput XMisc $ "delVote "++show (nodeId ni) | ||
524 | return () | ||
525 | transitionCommittee committee _ = return $ return () | ||
526 | |||
527 | type Handler = MethodHandler String TransactionId NodeInfo Message | ||
528 | |||
529 | isPing :: (f Ping -> Ping) -> DHTMessage f -> Either String Ping | ||
530 | isPing unpack (DHTPing a) = Right $ unpack $ asymmData a | ||
531 | isPing _ _ = Left "Bad ping" | ||
532 | |||
533 | mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8) | ||
534 | mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong) | ||
535 | |||
536 | isGetNodes :: (f GetNodes -> GetNodes) -> DHTMessage f -> Either String GetNodes | ||
537 | isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a | ||
538 | isGetNodes _ _ = Left "Bad GetNodes" | ||
539 | |||
540 | mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8) | ||
541 | mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes) | ||
542 | |||
543 | isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest | ||
544 | isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a | ||
545 | isCookieRequest _ _ = Left "Bad cookie request" | ||
546 | |||
547 | mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie Encrypted -> DHTMessage ((,) Nonce8) | ||
548 | mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie) | ||
549 | |||
550 | isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest | ||
551 | isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a | ||
552 | isDHTRequest _ _ = Left "Bad dht relay request" | ||
553 | |||
554 | dhtRequestH :: NodeInfo -> DHTRequest -> IO () | ||
555 | dhtRequestH ni req = do | ||
556 | dput XMisc $ "Unhandled DHT Request: " ++ show req | ||
557 | |||
558 | handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler | ||
559 | handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH | ||
560 | handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing | ||
561 | handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto | ||
562 | handlers _ _ DHTRequestType = Just $ NoReply (isDHTRequest snd) $ dhtRequestH | ||
563 | handlers _ _ typ = error $ "TODO DHT handlers " ++ show typ | ||
564 | |||
565 | nodeSearch :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo | ||
566 | nodeSearch client cbvar = Search | ||
567 | { searchSpace = toxSpace | ||
568 | , searchNodeAddress = nodeIP &&& nodePort | ||
569 | , searchQuery = Right $ asyncGetNodes client cbvar | ||
570 | , searchAlpha = 8 | ||
571 | , searchK = 16 | ||
572 | |||
573 | } | ||
diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs deleted file mode 100644 index b9b63165..00000000 --- a/src/Network/Tox/DHT/Transport.hs +++ /dev/null | |||
@@ -1,460 +0,0 @@ | |||
1 | {-# LANGUAGE DeriveGeneric #-} | ||
2 | {-# LANGUAGE FlexibleContexts #-} | ||
3 | {-# LANGUAGE FlexibleInstances #-} | ||
4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
5 | {-# LANGUAGE KindSignatures #-} | ||
6 | {-# LANGUAGE LambdaCase #-} | ||
7 | {-# LANGUAGE RankNTypes #-} | ||
8 | {-# LANGUAGE StandaloneDeriving #-} | ||
9 | {-# LANGUAGE TupleSections #-} | ||
10 | {-# LANGUAGE TypeOperators #-} | ||
11 | {-# LANGUAGE UndecidableInstances #-} | ||
12 | module Network.Tox.DHT.Transport | ||
13 | ( parseDHTAddr | ||
14 | , encodeDHTAddr | ||
15 | , forwardDHTRequests | ||
16 | , module Network.Tox.NodeId | ||
17 | , DHTMessage(..) | ||
18 | , Ping(..) | ||
19 | , Pong(..) | ||
20 | , GetNodes(..) | ||
21 | , SendNodes(..) | ||
22 | , DHTPublicKey(..) | ||
23 | , FriendRequest(..) | ||
24 | , NoSpam(..) | ||
25 | , CookieRequest(..) | ||
26 | , CookieResponse(..) | ||
27 | , Cookie(..) | ||
28 | , CookieData(..) | ||
29 | , DHTRequest | ||
30 | , mapMessage | ||
31 | , encrypt | ||
32 | , decrypt | ||
33 | , dhtMessageType | ||
34 | , asymNodeInfo | ||
35 | , putMessage -- Convenient for serializing DHTLanDiscovery | ||
36 | ) where | ||
37 | |||
38 | import Network.Tox.NodeId | ||
39 | import Crypto.Tox hiding (encrypt,decrypt) | ||
40 | import qualified Crypto.Tox as ToxCrypto | ||
41 | import Network.QueryResponse | ||
42 | |||
43 | import Control.Applicative | ||
44 | import Control.Arrow | ||
45 | import Control.Concurrent.STM | ||
46 | import Control.Monad | ||
47 | import Data.Bool | ||
48 | import qualified Data.ByteString as B | ||
49 | ;import Data.ByteString (ByteString) | ||
50 | import Data.Functor.Contravariant | ||
51 | import Data.Hashable | ||
52 | import Data.Maybe | ||
53 | import Data.Monoid | ||
54 | import Data.Serialize as S | ||
55 | import Data.Tuple | ||
56 | import Data.Word | ||
57 | import GHC.Generics | ||
58 | import Network.Socket | ||
59 | |||
60 | type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8) | ||
61 | type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a | ||
62 | |||
63 | |||
64 | data DHTMessage (f :: * -> *) | ||
65 | = DHTPing (Asymm (f Ping)) | ||
66 | | DHTPong (Asymm (f Pong)) | ||
67 | | DHTGetNodes (Asymm (f GetNodes)) | ||
68 | | DHTSendNodes (Asymm (f SendNodes)) | ||
69 | | DHTCookieRequest (Asymm (f CookieRequest)) | ||
70 | | DHTCookie Nonce24 (f (Cookie Encrypted)) | ||
71 | | DHTDHTRequest PublicKey (Asymm (f DHTRequest)) | ||
72 | | DHTLanDiscovery NodeId | ||
73 | |||
74 | deriving instance ( Show (f (Cookie Encrypted)) | ||
75 | , Show (f Ping) | ||
76 | , Show (f Pong) | ||
77 | , Show (f GetNodes) | ||
78 | , Show (f SendNodes) | ||
79 | , Show (f CookieRequest) | ||
80 | , Show (f DHTRequest) | ||
81 | ) => Show (DHTMessage f) | ||
82 | |||
83 | mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> Maybe b | ||
84 | mapMessage f (DHTPing a) = Just $ f (asymmNonce a) (asymmData a) | ||
85 | mapMessage f (DHTPong a) = Just $ f (asymmNonce a) (asymmData a) | ||
86 | mapMessage f (DHTGetNodes a) = Just $ f (asymmNonce a) (asymmData a) | ||
87 | mapMessage f (DHTSendNodes a) = Just $ f (asymmNonce a) (asymmData a) | ||
88 | mapMessage f (DHTCookieRequest a) = Just $ f (asymmNonce a) (asymmData a) | ||
89 | mapMessage f (DHTDHTRequest _ a) = Just $ f (asymmNonce a) (asymmData a) | ||
90 | mapMessage f (DHTCookie nonce fcookie) = Just $ f nonce fcookie | ||
91 | mapMessage f (DHTLanDiscovery nid) = Nothing | ||
92 | |||
93 | |||
94 | instance Sized Ping where size = ConstSize 1 | ||
95 | instance Sized Pong where size = ConstSize 1 | ||
96 | |||
97 | parseDHTAddr :: TransportCrypto -> (ByteString, SockAddr) -> IO (Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)) | ||
98 | parseDHTAddr crypto (msg,saddr) | ||
99 | | Just (typ,bs) <- B.uncons msg | ||
100 | , let right = return $ Right (msg,saddr) | ||
101 | left = either (const right) (return . Left) | ||
102 | = case typ of | ||
103 | 0x00 -> left $ direct bs saddr DHTPing | ||
104 | 0x01 -> left $ direct bs saddr DHTPong | ||
105 | 0x02 -> left $ direct bs saddr DHTGetNodes | ||
106 | 0x04 -> left $ direct bs saddr DHTSendNodes | ||
107 | 0x18 -> left $ direct bs saddr DHTCookieRequest | ||
108 | 0x19 -> do | ||
109 | cs <- atomically $ readTVar (pendingCookies crypto) | ||
110 | let ni = fromMaybe (noReplyAddr saddr) $ do | ||
111 | (cnt,key) <- lookup saddr cs <|> listToMaybe (map snd cs) | ||
112 | either (const Nothing) Just $ nodeInfo (key2id key) saddr | ||
113 | left $ fanGet bs getCookie (uncurry DHTCookie) (const $ ni) | ||
114 | 0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd) | ||
115 | 0x21 -> left $ do | ||
116 | nid <- runGet get bs | ||
117 | ni <- nodeInfo nid saddr | ||
118 | return (DHTLanDiscovery nid, ni) | ||
119 | _ -> right | ||
120 | |||
121 | encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> IO (ByteString, SockAddr) | ||
122 | encodeDHTAddr (msg,ni) = return (runPut $ putMessage msg, nodeAddr ni) | ||
123 | |||
124 | dhtMessageType :: ( Serialize (f DHTRequest) | ||
125 | , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest) | ||
126 | , Serialize (f SendNodes), Serialize (f GetNodes) | ||
127 | , Serialize (f Pong), Serialize (f Ping) | ||
128 | ) => DHTMessage f -> (Word8, Put) | ||
129 | dhtMessageType (DHTPing a) = (0x00, putAsymm a) | ||
130 | dhtMessageType (DHTPong a) = (0x01, putAsymm a) | ||
131 | dhtMessageType (DHTGetNodes a) = (0x02, putAsymm a) | ||
132 | dhtMessageType (DHTSendNodes a) = (0x04, putAsymm a) | ||
133 | dhtMessageType (DHTCookieRequest a) = (0x18, putAsymm a) | ||
134 | dhtMessageType (DHTCookie n x) = (0x19, put n >> put x) | ||
135 | dhtMessageType (DHTDHTRequest k a) = (0x20, putPublicKey k >> putAsymm a) | ||
136 | dhtMessageType (DHTLanDiscovery nid) = (0x21, put nid) | ||
137 | |||
138 | putMessage :: DHTMessage Encrypted8 -> Put | ||
139 | putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p | ||
140 | |||
141 | getCookie :: Get (Nonce24, Encrypted8 (Cookie Encrypted)) | ||
142 | getCookie = get | ||
143 | |||
144 | getDHTReqest :: Get (PublicKey, Asymm (Encrypted8 DHTRequest)) | ||
145 | getDHTReqest = (,) <$> getPublicKey <*> getAsymm | ||
146 | |||
147 | -- ## DHT Request packets | ||
148 | -- | ||
149 | -- | Length | Contents | | ||
150 | -- |:-------|:--------------------------| | ||
151 | -- | `1` | `uint8_t` (0x20) | | ||
152 | -- | `32` | receiver's DHT public key | | ||
153 | -- ... ... | ||
154 | |||
155 | |||
156 | getDHT :: Sized a => Get (Asymm (Encrypted8 a)) | ||
157 | getDHT = getAsymm | ||
158 | |||
159 | |||
160 | -- Throws an error if called with a non-internet socket. | ||
161 | direct :: Sized a => ByteString | ||
162 | -> SockAddr | ||
163 | -> (Asymm (Encrypted8 a) -> DHTMessage Encrypted8) | ||
164 | -> Either String (DHTMessage Encrypted8, NodeInfo) | ||
165 | direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr) | ||
166 | |||
167 | -- Throws an error if called with a non-internet socket. | ||
168 | asymNodeInfo :: SockAddr -> Asymm a -> NodeInfo | ||
169 | asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (key2id $ senderKey asym) saddr | ||
170 | |||
171 | |||
172 | fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b) | ||
173 | fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs | ||
174 | |||
175 | -- Throws an error if called with a non-internet socket. | ||
176 | noReplyAddr :: SockAddr -> NodeInfo | ||
177 | noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr | ||
178 | |||
179 | |||
180 | data DHTRequest | ||
181 | -- #### NAT ping request | ||
182 | -- | ||
183 | -- Length Contents | ||
184 | -- :------- :------------------------- | ||
185 | -- `1` `uint8_t` (0xfe) | ||
186 | -- `1` `uint8_t` (0x00) | ||
187 | -- `8` `uint64_t` random number | ||
188 | = NATPing Nonce8 | ||
189 | -- #### NAT ping response | ||
190 | -- | ||
191 | -- Length Contents | ||
192 | -- :------- :----------------------------------------------------------------- | ||
193 | -- `1` `uint8_t` (0xfe) | ||
194 | -- `1` `uint8_t` (0x01) | ||
195 | -- `8` `uint64_t` random number (the same that was received in request) | ||
196 | | NATPong Nonce8 | ||
197 | | DHTPK LongTermKeyWrap | ||
198 | -- From docs/Hardening_docs.txt | ||
199 | -- | ||
200 | -- All hardening requests must contain exactly 384 bytes of data. (The data sent | ||
201 | -- must be padded with zeros if it is smaller than that.) | ||
202 | -- | ||
203 | -- [byte with value: 02 (get nodes test request)][struct Node_format (the node to | ||
204 | -- test.)][client_id(32 bytes) the id to query the node with.][padding] | ||
205 | -- | ||
206 | -- packet id: CRYPTO_PACKET_HARDENING (48) | ||
207 | | Hardening -- TODO | ||
208 | deriving Show | ||
209 | |||
210 | instance Sized DHTRequest where | ||
211 | size = VarSize $ \case | ||
212 | NATPing _ -> 10 | ||
213 | NATPong _ -> 10 | ||
214 | DHTPK wrap -> 1{-typ-} + 32{-key-} + 24{-nonce-} | ||
215 | + case size of | ||
216 | ConstSize n -> n | ||
217 | VarSize f -> f (wrapData wrap) | ||
218 | Hardening -> 1{-typ-} + 384 | ||
219 | |||
220 | instance Serialize DHTRequest where | ||
221 | get = do | ||
222 | tag <- get | ||
223 | case tag :: Word8 of | ||
224 | 0xfe -> do | ||
225 | direction <- get | ||
226 | bool NATPong NATPing (direction==(0::Word8)) <$> get | ||
227 | 0x9c -> DHTPK <$> get | ||
228 | 0x30 -> pure Hardening -- TODO: CRYPTO_PACKET_HARDENING | ||
229 | _ -> fail ("unrecognized DHT request: "++show tag) | ||
230 | put (NATPing n) = put (0xfe00 :: Word16) >> put n | ||
231 | put (NATPong n) = put (0xfe01 :: Word16) >> put n | ||
232 | put (DHTPK pk) = put (0x9c :: Word8) >> put pk | ||
233 | put (Hardening) = put (0x30 :: Word8) >> putByteString (B.replicate 384 0) -- TODO | ||
234 | |||
235 | -- DHT public key packet: | ||
236 | -- (As Onion data packet?) | ||
237 | -- | ||
238 | -- | Length | Contents | | ||
239 | -- |:------------|:------------------------------------| | ||
240 | -- | `1` | `uint8_t` (0x9c) | | ||
241 | -- | `8` | `uint64_t` `no_replay` | | ||
242 | -- | `32` | Our DHT public key | | ||
243 | -- | `[39, 204]` | Maximum of 4 nodes in packed format | | ||
244 | data DHTPublicKey = DHTPublicKey | ||
245 | { dhtpkNonce :: Word64 -- ^ The `no_replay` number is protection if | ||
246 | -- someone tries to replay an older packet and | ||
247 | -- should be set to an always increasing number. | ||
248 | -- It is 8 bytes so you should set a high | ||
249 | -- resolution monotonic time as the value. | ||
250 | , dhtpk :: PublicKey -- dht public key | ||
251 | , dhtpkNodes :: SendNodes -- other reachable nodes | ||
252 | } | ||
253 | deriving (Eq, Show) | ||
254 | |||
255 | |||
256 | -- int8_t (0x20 sent over onion, 0x12 for sent over net_crypto) | ||
257 | -- [uint32_t nospam][Message (UTF8) 1 to ONION_CLIENT_MAX_DATA_SIZE bytes] | ||
258 | data FriendRequest = FriendRequest | ||
259 | { friendNoSpam :: Word32 | ||
260 | , friendRequestText :: ByteString -- UTF8 | ||
261 | } | ||
262 | deriving (Eq, Ord, Show) | ||
263 | |||
264 | |||
265 | -- When sent as a DHT request packet (this is the data sent in the DHT request | ||
266 | -- packet): | ||
267 | -- | ||
268 | -- Length Contents | ||
269 | -- :--------- :------------------------------- | ||
270 | -- `1` `uint8_t` (0x9c) | ||
271 | -- `32` Long term public key of sender | ||
272 | -- `24` Nonce | ||
273 | -- variable Encrypted payload | ||
274 | data LongTermKeyWrap = LongTermKeyWrap | ||
275 | { wrapLongTermKey :: PublicKey | ||
276 | , wrapNonce :: Nonce24 | ||
277 | , wrapData :: Encrypted DHTPublicKey | ||
278 | } | ||
279 | deriving Show | ||
280 | |||
281 | instance Serialize LongTermKeyWrap where | ||
282 | get = LongTermKeyWrap <$> getPublicKey <*> get <*> get | ||
283 | put (LongTermKeyWrap key nonce dta) = putPublicKey key >> put nonce >> put dta | ||
284 | |||
285 | |||
286 | instance Sized DHTPublicKey where | ||
287 | -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size. | ||
288 | -- WARNING: Serialize instance does not include this byte FIXME | ||
289 | size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of | ||
290 | ConstSize nodes -> nodes | ||
291 | VarSize sznodes -> sznodes nodes | ||
292 | |||
293 | instance Sized Word32 where size = ConstSize 4 | ||
294 | |||
295 | -- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte | ||
296 | -- where the DHTPublicKey type does include its tag. | ||
297 | instance Sized FriendRequest where | ||
298 | size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length) | ||
299 | |||
300 | instance Serialize DHTPublicKey where | ||
301 | -- TODO: This should agree with Sized instance. | ||
302 | get = DHTPublicKey <$> get <*> getPublicKey <*> get | ||
303 | put (DHTPublicKey nonce key nodes) = do | ||
304 | put nonce | ||
305 | putPublicKey key | ||
306 | put nodes | ||
307 | |||
308 | instance Serialize FriendRequest where | ||
309 | get = FriendRequest <$> get <*> (remaining >>= getBytes) | ||
310 | put (FriendRequest nospam txt) = put nospam >> putByteString txt | ||
311 | |||
312 | newtype GetNodes = GetNodes NodeId | ||
313 | deriving (Eq,Ord,Show,Read,S.Serialize) | ||
314 | |||
315 | instance Sized GetNodes where | ||
316 | size = ConstSize 32 -- TODO This right? | ||
317 | |||
318 | newtype SendNodes = SendNodes [NodeInfo] | ||
319 | deriving (Eq,Ord,Show,Read) | ||
320 | |||
321 | instance Sized SendNodes where | ||
322 | size = VarSize $ \(SendNodes ns) -> case size of | ||
323 | ConstSize nodeFormatSize -> nodeFormatSize * length ns | ||
324 | VarSize nsize -> sum $ map nsize ns | ||
325 | |||
326 | instance S.Serialize SendNodes where | ||
327 | get = do | ||
328 | cnt <- S.get :: S.Get Word8 | ||
329 | ns <- sequence $ replicate (fromIntegral cnt) S.get | ||
330 | return $ SendNodes ns | ||
331 | |||
332 | put (SendNodes ns) = do | ||
333 | let ns' = take 4 ns | ||
334 | S.put (fromIntegral (length ns') :: Word8) | ||
335 | mapM_ S.put ns' | ||
336 | |||
337 | data Ping = Ping deriving Show | ||
338 | data Pong = Pong deriving Show | ||
339 | |||
340 | instance S.Serialize Ping where | ||
341 | get = do w8 <- S.get | ||
342 | if (w8 :: Word8) /= 0 | ||
343 | then fail "Malformed ping." | ||
344 | else return Ping | ||
345 | put Ping = S.put (0 :: Word8) | ||
346 | |||
347 | instance S.Serialize Pong where | ||
348 | get = do w8 <- S.get | ||
349 | if (w8 :: Word8) /= 1 | ||
350 | then fail "Malformed pong." | ||
351 | else return Pong | ||
352 | put Pong = S.put (1 :: Word8) | ||
353 | |||
354 | newtype CookieRequest = CookieRequest PublicKey | ||
355 | deriving (Eq, Show) | ||
356 | newtype CookieResponse = CookieResponse (Cookie Encrypted) | ||
357 | deriving (Eq, Show) | ||
358 | |||
359 | data Cookie (f :: * -> *) = Cookie Nonce24 (f CookieData) | ||
360 | |||
361 | deriving instance Eq (f CookieData) => Eq (Cookie f) | ||
362 | deriving instance Ord (f CookieData) => Ord (Cookie f) | ||
363 | deriving instance Show (f CookieData) => Show (Cookie f) | ||
364 | deriving instance Generic (f CookieData) => Generic (Cookie f) | ||
365 | |||
366 | instance Hashable (Cookie Encrypted) | ||
367 | |||
368 | instance Sized (Cookie Encrypted) where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data | ||
369 | |||
370 | instance Serialize (Cookie Encrypted) where | ||
371 | get = Cookie <$> get <*> get | ||
372 | put (Cookie nonce dta) = put nonce >> put dta | ||
373 | |||
374 | data CookieData = CookieData -- 16 (mac) | ||
375 | { cookieTime :: Word64 -- 8 | ||
376 | , longTermKey :: PublicKey -- 32 | ||
377 | , dhtKey :: PublicKey -- + 32 | ||
378 | } -- = 88 bytes when encrypted. | ||
379 | deriving (Show, Generic) | ||
380 | |||
381 | instance Sized CookieData where | ||
382 | size = ConstSize 72 | ||
383 | |||
384 | instance Serialize CookieData where | ||
385 | get = CookieData <$> get <*> getPublicKey <*> getPublicKey | ||
386 | put (CookieData tm userkey dhtkey) = do | ||
387 | put tm | ||
388 | putPublicKey userkey | ||
389 | putPublicKey userkey | ||
390 | |||
391 | instance Sized CookieRequest where | ||
392 | size = ConstSize 64 -- 32 byte key + 32 byte padding | ||
393 | |||
394 | instance Serialize CookieRequest where | ||
395 | get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey | ||
396 | put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k | ||
397 | |||
398 | forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport | ||
399 | forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' } | ||
400 | where | ||
401 | await' :: HandleHi a -> IO a | ||
402 | await' pass = awaitMessage dht $ \case | ||
403 | Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto | ||
404 | -> do mni <- closeLookup target | ||
405 | -- Forward the message if the target is in our close list. | ||
406 | forM_ mni $ \ni -> sendMessage dht ni m | ||
407 | await' pass | ||
408 | m -> pass m | ||
409 | |||
410 | encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> IO (DHTMessage Encrypted8, NodeInfo) | ||
411 | encrypt crypto msg ni = do | ||
412 | let cipher n plain = Composed $ encryptMessage crypto (id2key $ nodeId ni) n plain | ||
413 | m <- sequenceMessage $ transcode cipher msg | ||
414 | return (m, ni) | ||
415 | |||
416 | encryptMessage :: Serialize a => | ||
417 | TransportCrypto -> | ||
418 | PublicKey -> | ||
419 | Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> IO (Encrypted8 a) | ||
420 | encryptMessage crypto destKey n arg = do | ||
421 | let plain = encodePlain $ swap $ either id asymmData arg | ||
422 | secret <- lookupSharedSecret crypto (transportSecret crypto) destKey n | ||
423 | return $ E8 $ ToxCrypto.encrypt secret plain | ||
424 | |||
425 | decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> IO (Either String (DHTMessage ((,) Nonce8), NodeInfo)) | ||
426 | decrypt crypto msg ni = do | ||
427 | let decipher n c = Composed $ decryptMessage crypto n . left ((,) $ id2key $ nodeId ni) $ c | ||
428 | msg' <- sequenceMessage $ transcode decipher msg | ||
429 | return $ fmap (, ni) $ sequenceMessage msg' | ||
430 | |||
431 | decryptMessage :: Serialize x => | ||
432 | TransportCrypto | ||
433 | -> Nonce24 | ||
434 | -> Either (PublicKey, Encrypted8 x) (Asymm (Encrypted8 x)) | ||
435 | -> IO ((Either String ∘ ((,) Nonce8)) x) | ||
436 | decryptMessage crypto n arg = do | ||
437 | let (remotekey,E8 e) = either id (senderKey &&& asymmData) arg | ||
438 | plain8 = Composed . fmap swap . (>>= decodePlain) | ||
439 | secret <- lookupSharedSecret crypto (transportSecret crypto) remotekey n | ||
440 | return $ plain8 $ ToxCrypto.decrypt secret e | ||
441 | |||
442 | sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f) | ||
443 | sequenceMessage (DHTPing asym) = fmap DHTPing $ sequenceA $ fmap uncomposed asym | ||
444 | sequenceMessage (DHTPong asym) = fmap DHTPong $ sequenceA $ fmap uncomposed asym | ||
445 | sequenceMessage (DHTGetNodes asym) = fmap DHTGetNodes $ sequenceA $ fmap uncomposed asym | ||
446 | sequenceMessage (DHTSendNodes asym) = fmap DHTSendNodes $ sequenceA $ fmap uncomposed asym | ||
447 | sequenceMessage (DHTCookieRequest asym) = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym | ||
448 | sequenceMessage (DHTCookie n dta) = fmap (DHTCookie n) $ uncomposed dta | ||
449 | sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym | ||
450 | sequenceMessage (DHTLanDiscovery nid) = pure $ DHTLanDiscovery nid | ||
451 | |||
452 | transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> DHTMessage f -> DHTMessage g | ||
453 | transcode f (DHTPing asym) = DHTPing $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
454 | transcode f (DHTPong asym) = DHTPong $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
455 | transcode f (DHTGetNodes asym) = DHTGetNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
456 | transcode f (DHTSendNodes asym) = DHTSendNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
457 | transcode f (DHTCookieRequest asym) = DHTCookieRequest $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
458 | transcode f (DHTCookie n dta) = DHTCookie n $ f n $ Left dta | ||
459 | transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
460 | transcode f (DHTLanDiscovery nid) = DHTLanDiscovery nid | ||
diff --git a/src/Network/Tox/Handshake.hs b/src/Network/Tox/Handshake.hs deleted file mode 100644 index c48b7415..00000000 --- a/src/Network/Tox/Handshake.hs +++ /dev/null | |||
@@ -1,125 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE DeriveFunctor #-} | ||
3 | {-# LANGUAGE NamedFieldPuns #-} | ||
4 | {-# LANGUAGE PatternSynonyms #-} | ||
5 | {-# LANGUAGE TupleSections #-} | ||
6 | {-# LANGUAGE TypeOperators #-} | ||
7 | module Network.Tox.Handshake where | ||
8 | |||
9 | import Control.Arrow | ||
10 | import Control.Concurrent.STM | ||
11 | import Control.Monad | ||
12 | import Crypto.Hash | ||
13 | import Crypto.Tox | ||
14 | import Data.Functor.Identity | ||
15 | import Data.Time.Clock.POSIX | ||
16 | import Network.Tox.Crypto.Transport | ||
17 | import Network.Tox.DHT.Handlers (createCookieSTM) | ||
18 | import Network.Tox.DHT.Transport (Cookie (..), CookieData (..)) | ||
19 | import Network.Tox.NodeId | ||
20 | #ifdef THREAD_DEBUG | ||
21 | #else | ||
22 | import Control.Concurrent | ||
23 | import GHC.Conc (labelThread) | ||
24 | #endif | ||
25 | import DPut | ||
26 | import DebugTag | ||
27 | |||
28 | |||
29 | anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1) | ||
30 | anyRight e [] f = return $ Left e | ||
31 | anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right) | ||
32 | |||
33 | decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity)) | ||
34 | decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do | ||
35 | (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto | ||
36 | <*> transportSymmetric crypto | ||
37 | let seckeys = map fst ukeys | ||
38 | now <- getPOSIXTime | ||
39 | -- dput XNetCrypto "decryptHandshake: trying the following keys:" | ||
40 | -- forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k) | ||
41 | fmap join . sequence $ do -- Either Monad | ||
42 | cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie | ||
43 | Right $ do -- IO Monad | ||
44 | decrypted <- anyRight "missing key" seckeys $ \key -> do | ||
45 | -- dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey = " ++ show (key2id $ remotePubkey) | ||
46 | -- dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 = " ++ show nonce24 | ||
47 | secret <- lookupSharedSecret crypto key remotePubkey nonce24 | ||
48 | let step1 = decrypt secret encrypted | ||
49 | case step1 of | ||
50 | Left s -> do | ||
51 | -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s | ||
52 | return (Left s) | ||
53 | Right pln -> do | ||
54 | case decodePlain pln of | ||
55 | Left s -> do | ||
56 | -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s | ||
57 | return (Left s) | ||
58 | Right x -> return (Right (key,x)) | ||
59 | return $ do -- Either Monad | ||
60 | (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted | ||
61 | left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15) | ||
62 | let hinit = hashInit | ||
63 | hctx = hashUpdate hinit n24 | ||
64 | hctx' = hashUpdate hctx ecookie | ||
65 | digest = hashFinalize hctx' | ||
66 | left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest) | ||
67 | return ( key | ||
68 | , hshake { handshakeCookie = Cookie n24 (pure cd) | ||
69 | , handshakeData = pure hsdata | ||
70 | } ) | ||
71 | |||
72 | |||
73 | data HandshakeParams | ||
74 | = HParam | ||
75 | { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own | ||
76 | , hpOtherCookie :: Cookie Encrypted | ||
77 | , hpTheirSessionKeyPublic :: Maybe PublicKey | ||
78 | , hpMySecretKey :: SecretKey | ||
79 | , hpCookieRemotePubkey :: PublicKey | ||
80 | , hpCookieRemoteDhtkey :: PublicKey | ||
81 | } | ||
82 | |||
83 | newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData | ||
84 | newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do | ||
85 | let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp | ||
86 | hinit = hashInit | ||
87 | Cookie n24 encrypted = hpOtherCookie | ||
88 | hctx = hashUpdate hinit n24 | ||
89 | hctx' = hashUpdate hctx encrypted | ||
90 | digest = hashFinalize hctx' | ||
91 | freshCookie <- createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey | ||
92 | return HandshakeData | ||
93 | { baseNonce = basenonce | ||
94 | , sessionKey = mySessionPublic | ||
95 | , cookieHash = digest | ||
96 | , otherCookie = freshCookie | ||
97 | } | ||
98 | |||
99 | toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams | ||
100 | toHandshakeParams (key,hs) | ||
101 | = let hd = runIdentity $ handshakeData hs | ||
102 | Cookie _ cd0 = handshakeCookie hs | ||
103 | CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0 | ||
104 | in HParam { hpTheirBaseNonce = Just $ baseNonce hd | ||
105 | , hpOtherCookie = otherCookie hd | ||
106 | , hpTheirSessionKeyPublic = Just $ sessionKey hd | ||
107 | , hpMySecretKey = key | ||
108 | , hpCookieRemotePubkey = remotePublicKey | ||
109 | , hpCookieRemoteDhtkey = remoteDhtPublicKey | ||
110 | } | ||
111 | |||
112 | encodeHandshake :: POSIXTime | ||
113 | -> TransportCrypto | ||
114 | -> SecretKey | ||
115 | -> PublicKey | ||
116 | -> Cookie Encrypted | ||
117 | -> HandshakeData | ||
118 | -> STM (Handshake Encrypted) | ||
119 | encodeHandshake timestamp crypto me them otherCookie myhandshakeData = do | ||
120 | n24 <- transportNewNonce crypto | ||
121 | state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto me them | ||
122 | return Handshake { handshakeCookie = otherCookie | ||
123 | , handshakeNonce = n24 | ||
124 | , handshakeData = encrypt state $ encodePlain myhandshakeData | ||
125 | } | ||
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs deleted file mode 100644 index 9a9c893a..00000000 --- a/src/Network/Tox/NodeId.hs +++ /dev/null | |||
@@ -1,731 +0,0 @@ | |||
1 | {- LANGUAGE ApplicativeDo -} | ||
2 | {-# LANGUAGE BangPatterns #-} | ||
3 | {-# LANGUAGE CPP #-} | ||
4 | {-# LANGUAGE DataKinds #-} | ||
5 | {-# LANGUAGE DeriveDataTypeable #-} | ||
6 | {-# LANGUAGE DeriveFunctor #-} | ||
7 | {-# LANGUAGE DeriveTraversable #-} | ||
8 | {-# LANGUAGE ExistentialQuantification #-} | ||
9 | {-# LANGUAGE FlexibleInstances #-} | ||
10 | {-# LANGUAGE GADTs #-} | ||
11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
12 | {-# LANGUAGE KindSignatures #-} | ||
13 | {-# LANGUAGE LambdaCase #-} | ||
14 | {-# LANGUAGE PatternSynonyms #-} | ||
15 | {-# LANGUAGE ScopedTypeVariables #-} | ||
16 | {-# LANGUAGE StandaloneDeriving #-} | ||
17 | {-# LANGUAGE TupleSections #-} | ||
18 | {- LANGUAGE TypeApplications -} | ||
19 | module Network.Tox.NodeId | ||
20 | ( NodeInfo(..) | ||
21 | , NodeId | ||
22 | , nodeInfo | ||
23 | , nodeAddr | ||
24 | , zeroID | ||
25 | , key2id | ||
26 | , id2key | ||
27 | , getIP | ||
28 | , xorNodeId | ||
29 | , testNodeIdBit | ||
30 | , sampleNodeId | ||
31 | , NoSpam(..) | ||
32 | , NoSpamId(..) | ||
33 | , noSpamIdToHex | ||
34 | , parseNoSpamId | ||
35 | , nospam64 | ||
36 | , nospam16 | ||
37 | , verifyChecksum | ||
38 | , ToxContact(..) | ||
39 | , ToxProgress(..) | ||
40 | , parseToken32 | ||
41 | , showToken32 | ||
42 | ) where | ||
43 | |||
44 | import Control.Applicative | ||
45 | import Control.Arrow | ||
46 | import Control.Monad | ||
47 | #ifdef CRYPTONITE_BACKPORT | ||
48 | import Crypto.Error.Types (CryptoFailable (..), | ||
49 | throwCryptoError) | ||
50 | #else | ||
51 | import Crypto.Error | ||
52 | #endif | ||
53 | |||
54 | import Crypto.PubKey.Curve25519 | ||
55 | import qualified Data.Aeson as JSON | ||
56 | ;import Data.Aeson (FromJSON, ToJSON, (.=)) | ||
57 | import Data.Bits.ByteString () | ||
58 | import qualified Data.ByteArray as BA | ||
59 | ;import Data.ByteArray as BA (ByteArrayAccess) | ||
60 | import qualified Data.ByteString as B | ||
61 | ;import Data.ByteString (ByteString) | ||
62 | import qualified Data.ByteString.Base16 as Base16 | ||
63 | import qualified Data.ByteString.Base64 as Base64 | ||
64 | import qualified Data.ByteString.Char8 as C8 | ||
65 | import Data.Char | ||
66 | import Data.Data | ||
67 | import Data.Hashable | ||
68 | #if MIN_VERSION_iproute(1,7,4) | ||
69 | import Data.IP hiding (fromSockAddr) | ||
70 | #else | ||
71 | import Data.IP | ||
72 | #endif | ||
73 | import Data.List | ||
74 | import Data.Maybe | ||
75 | import Data.Serialize as S | ||
76 | import Data.Word | ||
77 | import Foreign.Storable | ||
78 | import GHC.TypeLits | ||
79 | import Network.Address hiding (nodePort) | ||
80 | import System.IO.Unsafe (unsafeDupablePerformIO) | ||
81 | import qualified Text.ParserCombinators.ReadP as RP | ||
82 | import Text.Read hiding (get) | ||
83 | import Data.Bits | ||
84 | import Crypto.Tox | ||
85 | import Foreign.Ptr | ||
86 | import Data.Function | ||
87 | import System.Endian | ||
88 | import qualified Data.Text as Text | ||
89 | ;import Data.Text (Text) | ||
90 | import Util (splitJID) | ||
91 | |||
92 | -- | perform io for hashes that do allocation and ffi. | ||
93 | -- unsafeDupablePerformIO is used when possible as the | ||
94 | -- computation is pure and the output is directly linked | ||
95 | -- to the input. we also do not modify anything after it has | ||
96 | -- been returned to the user. | ||
97 | unsafeDoIO :: IO a -> a | ||
98 | #if __GLASGOW_HASKELL__ > 704 | ||
99 | unsafeDoIO = unsafeDupablePerformIO | ||
100 | #else | ||
101 | unsafeDoIO = unsafePerformIO | ||
102 | #endif | ||
103 | |||
104 | unpackPublicKey :: ByteArrayAccess bs => bs -> [Word64] | ||
105 | unpackPublicKey bs = loop 0 | ||
106 | where loop i | ||
107 | | i == (BA.length bs `div` 8) = [] | ||
108 | | otherwise = | ||
109 | let !v = unsafeDoIO $ BA.withByteArray bs (\p -> fromBE64 <$> peekElemOff p i) | ||
110 | in v : loop (i+1) | ||
111 | |||
112 | packPublicKey :: BA.ByteArray bs => [Word64] -> bs | ||
113 | packPublicKey ws = BA.allocAndFreeze (8 * length ws) $ | ||
114 | flip fix ws $ \loop ys ptr -> case ys of | ||
115 | [] -> return () | ||
116 | x:xs -> do poke ptr (toBE64 x) | ||
117 | loop xs (plusPtr ptr 8) | ||
118 | {-# NOINLINE packPublicKey #-} | ||
119 | |||
120 | -- We represent the node id redundantly in two formats. The [Word64] format is | ||
121 | -- convenient for short-circuiting xor/distance comparisons. The PublicKey | ||
122 | -- format is convenient for encryption. | ||
123 | data NodeId = NodeId [Word64] !(Maybe PublicKey) | ||
124 | deriving Data | ||
125 | |||
126 | instance Data PublicKey where | ||
127 | -- Data a => (forall d b . Data d => c (d -> b) -> d -> c b) -> (forall g . g -> c g) -> a -> c a | ||
128 | gfoldl f z txt = z (throwCryptoError . publicKey) `f` (BA.convert txt :: ByteString) | ||
129 | toConstr _ = error "Crypto.PubKey.Curve25519.toConstr" | ||
130 | gunfold _ _ = error "Crypto.PubKey.Curve25519.gunfold" | ||
131 | #if MIN_VERSION_base(4,2,0) | ||
132 | dataTypeOf _ = mkNoRepType "Crypto.PubKey.Curve25519.PublicKey" | ||
133 | #else | ||
134 | dataTypeOf _ = mkNorepType "Crypto.PubKey.Curve25519.PublicKey" | ||
135 | #endif | ||
136 | |||
137 | |||
138 | instance Eq NodeId where | ||
139 | (NodeId ws _) == (NodeId xs _) | ||
140 | = ws == xs | ||
141 | |||
142 | instance Ord NodeId where | ||
143 | compare (NodeId ws _) (NodeId xs _) = compare ws xs | ||
144 | |||
145 | instance Sized NodeId where size = ConstSize 32 | ||
146 | |||
147 | key2id :: PublicKey -> NodeId | ||
148 | key2id k = NodeId (unpackPublicKey k) (Just k) | ||
149 | |||
150 | bs2id :: ByteString -> NodeId | ||
151 | bs2id bs = uncurry NodeId . (unpackPublicKey &&& Just) $ throwCryptoError . publicKey $ bs | ||
152 | |||
153 | id2key :: NodeId -> PublicKey | ||
154 | id2key (NodeId ws (Just key)) = key | ||
155 | id2key (NodeId key Nothing) = throwCryptoError . publicKey $ (packPublicKey key :: BA.Bytes) | ||
156 | |||
157 | zeroKey :: PublicKey | ||
158 | zeroKey = throwCryptoError $ publicKey $ B.replicate 32 0 | ||
159 | |||
160 | zeroID :: NodeId | ||
161 | zeroID = NodeId (replicate 4 0) (Just zeroKey) | ||
162 | |||
163 | -- | Convert to and from a Base64 variant that uses .- instead of +/. | ||
164 | nmtoken64 :: Bool -> Char -> Char | ||
165 | nmtoken64 False '.' = '+' | ||
166 | nmtoken64 False '-' = '/' | ||
167 | nmtoken64 True '+' = '.' | ||
168 | nmtoken64 True '/' = '-' | ||
169 | nmtoken64 _ c = c | ||
170 | |||
171 | -- | Parse 43-digit base64 token into 32-byte bytestring. | ||
172 | parseToken32 :: String -> Either String ByteString | ||
173 | parseToken32 str = fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str) | ||
174 | |||
175 | -- | Encode 32-byte bytestring as 43-digit base64 token. | ||
176 | showToken32 :: ByteArrayAccess bin => bin -> String | ||
177 | showToken32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs | ||
178 | |||
179 | instance Read NodeId where | ||
180 | readsPrec _ str | ||
181 | | (bs,_) <- Base16.decode (C8.pack $ take 64 str) | ||
182 | , CryptoPassed pub <- publicKey bs -- B.length bs == 32 | ||
183 | = [ (key2id pub, drop (2 * B.length bs) str) ] | ||
184 | | Right bs <- parseToken32 str | ||
185 | , CryptoPassed pub <- publicKey bs -- B.length bs == 32 | ||
186 | = [ (key2id pub, drop 43 str) ] | ||
187 | | otherwise = [] | ||
188 | |||
189 | instance Show NodeId where | ||
190 | show nid = showToken32 $ id2key nid | ||
191 | |||
192 | instance S.Serialize NodeId where | ||
193 | get = key2id <$> getPublicKey | ||
194 | put nid = putPublicKey $ id2key nid | ||
195 | |||
196 | instance Hashable NodeId where | ||
197 | hashWithSalt salt (NodeId ws _) = hashWithSalt salt (head ws) | ||
198 | |||
199 | testNodeIdBit :: NodeId -> Word -> Bool | ||
200 | testNodeIdBit (NodeId ws _) i -- TODO: Optmize: use ByteArray key if it's available. | ||
201 | | fromIntegral i < 256 -- 256 bits | ||
202 | , (q, r) <- quotRem (fromIntegral i) 64 | ||
203 | = testBit (ws !! q) (63 - r) | ||
204 | | otherwise = False | ||
205 | |||
206 | xorNodeId :: NodeId -> NodeId -> NodeId | ||
207 | xorNodeId (NodeId xs _) (NodeId ys _) = NodeId (zipWith xor xs ys) Nothing | ||
208 | |||
209 | sampleNodeId :: Applicative m => (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId | ||
210 | sampleNodeId gen (NodeId self k) (q,m,b) | ||
211 | | q <= 0 = bs2id <$> gen 32 | ||
212 | | q >= 32 = pure (NodeId self k) | ||
213 | | let (qw,r) = (q+7) `divMod` 8 -- How many Word64 to prepend? | ||
214 | bw = shiftL (fromIntegral b) (8*(7-r)) | ||
215 | mw = bw - 1 :: Word64 | ||
216 | (hd, t0 : _) = splitAt (qw-1) self | ||
217 | h = xor bw (complement mw .&. t0) | ||
218 | = flip fmap (gen $ 8 * (4 - (qw-1)) ) $ \bs -> | ||
219 | let (w:ws) = unpackPublicKey bs | ||
220 | in NodeId (hd ++ (h .|. (w .&. mw)) : ws) Nothing | ||
221 | |||
222 | data NodeInfo = NodeInfo | ||
223 | { nodeId :: NodeId | ||
224 | , nodeIP :: IP | ||
225 | , nodePort :: PortNumber | ||
226 | } | ||
227 | deriving (Eq,Ord) | ||
228 | |||
229 | nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo | ||
230 | nodeInfo nid saddr | ||
231 | | Just ip <- fromSockAddr saddr | ||
232 | , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port | ||
233 | | otherwise = Left "Address family not supported." | ||
234 | |||
235 | |||
236 | instance ToJSON NodeInfo where | ||
237 | toJSON (NodeInfo nid (IPv4 ip) port) | ||
238 | = JSON.object [ "public_key" .= show nid | ||
239 | , "ipv4" .= show ip | ||
240 | , "port" .= (fromIntegral port :: Int) | ||
241 | ] | ||
242 | toJSON (NodeInfo nid (IPv6 ip6) port) | ||
243 | | Just ip <- un4map ip6 | ||
244 | = JSON.object [ "public_key" .= show nid | ||
245 | , "ipv4" .= show ip | ||
246 | , "port" .= (fromIntegral port :: Int) | ||
247 | ] | ||
248 | | otherwise | ||
249 | = JSON.object [ "public_key" .= show nid | ||
250 | , "ipv6" .= show ip6 | ||
251 | , "port" .= (fromIntegral port :: Int) | ||
252 | ] | ||
253 | instance FromJSON NodeInfo where | ||
254 | parseJSON (JSON.Object v) = do | ||
255 | nidstr <- v JSON..: "public_key" | ||
256 | ip6str <- v JSON..:? "ipv6" | ||
257 | ip4str <- v JSON..:? "ipv4" | ||
258 | portnum <- v JSON..: "port" | ||
259 | ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) | ||
260 | <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) | ||
261 | let (bs,_) = Base16.decode (C8.pack nidstr) | ||
262 | enid = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr) | ||
263 | idbs <- (guard (B.length bs == 32) >> return bs) | ||
264 | <|> either fail (return . B.drop 1) enid | ||
265 | return $ NodeInfo (bs2id idbs) ip (fromIntegral (portnum :: Word16)) | ||
266 | |||
267 | getIP :: Word8 -> S.Get IP | ||
268 | getIP 0x02 = IPv4 <$> S.get | ||
269 | getIP 0x0a = IPv6 <$> S.get | ||
270 | getIP 0x82 = IPv4 <$> S.get -- TODO: TCP | ||
271 | getIP 0x8a = IPv6 <$> S.get -- TODO: TCP | ||
272 | getIP x = fail ("unsupported address family ("++show x++")") | ||
273 | |||
274 | instance Sized NodeInfo where | ||
275 | size = VarSize $ \(NodeInfo nid ip port) -> | ||
276 | case ip of | ||
277 | IPv4 _ -> 39 -- 35 + 4 = 1 + 4 + 2 + 32 | ||
278 | IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32 | ||
279 | |||
280 | instance S.Serialize NodeInfo where | ||
281 | get = do | ||
282 | addrfam <- S.get :: S.Get Word8 | ||
283 | let fallback = do -- FIXME: Handle unrecognized address families. | ||
284 | IPv6 <$> S.get | ||
285 | return $ IPv6 (read "::" :: IPv6) | ||
286 | ip <- getIP addrfam <|> fallback | ||
287 | port <- S.get :: S.Get PortNumber | ||
288 | nid <- S.get | ||
289 | return $ NodeInfo nid ip port | ||
290 | |||
291 | put (NodeInfo nid ip port) = do | ||
292 | case ip of | ||
293 | IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 | ||
294 | IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 | ||
295 | S.put port | ||
296 | S.put nid | ||
297 | |||
298 | hexdigit :: Char -> Bool | ||
299 | hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') | ||
300 | |||
301 | b64digit :: Char -> Bool | ||
302 | b64digit '.' = True | ||
303 | b64digit '+' = True | ||
304 | b64digit '-' = True | ||
305 | b64digit '/' = True | ||
306 | b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z') | ||
307 | |||
308 | ip_w_port :: Int -> RP.ReadP (IP, PortNumber) | ||
309 | ip_w_port i = do | ||
310 | ip <- RP.between (RP.char '[') (RP.char ']') | ||
311 | (IPv6 <$> RP.readS_to_P (readsPrec i)) | ||
312 | RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) | ||
313 | _ <- RP.char ':' | ||
314 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
315 | return (ip, port) | ||
316 | |||
317 | |||
318 | instance Read NodeInfo where | ||
319 | readsPrec i = RP.readP_to_S $ do | ||
320 | RP.skipSpaces | ||
321 | let n = 43 -- characters in node id. | ||
322 | parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) | ||
323 | RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char]))) | ||
324 | nodeidAt = do (is64,hexhash) <- | ||
325 | fmap (True,) (sequence $ replicate n (RP.satisfy b64digit)) | ||
326 | RP.+++ fmap (False,) (sequence $ replicate 64 (RP.satisfy isHexDigit)) | ||
327 | RP.char '@' RP.+++ RP.satisfy isSpace | ||
328 | addrstr <- parseAddr | ||
329 | nid <- if is64 | ||
330 | then case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of | ||
331 | Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs) | ||
332 | _ -> fail "Bad node id." | ||
333 | else case Base16.decode $ C8.pack hexhash of | ||
334 | (bs,rem) | B.length bs == 32 && B.null rem -> return (bs2id bs) | ||
335 | _ -> fail "Bad node id." | ||
336 | return (nid,addrstr) | ||
337 | (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) | ||
338 | (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of | ||
339 | [] -> fail "Bad address." | ||
340 | ((ip,port),_):_ -> return (ip,port) | ||
341 | return $ NodeInfo nid ip port | ||
342 | |||
343 | -- The Hashable instance depends only on the IP address and port number. | ||
344 | -- | ||
345 | -- TODO: Why is the node id excluded? | ||
346 | instance Hashable NodeInfo where | ||
347 | hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) | ||
348 | {-# INLINE hashWithSalt #-} | ||
349 | |||
350 | |||
351 | instance Show NodeInfo where | ||
352 | showsPrec _ (NodeInfo nid ip port) = | ||
353 | shows nid . ('@' :) . showsip . (':' :) . shows port | ||
354 | where | ||
355 | showsip | ||
356 | | IPv4 ip4 <- ip = shows ip4 | ||
357 | | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 | ||
358 | | otherwise = ('[' :) . shows ip . (']' :) | ||
359 | |||
360 | |||
361 | |||
362 | |||
363 | {- | ||
364 | type NodeId = PubKey | ||
365 | |||
366 | pattern NodeId bs = PubKey bs | ||
367 | |||
368 | -- TODO: This should probably be represented by Curve25519.PublicKey, but | ||
369 | -- ByteString has more instances... | ||
370 | newtype PubKey = PubKey ByteString | ||
371 | deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable) | ||
372 | |||
373 | instance Serialize PubKey where | ||
374 | get = PubKey <$> getBytes 32 | ||
375 | put (PubKey bs) = putByteString bs | ||
376 | |||
377 | instance Show PubKey where | ||
378 | show (PubKey bs) = C8.unpack $ Base16.encode bs | ||
379 | |||
380 | instance FiniteBits PubKey where | ||
381 | finiteBitSize _ = 256 | ||
382 | |||
383 | instance Read PubKey where | ||
384 | readsPrec _ str | ||
385 | | (bs, xs) <- Base16.decode $ C8.pack str | ||
386 | , B.length bs == 32 | ||
387 | = [ (PubKey bs, drop 64 str) ] | ||
388 | | otherwise = [] | ||
389 | |||
390 | |||
391 | |||
392 | |||
393 | data NodeInfo = NodeInfo | ||
394 | { nodeId :: NodeId | ||
395 | , nodeIP :: IP | ||
396 | , nodePort :: PortNumber | ||
397 | } | ||
398 | deriving (Eq,Ord,Data) | ||
399 | |||
400 | instance Data PortNumber where | ||
401 | dataTypeOf _ = mkNoRepType "PortNumber" | ||
402 | toConstr _ = error "PortNumber.toConstr" | ||
403 | gunfold _ _ = error "PortNumber.gunfold" | ||
404 | |||
405 | instance ToJSON NodeInfo where | ||
406 | toJSON (NodeInfo nid (IPv4 ip) port) | ||
407 | = JSON.object [ "public_key" .= show nid | ||
408 | , "ipv4" .= show ip | ||
409 | , "port" .= (fromIntegral port :: Int) | ||
410 | ] | ||
411 | toJSON (NodeInfo nid (IPv6 ip6) port) | ||
412 | | Just ip <- un4map ip6 | ||
413 | = JSON.object [ "public_key" .= show nid | ||
414 | , "ipv4" .= show ip | ||
415 | , "port" .= (fromIntegral port :: Int) | ||
416 | ] | ||
417 | | otherwise | ||
418 | = JSON.object [ "public_key" .= show nid | ||
419 | , "ipv6" .= show ip6 | ||
420 | , "port" .= (fromIntegral port :: Int) | ||
421 | ] | ||
422 | instance FromJSON NodeInfo where | ||
423 | parseJSON (JSON.Object v) = do | ||
424 | nidstr <- v JSON..: "public_key" | ||
425 | ip6str <- v JSON..:? "ipv6" | ||
426 | ip4str <- v JSON..:? "ipv4" | ||
427 | portnum <- v JSON..: "port" | ||
428 | ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) | ||
429 | <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) | ||
430 | let (bs,_) = Base16.decode (C8.pack nidstr) | ||
431 | guard (B.length bs == 32) | ||
432 | return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) | ||
433 | |||
434 | getIP :: Word8 -> S.Get IP | ||
435 | getIP 0x02 = IPv4 <$> S.get | ||
436 | getIP 0x0a = IPv6 <$> S.get | ||
437 | getIP 0x82 = IPv4 <$> S.get -- TODO: TCP | ||
438 | getIP 0x8a = IPv6 <$> S.get -- TODO: TCP | ||
439 | getIP x = fail ("unsupported address family ("++show x++")") | ||
440 | |||
441 | instance S.Serialize NodeInfo where | ||
442 | get = do | ||
443 | addrfam <- S.get :: S.Get Word8 | ||
444 | ip <- getIP addrfam | ||
445 | port <- S.get :: S.Get PortNumber | ||
446 | nid <- S.get | ||
447 | return $ NodeInfo nid ip port | ||
448 | |||
449 | put (NodeInfo nid ip port) = do | ||
450 | case ip of | ||
451 | IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 | ||
452 | IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 | ||
453 | S.put port | ||
454 | S.put nid | ||
455 | |||
456 | -- node format: | ||
457 | -- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)] | ||
458 | -- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6] | ||
459 | -- [port (in network byte order), length=2 bytes] | ||
460 | -- [char array (node_id), length=32 bytes] | ||
461 | -- | ||
462 | |||
463 | |||
464 | hexdigit :: Char -> Bool | ||
465 | hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') | ||
466 | |||
467 | instance Read NodeInfo where | ||
468 | readsPrec i = RP.readP_to_S $ do | ||
469 | RP.skipSpaces | ||
470 | let n = 64 -- characters in node id. | ||
471 | parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) | ||
472 | RP.+++ RP.munch (not . isSpace) | ||
473 | nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit) | ||
474 | RP.char '@' RP.+++ RP.satisfy isSpace | ||
475 | addrstr <- parseAddr | ||
476 | nid <- case Base16.decode $ C8.pack hexhash of | ||
477 | (bs,_) | B.length bs==32 -> return (PubKey bs) | ||
478 | _ -> fail "Bad node id." | ||
479 | return (nid,addrstr) | ||
480 | (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) | ||
481 | let raddr = do | ||
482 | ip <- RP.between (RP.char '[') (RP.char ']') | ||
483 | (IPv6 <$> RP.readS_to_P (readsPrec i)) | ||
484 | RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) | ||
485 | _ <- RP.char ':' | ||
486 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
487 | return (ip, port) | ||
488 | |||
489 | (ip,port) <- case RP.readP_to_S raddr addrstr of | ||
490 | [] -> fail "Bad address." | ||
491 | ((ip,port),_):_ -> return (ip,port) | ||
492 | return $ NodeInfo nid ip port | ||
493 | |||
494 | |||
495 | -- The Hashable instance depends only on the IP address and port number. | ||
496 | instance Hashable NodeInfo where | ||
497 | hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) | ||
498 | {-# INLINE hashWithSalt #-} | ||
499 | |||
500 | |||
501 | instance Show NodeInfo where | ||
502 | showsPrec _ (NodeInfo nid ip port) = | ||
503 | shows nid . ('@' :) . showsip . (':' :) . shows port | ||
504 | where | ||
505 | showsip | ||
506 | | IPv4 ip4 <- ip = shows ip4 | ||
507 | | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 | ||
508 | | otherwise = ('[' :) . shows ip . (']' :) | ||
509 | |||
510 | nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo | ||
511 | nodeInfo nid saddr | ||
512 | | Just ip <- fromSockAddr saddr | ||
513 | , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port | ||
514 | | otherwise = Left "Address family not supported." | ||
515 | |||
516 | zeroID :: NodeId | ||
517 | zeroID = PubKey $ B.replicate 32 0 | ||
518 | |||
519 | -} | ||
520 | |||
521 | nodeAddr :: NodeInfo -> SockAddr | ||
522 | nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip | ||
523 | |||
524 | |||
525 | newtype ForwardPath (n::Nat) = ForwardPath ByteString | ||
526 | deriving (Eq, Ord,Data) | ||
527 | |||
528 | {- | ||
529 | class KnownNat n => OnionPacket n where | ||
530 | mkOnion :: ReturnPath n -> Packet -> Packet | ||
531 | instance OnionPacket 0 where mkOnion _ = id | ||
532 | instance OnionPacket 3 where mkOnion = OnionResponse3 | ||
533 | -} | ||
534 | |||
535 | data NoSpam = NoSpam !Word32 !(Maybe Word16) | ||
536 | deriving (Eq,Ord,Show) | ||
537 | |||
538 | instance Serialize NoSpam where | ||
539 | get = NoSpam <$> get <*> get | ||
540 | put (NoSpam w32 w16) = do | ||
541 | put w32 | ||
542 | put w16 | ||
543 | |||
544 | -- Utilizes Data.Serialize format for Word32 nospam and Word16 checksum. | ||
545 | instance Read NoSpam where | ||
546 | readsPrec d s = case break isSpace s of | ||
547 | ('$':ws ,rs) | (length ws == 8) -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws | ||
548 | ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws | ||
549 | _ -> [] | ||
550 | |||
551 | base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1) | ||
552 | base64decode rs getter s = | ||
553 | either fail (\a -> return (a,rs)) | ||
554 | $ runGet getter | ||
555 | =<< Base64.decode (C8.pack $ map (nmtoken64 False) s) | ||
556 | |||
557 | base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1) | ||
558 | base16decode rs getter s = | ||
559 | either fail (\a -> return (a,rs)) | ||
560 | $ runGet getter | ||
561 | $ fst | ||
562 | $ Base16.decode (C8.pack s) | ||
563 | |||
564 | verifyChecksum :: PublicKey -> Word16 -> Either String () | ||
565 | verifyChecksum _ _ = return () -- TODO | ||
566 | |||
567 | data NoSpamId = NoSpamId NoSpam PublicKey | ||
568 | deriving (Eq,Ord) | ||
569 | |||
570 | noSpamIdToHex :: NoSpamId -> String | ||
571 | noSpamIdToHex (NoSpamId nspam pub) = C8.unpack (Base16.encode $ BA.convert pub) | ||
572 | ++ nospam16 nspam | ||
573 | |||
574 | nospam16 :: NoSpam -> String | ||
575 | nospam16 (NoSpam w32 Nothing) = n ++ "????" | ||
576 | where n = take 8 $ nospam16 (NoSpam w32 (Just 0)) | ||
577 | nospam16 (NoSpam w32 (Just w16)) = C8.unpack $ Base16.encode $ runPut $ do | ||
578 | put w32 | ||
579 | put w16 | ||
580 | |||
581 | nospam64 :: NoSpam -> String | ||
582 | nospam64 (NoSpam w32 Nothing) = n ++ "???" | ||
583 | where n = take 5 $ nospam64 (NoSpam w32 (Just 0)) | ||
584 | nospam64 (NoSpam w32 (Just w16)) = map (nmtoken64 True) $ C8.unpack $ Base64.encode $ runPut $ do | ||
585 | put w32 | ||
586 | put w16 | ||
587 | |||
588 | instance Show NoSpamId where | ||
589 | show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox" | ||
590 | |||
591 | instance Read NoSpamId where | ||
592 | readsPrec d s = either fail id $ do | ||
593 | (jid,xs) <- Right $ break isSpace s | ||
594 | nsid <- parseNoSpamId $ Text.pack jid | ||
595 | return [(nsid,xs)] | ||
596 | |||
597 | parseNoSpamHex :: Text -> Either String NoSpamId | ||
598 | parseNoSpamHex hex = Right $ NoSpamId (read $ "0x"++nospamsum) (id2key $ read hkey) | ||
599 | where | ||
600 | (hkey,nospamsum) = splitAt 64 $ Text.unpack hex | ||
601 | |||
602 | parseNoSpamId :: Text -> Either String NoSpamId | ||
603 | parseNoSpamId spec | Text.length spec == 76 | ||
604 | , Text.all isHexDigit spec = parseNoSpamHex spec | ||
605 | | otherwise = parseNoSpamJID spec | ||
606 | |||
607 | parseNoSpamJID :: Text -> Either String NoSpamId | ||
608 | parseNoSpamJID jid = do | ||
609 | (u,h) <- maybe (Left "Invalid JID.") Right | ||
610 | $ let (mu,h,_) = splitJID jid | ||
611 | in fmap (, h) mu | ||
612 | base64 <- case splitAt 43 $ Text.unpack h of | ||
613 | (base64,".tox") -> Right base64 | ||
614 | _ -> Left "Hostname should be 43 base64 digits followed by .tox." | ||
615 | pub <- id2key <$> readEither base64 | ||
616 | let ustr = Text.unpack u | ||
617 | case ustr of | ||
618 | '$' : b64digits -> solveBase64NoSpamID b64digits pub | ||
619 | '0' : 'x' : hexdigits -> do nospam <- readEither ('0':'x':hexdigits) | ||
620 | return $ NoSpamId nospam pub | ||
621 | _ -> Left "Missing nospam." | ||
622 | |||
623 | solveBase64NoSpamID :: String -> PublicKey -> Either String NoSpamId | ||
624 | solveBase64NoSpamID b64digits pub = do | ||
625 | NoSpam nospam mx <- readEither $ '$' : map (\case; '?' -> '0'; c -> c) b64digits | ||
626 | maybe (const $ Left "missing checksum") (flip ($)) mx $ \x -> do | ||
627 | let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 | ||
628 | nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 | ||
629 | sum = x `xor` nlo `xor` nhi `xor` xorsum pub | ||
630 | -- Find any question mark indices. | ||
631 | qs = catMaybes $ zipWith (\case; '?' -> Just ; _ -> const Nothing) b64digits [0..7] | ||
632 | -- Break up the /sum/ into a numbered list of two-bit non-zero nibbles. | ||
633 | ns = filter (\case; (_,0) -> False; _ -> True) | ||
634 | $ zip [0..7] | ||
635 | $ unfoldr (\s -> Just (s .&. 0xC000, s `shiftL` 2)) sum | ||
636 | -- Represent the nospam value as a Word64 | ||
637 | n64 = shiftL (fromIntegral nospam) 32 .|. shiftL (fromIntegral x) 16 :: Word64 | ||
638 | |||
639 | -- q=0 1 2 3 4 5 6 7 | ||
640 | -- 012 345 670 123 456 701 234 567 | ||
641 | nibblePlace n q = case mod (n - 3 * q) 8 of | ||
642 | p | p < 3 -> Just (q,p) | ||
643 | _ -> Nothing | ||
644 | |||
645 | solve [] !ac = Right ac | ||
646 | solve ((n,b):ns) !ac = do | ||
647 | -- Find nibble p of question-digit q that corresponds to nibble n. | ||
648 | (q,p) <- maybe (Left "Unsolvable nospam.") Right | ||
649 | $ foldr (<|>) Nothing $ map (nibblePlace n) qs | ||
650 | let bitpos = q * 6 + p * 2 | ||
651 | ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos | ||
652 | solve ns ac' | ||
653 | n64' <- solve ns n64 | ||
654 | let nospam' = fromIntegral (n64' `shiftR` 32) | ||
655 | cksum' = fromIntegral (n64' `shiftR` 16) | ||
656 | return $ NoSpamId (NoSpam nospam' (Just cksum')) pub | ||
657 | |||
658 | -- | This type indicates a roster-link relationship between a local toxid and a | ||
659 | -- remote toxid. Note that these toxids are represented as the type 'NodeId' | ||
660 | -- even though they are long-term keys rather than the public keys of Tox DHT | ||
661 | -- nodes. | ||
662 | data ToxContact = ToxContact NodeId{-me-} NodeId{-them-} | ||
663 | deriving (Eq,Ord) | ||
664 | |||
665 | instance Show ToxContact where show = show . showToxContact_ | ||
666 | |||
667 | showToxContact_ :: ToxContact -> String | ||
668 | showToxContact_ (ToxContact me them) = show me ++ ":" ++ show them | ||
669 | |||
670 | -- | This type indicates the progress of a tox encrypted friend link | ||
671 | -- connection. Two scenarios are illustrated below. The parenthesis show the | ||
672 | -- current 'G.Status' 'ToxProgress' of the session. | ||
673 | -- | ||
674 | -- | ||
675 | -- Perfect handshake scenario: | ||
676 | -- | ||
677 | -- Peer 1 Peer 2 | ||
678 | -- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie) | ||
679 | -- Cookie request -> | ||
680 | -- <- Cookie response | ||
681 | -- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie) | ||
682 | -- Handshake packet -> | ||
683 | -- * accepts connection | ||
684 | -- (InProgress AwaitingSessionPacket) | ||
685 | -- <- Handshake packet | ||
686 | -- *accepts connection | ||
687 | -- (InProgress AwaitingSessionPacket) | ||
688 | -- Encrypted packet -> <- Encrypted packet | ||
689 | -- *confirms connection *confirms connection | ||
690 | -- (Established) (Established) | ||
691 | -- | ||
692 | -- Connection successful. | ||
693 | -- | ||
694 | -- Encrypted packets -> <- Encrypted packets | ||
695 | -- | ||
696 | -- | ||
697 | -- | ||
698 | -- | ||
699 | -- More realistic handshake scenario: | ||
700 | -- Peer 1 Peer 2 | ||
701 | -- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie) | ||
702 | -- Cookie request -> *packet lost* | ||
703 | -- Cookie request -> | ||
704 | -- <- Cookie response | ||
705 | -- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie) | ||
706 | -- | ||
707 | -- *Peer 2 randomly starts new connection to peer 1 | ||
708 | -- (InProgress AcquiringCookie) | ||
709 | -- <- Cookie request | ||
710 | -- Cookie response -> | ||
711 | -- (InProgress AwaitingHandshake) | ||
712 | -- | ||
713 | -- Handshake packet -> <- Handshake packet | ||
714 | -- *accepts connection * accepts connection | ||
715 | -- (InProgress AwaitingSessionPacket) (InProgress AwaitingSessionPacket) | ||
716 | -- | ||
717 | -- Encrypted packet -> <- Encrypted packet | ||
718 | -- *confirms connection *confirms connection | ||
719 | -- (Established) (Established) | ||
720 | -- | ||
721 | -- Connection successful. | ||
722 | -- | ||
723 | -- Encrypted packets -> <- Encrypted packets | ||
724 | data ToxProgress | ||
725 | = AwaitingDHTKey -- ^ Waiting to receive their DHT key. | ||
726 | | AcquiringIPAddress -- ^ Searching DHT to obtain their node's IP & port. | ||
727 | | AcquiringCookie -- ^ Attempting to obtain a cookie. | ||
728 | | AwaitingHandshake -- ^ Waiting to receive a handshake. | ||
729 | | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed". | ||
730 | deriving (Eq,Ord,Enum,Show) | ||
731 | |||
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs deleted file mode 100644 index f44dd79c..00000000 --- a/src/Network/Tox/Onion/Handlers.hs +++ /dev/null | |||
@@ -1,369 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE LambdaCase #-} | ||
3 | {-# LANGUAGE PatternSynonyms #-} | ||
4 | module Network.Tox.Onion.Handlers where | ||
5 | |||
6 | import Network.Kademlia.Search | ||
7 | import Network.Tox.DHT.Transport | ||
8 | import Network.Tox.DHT.Handlers hiding (Message,Client) | ||
9 | import Network.Tox.Onion.Transport | ||
10 | import Network.QueryResponse as QR hiding (Client) | ||
11 | import qualified Network.QueryResponse as QR (Client) | ||
12 | import Crypto.Tox | ||
13 | import qualified Data.Wrapper.PSQ as PSQ | ||
14 | ;import Data.Wrapper.PSQ (PSQ,pattern (:->)) | ||
15 | import Control.Arrow | ||
16 | |||
17 | import Data.Function | ||
18 | import qualified Data.MinMaxPSQ as MinMaxPSQ | ||
19 | ;import Data.MinMaxPSQ (MinMaxPSQ') | ||
20 | import Network.BitTorrent.DHT.Token as Token | ||
21 | |||
22 | import Control.Exception hiding (Handler) | ||
23 | import Control.Monad | ||
24 | #ifdef THREAD_DEBUG | ||
25 | import Control.Concurrent.Lifted.Instrument | ||
26 | #else | ||
27 | import Control.Concurrent | ||
28 | import GHC.Conc (labelThread) | ||
29 | #endif | ||
30 | import Control.Concurrent.STM | ||
31 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) | ||
32 | import Network.Socket | ||
33 | #if MIN_VERSION_iproute(1,7,4) | ||
34 | import Data.IP hiding (fromSockAddr) | ||
35 | #else | ||
36 | import Data.IP | ||
37 | #endif | ||
38 | import Data.Maybe | ||
39 | import Data.Functor.Identity | ||
40 | import DPut | ||
41 | import DebugTag | ||
42 | |||
43 | type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message | ||
44 | type Message = OnionMessage Identity | ||
45 | |||
46 | classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message | ||
47 | classify msg = go msg | ||
48 | where | ||
49 | go (OnionAnnounce announce) = IsQuery AnnounceType | ||
50 | $ TransactionId (snd $ runIdentity $ asymmData announce) | ||
51 | (asymmNonce announce) | ||
52 | go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24) | ||
53 | go (OnionToRoute {}) = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24)) | ||
54 | go (OnionToRouteResponse {}) = IsResponse (TransactionId (Nonce8 0) (Nonce24 zeros24)) | ||
55 | |||
56 | -- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time, | ||
57 | -- some secret bytes generated when the instance is created, the current time | ||
58 | -- divided by a 20 second timeout, the public key of the requester and the source | ||
59 | -- ip/port that the packet was received from. Since the ip/port that the packet | ||
60 | -- was received from is in the `ping_id`, the announce packets being sent with a | ||
61 | -- ping id must be sent using the same path as the packet that we received the | ||
62 | -- `ping_id` from or announcing will fail. | ||
63 | -- | ||
64 | -- The reason for this 20 second timeout in toxcore is that it gives a reasonable | ||
65 | -- time (20 to 40 seconds) for a peer to announce himself while taking in count | ||
66 | -- all the possible delays with some extra seconds. | ||
67 | announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse | ||
68 | announceH routing toks keydb oaddr req = do | ||
69 | case () of | ||
70 | _ | announcePingId req == zeros32 | ||
71 | -> go False | ||
72 | |||
73 | _ -> let Nonce32 bs = announcePingId req | ||
74 | tok = fromPaddedByteString 32 bs | ||
75 | in checkToken toks (onionNodeInfo oaddr) tok >>= go | ||
76 | `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e) | ||
77 | where | ||
78 | go withTok = do | ||
79 | let naddr = onionNodeInfo oaddr | ||
80 | ns <- getNodesH routing naddr (GetNodes (announceSeeking req)) | ||
81 | tm <- getPOSIXTime | ||
82 | |||
83 | let storing = case oaddr of | ||
84 | OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth | ||
85 | _ -> Nothing | ||
86 | dput XAnnounce $ unlines [ "announceH: nodeId = " ++ show (nodeId naddr) | ||
87 | , " announceSeeking = " ++ show (announceSeeking req) | ||
88 | , " withTok = " ++ show withTok | ||
89 | , " storing = " ++ maybe "False" (const "True") storing | ||
90 | ] | ||
91 | record <- atomically $ do | ||
92 | forM_ storing $ \retpath -> when withTok $ do | ||
93 | let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath | ||
94 | -- Note: The following distance calculation assumes that | ||
95 | -- our nodeid doesn't change and is the same for both | ||
96 | -- routing4 and routing6. | ||
97 | d = xorNodeId (nodeId (tentativeId routing)) | ||
98 | (announceSeeking req) | ||
99 | modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d) | ||
100 | ks <- readTVar keydb | ||
101 | return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks) | ||
102 | newtok <- maybe (return $ zeros32) | ||
103 | (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr) | ||
104 | storing | ||
105 | let k = case record of | ||
106 | Nothing -> NotStored newtok | ||
107 | Just _ | isJust storing -> Acknowledged newtok | ||
108 | Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni) | ||
109 | let response = AnnounceResponse k ns | ||
110 | dput XAnnounce $ unwords ["Announce:", show req, "-reply->", show response] | ||
111 | return response | ||
112 | |||
113 | dataToRouteH :: | ||
114 | TVar AnnouncedKeys | ||
115 | -> Transport err (OnionDestination r) (OnionMessage f) | ||
116 | -> addr | ||
117 | -> OnionMessage f | ||
118 | -> IO () | ||
119 | dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do | ||
120 | let k = key2id pub | ||
121 | dput XOnion $ "dataToRouteH "++ show k | ||
122 | mb <- atomically $ do | ||
123 | ks <- readTVar keydb | ||
124 | forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do | ||
125 | writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) } | ||
126 | return rpath | ||
127 | dput XOnion $ "dataToRouteH "++ show (fmap (const ()) mb) | ||
128 | forM_ mb $ \rpath -> do | ||
129 | -- forward | ||
130 | dput XOnion $ "dataToRouteH sendMessage" | ||
131 | sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm | ||
132 | dput XOnion $ "Forwarding data-to-route -->"++show k | ||
133 | |||
134 | type NodeDistance = NodeId | ||
135 | |||
136 | data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3) | ||
137 | |||
138 | toOnionDestination :: AnnouncedRoute -> OnionDestination r | ||
139 | toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath | ||
140 | |||
141 | -- | | ||
142 | -- The type 'NodeId' was originally made for the DHT key, but here | ||
143 | -- we reuse it for user keys (public key/real key). | ||
144 | -- | ||
145 | -- To find someone using their user (public) key, you search for it on | ||
146 | -- kademlia. At each iteration of the search, you get a response with | ||
147 | -- closest known nodes(DHT keys) to the key you are searching for. | ||
148 | -- | ||
149 | -- To do an 'Announce' so your friends can find you, you do a search to | ||
150 | -- find the closest nodes to your own user(public) key. At those nodes, | ||
151 | -- you store a route back to yourself (using Announce message) so your | ||
152 | -- friends can contact you. This means each node needs to store the | ||
153 | -- saved routes, and that is the purpose of the 'AnnouncedKeys' data | ||
154 | -- structure. | ||
155 | -- | ||
156 | data AnnouncedKeys = AnnouncedKeys | ||
157 | { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-})) | ||
158 | , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute)) | ||
159 | -- ^ PSQ using NodeId(user/public key) as Key | ||
160 | -- and using 'NodeDistance' as priority. | ||
161 | -- (smaller number is higher priority) | ||
162 | -- | ||
163 | -- Keeping in a MinMaxPSQ will help us later when we want to make the structure | ||
164 | -- bounded. (We simply throw away the most NodeDistant keys. | ||
165 | } | ||
166 | |||
167 | |||
168 | insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys | ||
169 | insertKey tm pub toxpath d keydb = AnnouncedKeys | ||
170 | { keyByAge = PSQ.insert pub tm (keyByAge keydb) | ||
171 | , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of | ||
172 | Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb) | ||
173 | Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb) | ||
174 | } | ||
175 | |||
176 | -- | Forks a thread to garbage-collect old key announcements. Keys may be | ||
177 | -- discarded after 5 minutes. | ||
178 | forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId | ||
179 | forkAnnouncedKeysGC db = forkIO $ do | ||
180 | myThreadId >>= flip labelThread "gc:toxids" | ||
181 | fix $ \loop -> do | ||
182 | cutoff <- getPOSIXTime | ||
183 | threadDelay 300000000 -- 300 seconds | ||
184 | join $ atomically $ do | ||
185 | fix $ \gc -> do | ||
186 | keys <- readTVar db | ||
187 | case PSQ.minView (keyByAge keys) of | ||
188 | Nothing -> return loop | ||
189 | Just (pub :-> tm,kba') | ||
190 | | tm > cutoff -> return loop | ||
191 | | otherwise -> do writeTVar db keys | ||
192 | { keyByAge = kba' | ||
193 | , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys) | ||
194 | } | ||
195 | gc | ||
196 | |||
197 | areq :: Message -> Either String AnnounceRequest | ||
198 | areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm | ||
199 | areq _ = Left "Unexpected non-announce OnionMessage" | ||
200 | |||
201 | handlers :: Transport err (OnionDestination r) Message | ||
202 | -> Routing | ||
203 | -> TVar SessionTokens | ||
204 | -> TVar AnnouncedKeys | ||
205 | -> PacketKind | ||
206 | -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message) | ||
207 | handlers net routing toks keydb AnnounceType | ||
208 | = Just | ||
209 | $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity) | ||
210 | $ announceH routing toks keydb | ||
211 | handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net | ||
212 | |||
213 | |||
214 | toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
215 | -> TransportCrypto | ||
216 | -> Client r | ||
217 | -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous | ||
218 | toxidSearch getTimeout crypto client = Search | ||
219 | { searchSpace = toxSpace | ||
220 | , searchNodeAddress = nodeIP &&& nodePort | ||
221 | , searchQuery = Right $ asyncGetRendezvous getTimeout crypto client | ||
222 | , searchAlpha = 3 | ||
223 | , searchK = 6 | ||
224 | } | ||
225 | |||
226 | announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
227 | -> MethodSerializer | ||
228 | TransactionId | ||
229 | (OnionDestination r) | ||
230 | (OnionMessage Identity) | ||
231 | PacketKind | ||
232 | AnnounceRequest | ||
233 | (Maybe AnnounceResponse) | ||
234 | announceSerializer getTimeout = MethodSerializer | ||
235 | { methodTimeout = getTimeout | ||
236 | , method = AnnounceType | ||
237 | , wrapQuery = \(TransactionId n8 n24) src dst req -> | ||
238 | -- :: tid -> addr -> addr -> a -> OnionMessage Identity | ||
239 | OnionAnnounce $ Asymm | ||
240 | { -- The public key is our real long term public key if we want to | ||
241 | -- announce ourselves, a temporary one if we are searching for | ||
242 | -- friends. | ||
243 | senderKey = onionKey src | ||
244 | , asymmNonce = n24 | ||
245 | , asymmData = Identity (req, n8) | ||
246 | } | ||
247 | , unwrapResponse = \case -- :: OnionMessage Identity -> b | ||
248 | OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp | ||
249 | _ -> Nothing | ||
250 | } | ||
251 | |||
252 | unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32) | ||
253 | unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns)) | ||
254 | = case is_stored of | ||
255 | NotStored n32 -> ( ns , [] , Just n32) | ||
256 | SendBackKey k -> ( ns , [Rendezvous k ni] , Nothing ) | ||
257 | Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32) | ||
258 | |||
259 | -- TODO Announce key to announce peers. | ||
260 | -- | ||
261 | -- Announce Peers are only put in the 8 closest peers array if they respond | ||
262 | -- to an announce request. If the peers fail to respond to 3 announce | ||
263 | -- requests they are deemed timed out and removed. | ||
264 | -- | ||
265 | -- ... | ||
266 | -- | ||
267 | -- For this reason, after the peer is announced successfully for 17 seconds, | ||
268 | -- announce packets are sent aggressively every 3 seconds to each known close | ||
269 | -- peer (in the list of 8 peers) to search aggressively for peers that know | ||
270 | -- the peer we are searching for. | ||
271 | |||
272 | -- TODO | ||
273 | -- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will | ||
274 | -- aggressively reannounce itself and search for friends as if it was just | ||
275 | -- started. | ||
276 | |||
277 | |||
278 | sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
279 | -> Client r | ||
280 | -> AnnounceRequest | ||
281 | -> OnionDestination r | ||
282 | -> (NodeInfo -> AnnounceResponse -> t) | ||
283 | -> IO (Maybe t) | ||
284 | sendOnion getTimeout client req oaddr unwrap = | ||
285 | -- Four tries and then we tap out. | ||
286 | flip fix 4 $ \loop n -> do | ||
287 | mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr | ||
288 | forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r | ||
289 | maybe (if n>0 then loop $! n - 1 else return Nothing) | ||
290 | (return . Just . unwrap (onionNodeInfo oaddr)) | ||
291 | $ join mb | ||
292 | |||
293 | asyncOnion :: (TransactionId | ||
294 | -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
295 | -> QR.Client | ||
296 | err | ||
297 | PacketKind | ||
298 | TransactionId | ||
299 | (OnionDestination r) | ||
300 | (OnionMessage Identity) | ||
301 | -> AnnounceRequest | ||
302 | -> OnionDestination r | ||
303 | -> (NodeInfo -> AnnounceResponse -> a) | ||
304 | -> (Maybe a -> IO ()) | ||
305 | -> IO () | ||
306 | asyncOnion getTimeout client req oaddr unwrap go = | ||
307 | -- Four tries and then we tap out. | ||
308 | flip fix 4 $ \loop n -> do | ||
309 | QR.asyncQuery client (announceSerializer getTimeout) req oaddr | ||
310 | $ \mb -> do | ||
311 | forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r | ||
312 | maybe (if n>0 then loop $! n - 1 else go Nothing) | ||
313 | (go . Just . unwrap (onionNodeInfo oaddr)) | ||
314 | $ join mb | ||
315 | |||
316 | |||
317 | -- | Lookup the secret counterpart for a given alias key. | ||
318 | getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
319 | -> TransportCrypto | ||
320 | -> Client r | ||
321 | -> NodeId | ||
322 | -> NodeInfo | ||
323 | -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32)) | ||
324 | getRendezvous getTimeout crypto client nid ni = do | ||
325 | asel <- atomically $ selectAlias crypto nid | ||
326 | let oaddr = OnionDestination asel ni Nothing | ||
327 | rkey = case asel of | ||
328 | SearchingAlias -> Nothing | ||
329 | _ -> Just $ key2id $ rendezvousPublic crypto | ||
330 | sendOnion getTimeout client | ||
331 | (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey) | ||
332 | oaddr | ||
333 | (unwrapAnnounceResponse rkey) | ||
334 | |||
335 | asyncGetRendezvous | ||
336 | :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
337 | -> TransportCrypto | ||
338 | -> Client r | ||
339 | -> NodeId | ||
340 | -> NodeInfo | ||
341 | -> (Maybe ([NodeInfo], [Rendezvous], Maybe Nonce32) -> IO ()) | ||
342 | -> IO () | ||
343 | asyncGetRendezvous getTimeout crypto client nid ni go = do | ||
344 | asel <- atomically $ selectAlias crypto nid | ||
345 | let oaddr = OnionDestination asel ni Nothing | ||
346 | rkey = case asel of | ||
347 | SearchingAlias -> Nothing | ||
348 | _ -> Just $ key2id $ rendezvousPublic crypto | ||
349 | asyncOnion getTimeout client | ||
350 | (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey) | ||
351 | oaddr | ||
352 | (unwrapAnnounceResponse rkey) | ||
353 | go | ||
354 | |||
355 | putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
356 | -> TransportCrypto | ||
357 | -> Client r | ||
358 | -> PublicKey | ||
359 | -> Nonce32 | ||
360 | -> NodeInfo | ||
361 | -> IO (Maybe (Rendezvous, AnnounceResponse)) | ||
362 | putRendezvous getTimeout crypto client pubkey nonce32 ni = do | ||
363 | let longTermKey = key2id pubkey | ||
364 | rkey = rendezvousPublic crypto | ||
365 | rendezvousKey = key2id rkey | ||
366 | asel <- atomically $ selectAlias crypto longTermKey | ||
367 | let oaddr = OnionDestination asel ni Nothing | ||
368 | sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr | ||
369 | $ \ni resp -> (Rendezvous rkey ni, resp) | ||
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs deleted file mode 100644 index e746c414..00000000 --- a/src/Network/Tox/Onion/Transport.hs +++ /dev/null | |||
@@ -1,119 +0,0 @@ | |||
1 | module Network.Tox.Onion.Transport | ||
2 | ( parseOnionAddr | ||
3 | , encodeOnionAddr | ||
4 | , parseDataToRoute | ||
5 | , encodeDataToRoute | ||
6 | , forwardOnions | ||
7 | , AliasSelector(..) | ||
8 | , OnionDestination(..) | ||
9 | , OnionMessage(..) | ||
10 | , Rendezvous(..) | ||
11 | , DataToRoute(..) | ||
12 | , OnionData(..) | ||
13 | , AnnouncedRendezvous(..) | ||
14 | , AnnounceResponse(..) | ||
15 | , AnnounceRequest(..) | ||
16 | , Forwarding(..) | ||
17 | , ReturnPath(..) | ||
18 | , OnionRequest(..) | ||
19 | , OnionResponse(..) | ||
20 | , Addressed(..) | ||
21 | , UDPTransport | ||
22 | , KeyRecord(..) | ||
23 | , encrypt | ||
24 | , decrypt | ||
25 | , peelSymmetric | ||
26 | , OnionRoute(..) | ||
27 | , N0 | ||
28 | , N1 | ||
29 | , N2 | ||
30 | , N3 | ||
31 | , onionKey | ||
32 | , onionAliasSelector | ||
33 | , selectAlias | ||
34 | , RouteId(..) | ||
35 | , routeId | ||
36 | , putRequest | ||
37 | , wrapForRoute | ||
38 | , wrapSymmetric | ||
39 | , wrapOnion | ||
40 | , wrapOnionPure | ||
41 | ) where | ||
42 | |||
43 | import Data.ByteString (ByteString) | ||
44 | import Data.Serialize | ||
45 | import Network.Socket | ||
46 | |||
47 | import Crypto.Tox hiding (encrypt,decrypt) | ||
48 | import qualified Data.Tox.Relay as TCP | ||
49 | import Data.Tox.Onion | ||
50 | import Network.Tox.NodeId | ||
51 | |||
52 | {- | ||
53 | encodeOnionAddr :: TransportCrypto | ||
54 | -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) | ||
55 | -> (OnionMessage Encrypted,OnionDestination RouteId) | ||
56 | -> IO (Maybe (ByteString, SockAddr)) | ||
57 | -} | ||
58 | encodeOnionAddr :: TransportCrypto | ||
59 | -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) | ||
60 | -> (OnionMessage Encrypted, OnionDestination RouteId) | ||
61 | -> IO (Maybe | ||
62 | (Either (TCP.RelayPacket, TCP.NodeInfo) (ByteString, SockAddr))) | ||
63 | encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = | ||
64 | return $ Just $ Right ( runPut $ putResponse (OnionResponse p msg) | ||
65 | , nodeAddr ni ) | ||
66 | encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do | ||
67 | encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) | ||
68 | -- dput XMisc $ "ONION encode missing routeid" | ||
69 | -- return Nothing | ||
70 | encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do | ||
71 | let go route = do | ||
72 | mreq <- wrapForRoute crypto msg ni route | ||
73 | case mreq of | ||
74 | Right req -> return $ Right ( runPut $ putRequest req , nodeAddr $ routeNodeA route) | ||
75 | Left o | Just port <- routeRelayPort route | ||
76 | -> return $ Left ( o, TCP.NodeInfo (routeNodeA route) port) | ||
77 | m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid | ||
78 | x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m | ||
79 | return x | ||
80 | |||
81 | -- wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0) | ||
82 | wrapForRoute :: TransportCrypto | ||
83 | -> OnionMessage Encrypted | ||
84 | -> NodeInfo | ||
85 | -> OnionRoute | ||
86 | -> IO (Either TCP.RelayPacket (OnionRequest N0)) | ||
87 | wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort=Nothing} = do | ||
88 | -- We needn't use the same nonce value here, but I think it is safe to do so. | ||
89 | let nonce = msgNonce msg | ||
90 | fwd <- wrapOnion crypto (routeAliasA r) | ||
91 | nonce | ||
92 | (id2key . nodeId $ routeNodeA r) | ||
93 | (nodeAddr $ routeNodeB r) | ||
94 | =<< wrapOnion crypto (routeAliasB r) | ||
95 | nonce | ||
96 | (id2key . nodeId $ routeNodeB r) | ||
97 | (nodeAddr $ routeNodeC r) | ||
98 | =<< wrapOnion crypto (routeAliasC r) | ||
99 | nonce | ||
100 | (id2key . nodeId $ routeNodeC r) | ||
101 | (nodeAddr ni) | ||
102 | (NotForwarded msg) | ||
103 | return $ Right OnionRequest | ||
104 | { onionNonce = nonce | ||
105 | , onionForward = fwd | ||
106 | , pathFromOwner = NoReturnPath | ||
107 | } | ||
108 | wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort = Just tcpport} = do | ||
109 | let nonce = msgNonce msg | ||
110 | fwd <- wrapOnion crypto (routeAliasB r) | ||
111 | nonce | ||
112 | (id2key . nodeId $ routeNodeB r) | ||
113 | (nodeAddr $ routeNodeC r) | ||
114 | =<< wrapOnion crypto (routeAliasC r) | ||
115 | nonce | ||
116 | (id2key . nodeId $ routeNodeC r) | ||
117 | (nodeAddr ni) | ||
118 | (NotForwarded msg) | ||
119 | return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd | ||
diff --git a/src/Network/Tox/Relay.hs b/src/Network/Tox/Relay.hs deleted file mode 100644 index 2842fcc2..00000000 --- a/src/Network/Tox/Relay.hs +++ /dev/null | |||
@@ -1,235 +0,0 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | ||
2 | {-# LANGUAGE RecordWildCards #-} | ||
3 | {-# LANGUAGE ScopedTypeVariables #-} | ||
4 | module Network.Tox.Relay (tcpRelay) where | ||
5 | |||
6 | import Control.Concurrent.MVar | ||
7 | import Control.Concurrent.STM | ||
8 | import Control.Exception | ||
9 | import Control.Monad | ||
10 | import qualified Data.ByteString as B | ||
11 | import Data.Function | ||
12 | import Data.Functor.Identity | ||
13 | import qualified Data.IntMap as IntMap | ||
14 | ;import Data.IntMap (IntMap) | ||
15 | import qualified Data.Map as Map | ||
16 | ;import Data.Map (Map) | ||
17 | import Data.Serialize | ||
18 | import Data.Word | ||
19 | import Network.Socket (SockAddr) | ||
20 | import System.IO | ||
21 | import System.IO.Error | ||
22 | import System.Timeout | ||
23 | |||
24 | import Crypto.Tox | ||
25 | import qualified Data.IntervalSet as IntSet | ||
26 | ;import Data.IntervalSet (IntSet) | ||
27 | import Data.Tox.Relay | ||
28 | import Network.Address (getBindAddress) | ||
29 | import Network.SocketLike | ||
30 | import Network.StreamServer | ||
31 | import Network.Tox.Onion.Transport hiding (encrypt,decrypt) | ||
32 | |||
33 | |||
34 | |||
35 | hGetPrefixed :: Serialize a => Handle -> IO (Either String a) | ||
36 | hGetPrefixed h = do | ||
37 | mlen <- runGet getWord16be <$> B.hGet h 2 | ||
38 | -- We treat parse-fail the same as EOF. | ||
39 | fmap join $ forM mlen $ \len -> runGet get <$> B.hGet h (fromIntegral len) | ||
40 | |||
41 | hGetSized :: forall x. (Sized x, Serialize x) => Handle -> IO (Either String x) | ||
42 | hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF. | ||
43 | where | ||
44 | ConstSize len = size :: Size x | ||
45 | |||
46 | data RelaySession = RelaySession | ||
47 | { indexPool :: IntSet -- ^ Ints that are either solicited or associated. | ||
48 | , solicited :: Map PublicKey Int -- ^ Reserved ids, not yet in associated. | ||
49 | , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to. | ||
50 | } | ||
51 | |||
52 | freshSession :: RelaySession | ||
53 | freshSession = RelaySession | ||
54 | { indexPool = IntSet.empty | ||
55 | , solicited = Map.empty | ||
56 | , associated = IntMap.empty | ||
57 | } | ||
58 | |||
59 | disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession)) | ||
60 | -> PublicKey | ||
61 | -> IO () | ||
62 | disconnect cons who = join $ atomically $ do | ||
63 | Map.lookup who <$> readTVar cons | ||
64 | >>= \case | ||
65 | Nothing -> return $ return () | ||
66 | Just (_,session) -> do | ||
67 | modifyTVar' cons $ Map.delete who | ||
68 | RelaySession { associated = cs } <- readTVar session | ||
69 | return $ let notifyPeer i send = ((send DisconnectNotification) >>) | ||
70 | in IntMap.foldrWithKey notifyPeer (return ()) cs | ||
71 | |||
72 | relaySession :: TransportCrypto | ||
73 | -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession)) | ||
74 | -> (SockAddr -> OnionRequest N1 -> IO ()) | ||
75 | -> sock | ||
76 | -> Int | ||
77 | -> Handle | ||
78 | -> IO () | ||
79 | relaySession crypto cons sendOnion _ conid h = do | ||
80 | -- atomically $ modifyTVar' cons $ IntMap.insert conid h | ||
81 | |||
82 | -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h | ||
83 | |||
84 | (hGetSized h >>=) $ mapM_ $ \helloE -> do | ||
85 | |||
86 | let me = transportSecret crypto | ||
87 | them = helloFrom helloE | ||
88 | |||
89 | noncef <- lookupNonceFunction crypto me them | ||
90 | let mhello = decryptPayload (noncef $ helloNonce helloE) helloE | ||
91 | forM_ mhello $ \hello -> do | ||
92 | let _ = hello :: Hello Identity | ||
93 | |||
94 | (me',welcome) <- atomically $ do | ||
95 | skey <- transportNewKey crypto | ||
96 | dta <- HelloData (toPublic skey) <$> transportNewNonce crypto | ||
97 | w24 <- transportNewNonce crypto | ||
98 | return (skey, Welcome w24 $ pure dta) | ||
99 | |||
100 | B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome | ||
101 | |||
102 | noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello) | ||
103 | in lookupNonceFunction crypto me' them' | ||
104 | |||
105 | let readPacket n24 = (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h | ||
106 | base = sessionBaseNonce $ runIdentity $ helloData hello | ||
107 | |||
108 | -- You get 3 seconds to send a session packet. | ||
109 | mpkt0 <- join <$> timeout 3000000 (either (const Nothing) Just <$> readPacket base) | ||
110 | forM_ mpkt0 $ \pkt0 -> do | ||
111 | |||
112 | disconnect cons (helloFrom hello) | ||
113 | (sendPacket,session) <- do | ||
114 | session <- atomically $ newTVar freshSession | ||
115 | sendPacket <- do | ||
116 | v <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome) | ||
117 | return $ \p -> do | ||
118 | case p of | ||
119 | DisconnectNotification con -> atomically $ do | ||
120 | modifyTVar' session $ \s -> s | ||
121 | { indexPool = maybe id IntSet.delete (c2key con) (indexPool s) | ||
122 | , associated = maybe id IntMap.delete (c2key con) (associated s) | ||
123 | } | ||
124 | _ -> return () | ||
125 | n24 <- takeMVar v | ||
126 | let bs = encode $ encrypt (noncef' n24) $ encodePlain (p :: RelayPacket) | ||
127 | do B.hPut h $ encode (fromIntegral (B.length bs) :: Word16) | ||
128 | B.hPut h bs | ||
129 | `catchIOError` \_ -> return () | ||
130 | putMVar v (incrementNonce24 n24) | ||
131 | atomically $ modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session) | ||
132 | return (sendPacket,session) | ||
133 | |||
134 | handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0 | ||
135 | |||
136 | flip fix (incrementNonce24 base) $ \loop n24 -> do | ||
137 | m <- readPacket n24 | ||
138 | forM_ m $ \p -> do | ||
139 | handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p | ||
140 | loop (incrementNonce24 n24) | ||
141 | `finally` | ||
142 | disconnect cons (helloFrom hello) | ||
143 | |||
144 | handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession)) | ||
145 | -> Int | ||
146 | -> PublicKey | ||
147 | -> TransportCrypto | ||
148 | -> (SockAddr -> OnionRequest N1 -> IO ()) | ||
149 | -> (RelayPacket -> IO ()) | ||
150 | -> TVar RelaySession | ||
151 | -> RelayPacket | ||
152 | -> IO () | ||
153 | handlePacket cons thistcp me crypto sendOnion sendToMe session = \case | ||
154 | RoutingRequest them -> join $ atomically $ do | ||
155 | mySession <- readTVar session | ||
156 | mi <- case Map.lookup them (solicited mySession) of | ||
157 | Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do | ||
158 | if -120 <= i && i <= 119 | ||
159 | then do | ||
160 | writeTVar session mySession | ||
161 | { indexPool = IntSet.insert i (indexPool mySession) | ||
162 | , solicited = Map.insert them i (solicited mySession) | ||
163 | } | ||
164 | return $ Just i | ||
165 | else return Nothing -- No more slots available. | ||
166 | Just i -> return $ Just i | ||
167 | notifyConnect <- fmap (join . join) $ forM mi $ \i -> do | ||
168 | mp <- Map.lookup them <$> readTVar cons | ||
169 | forM mp $ \(sendToThem,peer) -> do | ||
170 | theirSession <- readTVar peer | ||
171 | forM (Map.lookup me $ solicited theirSession) $ \reserved_id -> do | ||
172 | let sendToThem' f = sendToThem $ f $ key2c reserved_id | ||
173 | sendToMe' f = sendToMe $ f $ key2c i | ||
174 | writeTVar peer theirSession | ||
175 | { solicited = Map.delete me (solicited theirSession) | ||
176 | , associated = IntMap.insert reserved_id sendToMe' (associated theirSession) | ||
177 | } | ||
178 | writeTVar session mySession | ||
179 | { solicited = Map.delete them (solicited mySession) | ||
180 | , associated = IntMap.insert i sendToThem' (associated mySession) | ||
181 | } | ||
182 | return $ do sendToThem' ConnectNotification | ||
183 | sendToMe' ConnectNotification | ||
184 | return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them | ||
185 | sequence_ notifyConnect | ||
186 | |||
187 | RelayPing x -> sendToMe $ RelayPong x -- TODO x==0 is invalid. Do we care? | ||
188 | |||
189 | OOBSend them bs -> do | ||
190 | m <- atomically $ Map.lookup them <$> readTVar cons | ||
191 | forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs | ||
192 | |||
193 | RelayData bs con -> join $ atomically $ do | ||
194 | -- Data: Data packets can only be sent and received if the | ||
195 | -- corresponding connection_id is connection (a Connect notification | ||
196 | -- has been received from it) if the server receives a Data packet for | ||
197 | -- a non connected or existent connection it will discard it. | ||
198 | mySession <- readTVar session | ||
199 | return $ sequence_ $ do | ||
200 | i <- c2key con | ||
201 | sendToThem' <- IntMap.lookup i $ associated mySession | ||
202 | return $ sendToThem' $ RelayData bs | ||
203 | |||
204 | OnionPacket n24 (Addressed addr req) -> do | ||
205 | rpath <- atomically $ do | ||
206 | sym <- transportSymmetric crypto | ||
207 | n <- transportNewNonce crypto | ||
208 | return $ wrapSymmetric sym n (TCPIndex thistcp) NoReturnPath | ||
209 | sendOnion addr $ OnionRequest n24 req rpath | ||
210 | |||
211 | _ -> return () | ||
212 | |||
213 | |||
214 | sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionMessage Encrypted -> IO () | ||
215 | sendTCP_ st addr x = join $ atomically | ||
216 | $ IntMap.lookup addr <$> readTVar st >>= \case | ||
217 | Nothing -> return $ return () | ||
218 | Just send -> return $ send $ OnionPacketResponse x | ||
219 | |||
220 | tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ()) | ||
221 | tcpRelay udp_addr sendOnion = do | ||
222 | crypto <- newCrypto | ||
223 | cons <- newTVarIO Map.empty | ||
224 | clients <- newTVarIO IntMap.empty | ||
225 | b443 <- getBindAddress "443" True | ||
226 | b80 <- getBindAddress "80" True | ||
227 | b33445 <- getBindAddress "33445" True | ||
228 | bany <- getBindAddress "" True | ||
229 | h <- streamServer ServerConfig | ||
230 | { serverWarn = hPutStrLn stderr | ||
231 | , serverSession = relaySession crypto cons sendOnion | ||
232 | } | ||
233 | [b443,b80,udp_addr,b33445,bany] | ||
234 | return (h,sendTCP_ clients) | ||
235 | |||
diff --git a/src/Network/Tox/Session.hs b/src/Network/Tox/Session.hs deleted file mode 100644 index 189967fa..00000000 --- a/src/Network/Tox/Session.hs +++ /dev/null | |||
@@ -1,243 +0,0 @@ | |||
1 | -- | This module implements the lossless Tox session protocol. | ||
2 | {-# LANGUAGE TupleSections #-} | ||
3 | module Network.Tox.Session | ||
4 | ( SessionParams(..) | ||
5 | , SessionKey | ||
6 | , Session(..) | ||
7 | , sTheirUserKey | ||
8 | , sClose | ||
9 | , handshakeH | ||
10 | ) where | ||
11 | |||
12 | import Control.Concurrent.STM | ||
13 | import Control.Monad | ||
14 | import Control.Exception | ||
15 | import Data.Dependent.Sum | ||
16 | import Data.Functor.Identity | ||
17 | import Data.Word | ||
18 | import Network.Socket (SockAddr) | ||
19 | |||
20 | import Crypto.Tox | ||
21 | import Data.PacketBuffer (PacketInboundEvent (..)) | ||
22 | import Data.Tox.Msg | ||
23 | import DPut | ||
24 | import DebugTag | ||
25 | import Network.Lossless | ||
26 | import Network.QueryResponse | ||
27 | import Network.SessionTransports | ||
28 | import Network.Tox.Crypto.Transport | ||
29 | import Network.Tox.DHT.Transport (Cookie (..), key2id, longTermKey) | ||
30 | import Network.Tox.Handshake | ||
31 | |||
32 | -- | Alias for 'SecretKey' to document that it is used as the temporary Tox | ||
33 | -- session key corresponding to the 'PublicKey' we sent in the handshake. | ||
34 | type SessionKey = SecretKey | ||
35 | |||
36 | -- | These inputs to 'handshakeH' indicate how to respond to handshakes, how to | ||
37 | -- assign packets to sessions, and what to do with established sessions after | ||
38 | -- they are made lossless by queuing packets and appending sequence numbers. | ||
39 | data SessionParams = SessionParams | ||
40 | { -- | The database of secret keys necessary to encrypt handshake packets. | ||
41 | spCrypto :: TransportCrypto | ||
42 | -- | This is used to create sessions and dispatch packets to them. | ||
43 | , spSessions :: Sessions (CryptoPacket Encrypted) | ||
44 | -- | This method returns the session information corresponding to the | ||
45 | -- cookie pair for the remote address. If no handshake was sent, this | ||
46 | -- should send one immediately. It should return 'Nothing' if anything | ||
47 | -- goes wrong. | ||
48 | , spGetSentHandshake :: SecretKey -> SockAddr | ||
49 | -> Cookie Identity | ||
50 | -> Cookie Encrypted | ||
51 | -> IO (Maybe (SessionKey, HandshakeData)) | ||
52 | -- | This method is invoked on each new session and is responsible for | ||
53 | -- launching any threads necessary to keep the session alive. | ||
54 | , spOnNewSession :: Session -> IO () | ||
55 | } | ||
56 | |||
57 | -- | After a session is established, this information is given to the | ||
58 | -- 'spOnNewSession' callback. | ||
59 | data Session = Session | ||
60 | { -- | This is the secret user (toxid) key that corresponds to the | ||
61 | -- local-end of this session. | ||
62 | sOurKey :: SecretKey | ||
63 | -- | The remote address for this session. (Not unique, see 'sSessionID'). | ||
64 | , sTheirAddr :: SockAddr | ||
65 | -- | The information we sent in the handshake for this session. | ||
66 | , sSentHandshake :: HandshakeData | ||
67 | -- | The information we received in a handshake for this session. | ||
68 | , sReceivedHandshake :: Handshake Identity | ||
69 | -- | This method can be used to trigger packets to be re-sent given a | ||
70 | -- list of their sequence numbers. It should be used when the remote end | ||
71 | -- indicates they lost packets. | ||
72 | , sResendPackets :: [Word32] -> IO () | ||
73 | -- | This list of sequence numbers should be periodically polled and if | ||
74 | -- it is not empty, we should request they re-send these packets. For | ||
75 | -- convenience, a lower bound for the numbers in the list is also | ||
76 | -- returned. Suggested polling interval: a few seconds. | ||
77 | , sMissingInbound :: IO ([Word32],Word32) | ||
78 | -- | A lossless transport for sending and receiving packets in this | ||
79 | -- session. It is up to the caller to spawn the await-loop to handle | ||
80 | -- inbound packets. | ||
81 | , sTransport :: Transport String () CryptoMessage | ||
82 | -- | A unique small integer that identifies this session for as long as | ||
83 | -- it is established. | ||
84 | , sSessionID :: Int | ||
85 | } | ||
86 | |||
87 | -- | Helper to obtain the remote ToxID key from the locally-issued cookie | ||
88 | -- associated with the session. | ||
89 | sTheirUserKey :: Session -> PublicKey | ||
90 | sTheirUserKey s = longTermKey $ runIdentity cookie | ||
91 | where | ||
92 | Cookie _ cookie = handshakeCookie (sReceivedHandshake s) | ||
93 | |||
94 | -- | Helper to close the 'Transport' associated with a session. | ||
95 | sClose :: Session -> IO () | ||
96 | sClose s = closeTransport (sTransport s) | ||
97 | |||
98 | |||
99 | -- | Call this whenever a new handshake arrives so that a session is | ||
100 | -- negotiated. It always returns Nothing which makes it convenient to use with | ||
101 | -- 'Network.QueryResponse.addHandler'. | ||
102 | handshakeH :: SessionParams | ||
103 | -> SockAddr | ||
104 | -> Handshake Encrypted | ||
105 | -> IO (Maybe a) | ||
106 | handshakeH sp saddr handshake = do | ||
107 | decryptHandshake (spCrypto sp) handshake | ||
108 | >>= either (\err -> return ()) | ||
109 | (uncurry $ plainHandshakeH sp saddr) | ||
110 | return Nothing | ||
111 | |||
112 | |||
113 | plainHandshakeH :: SessionParams | ||
114 | -> SockAddr | ||
115 | -> SecretKey | ||
116 | -> Handshake Identity | ||
117 | -> IO () | ||
118 | plainHandshakeH sp saddr skey handshake = do | ||
119 | let hd = runIdentity $ handshakeData handshake | ||
120 | prelude = show saddr ++ " --> " | ||
121 | dput XNetCrypto $ unlines $ map (prelude ++) | ||
122 | [ "handshake: auth=" ++ show (handshakeCookie handshake) | ||
123 | , " : issuing=" ++ show (otherCookie hd) | ||
124 | , " : baseNonce=" ++ show (baseNonce hd) | ||
125 | ] | ||
126 | sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd) | ||
127 | -- TODO: this is always returning sent = Nothing | ||
128 | dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd) sent) | ||
129 | forM_ sent $ \(hd_skey,hd_sent) -> do | ||
130 | sk <- SessionKeys (spCrypto sp) | ||
131 | hd_skey | ||
132 | (sessionKey hd) | ||
133 | <$> atomically (newTVar $ baseNonce hd) | ||
134 | <*> atomically (newTVar $ baseNonce hd_sent) | ||
135 | m <- newSession (spSessions sp) (\() p -> return p) (decryptPacket sk) saddr | ||
136 | dput XNetCrypto $ prelude ++ "plainHandshakeH: session " ++ maybe "Nothing" (const "Just") m | ||
137 | forM_ m $ \(sid, t) -> do | ||
138 | (t2,resend,getMissing) | ||
139 | <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp) | ||
140 | (\seqno p@(Pkt m :=> _) _ -> do | ||
141 | y <- encryptPacket sk $ bookKeeping seqno p | ||
142 | return OutgoingInfo | ||
143 | { oIsLossy = lossyness m == Lossy | ||
144 | , oEncoded = y | ||
145 | , oHandleException = Just $ \e -> do | ||
146 | dput XUnexpected $ unlines | ||
147 | [ "<-- " ++ show e | ||
148 | , "<-- while sending " ++ show (seqno,p) ] | ||
149 | throwIO e | ||
150 | }) | ||
151 | () | ||
152 | t | ||
153 | let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted) | ||
154 | _ = t2 :: Transport String () CryptoMessage | ||
155 | sendMessage t2 () $ (Pkt ONLINE ==> ()) | ||
156 | spOnNewSession sp Session | ||
157 | { sOurKey = skey | ||
158 | , sTheirAddr = saddr | ||
159 | , sSentHandshake = hd_sent | ||
160 | , sReceivedHandshake = handshake | ||
161 | , sResendPackets = resend | ||
162 | , sMissingInbound = getMissing | ||
163 | , sTransport = t2 | ||
164 | , sSessionID = sid | ||
165 | } | ||
166 | return () | ||
167 | |||
168 | |||
169 | -- | The per-session nonce and key state maintained by 'decryptPacket' and | ||
170 | -- 'encryptPacket'. | ||
171 | data SessionKeys = SessionKeys | ||
172 | { skCrypto :: TransportCrypto -- ^ Cache of shared-secrets. | ||
173 | , skMe :: SessionKey -- ^ My session key | ||
174 | , skThem :: PublicKey -- ^ Their session key | ||
175 | , skNonceIncoming :: TVar Nonce24 -- ^ +21845 when a threshold is reached. | ||
176 | , skNonceOutgoing :: TVar Nonce24 -- ^ +1 on every packet | ||
177 | } | ||
178 | |||
179 | -- | Decrypt an inbound session packet and update the nonce for the next one. | ||
180 | decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ())) | ||
181 | decryptPacket sk saddr (CryptoPacket n16 ciphered) = do | ||
182 | (n24,δ) <- atomically $ do | ||
183 | n <- readTVar (skNonceIncoming sk) | ||
184 | let δ = n16 - nonce24ToWord16 n | ||
185 | return ( n `addtoNonce24` fromIntegral δ, δ ) | ||
186 | secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 | ||
187 | case decodePlain =<< decrypt secret ciphered of | ||
188 | Left e -> return Nothing | ||
189 | Right x -> do | ||
190 | when ( δ > 43690 ) | ||
191 | $ atomically $ writeTVar (skNonceIncoming sk) (n24 `addtoNonce24` 21845) | ||
192 | |||
193 | do let them = key2id $ skThem sk | ||
194 | CryptoData ack seqno _ = x | ||
195 | cm = decodeRawCryptoMsg x | ||
196 | dput XNetCrypto $ unwords [take 8 (show them),"-->",show (msgID cm),show (n24,ack,seqno)] | ||
197 | |||
198 | return $ Just ( CryptoPacket n16 (pure x), () ) | ||
199 | |||
200 | -- | Encrypt an outbound session packet and update the nonce for the next one. | ||
201 | encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted) | ||
202 | encryptPacket sk plain = do | ||
203 | n24 <- atomically $ do | ||
204 | n24 <- readTVar (skNonceOutgoing sk) | ||
205 | modifyTVar' (skNonceOutgoing sk) incrementNonce24 | ||
206 | return n24 | ||
207 | secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 | ||
208 | let ciphered = encrypt secret $ encodePlain $ plain | ||
209 | |||
210 | do let them = key2id $ skThem sk | ||
211 | CryptoData ack seqno cm = plain | ||
212 | dput XNetCrypto $ unwords [take 8 (show them),"<--",show (msgID cm),show (n24,ack,seqno)] | ||
213 | |||
214 | return $ CryptoPacket (nonce24ToWord16 n24) ciphered | ||
215 | |||
216 | |||
217 | -- | Add sequence information to an outbound packet. | ||
218 | -- | ||
219 | -- From spec.md: | ||
220 | -- | ||
221 | -- Data in the encrypted packets: | ||
222 | -- | ||
223 | -- [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)] | ||
224 | -- [uint32_t packet number if lossless, sendbuffer buffer_end if lossy, (big endian)] | ||
225 | -- [data] | ||
226 | bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData | ||
227 | bookKeeping (SequenceInfo seqno ack) m = CryptoData | ||
228 | { bufferStart = ack :: Word32 | ||
229 | , bufferEnd = seqno :: Word32 | ||
230 | , bufferData = m | ||
231 | } | ||
232 | |||
233 | -- | Classify an inbound packet as lossy or lossless based on its id byte. | ||
234 | checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage | ||
235 | checkLossless cd@CryptoData{ bufferStart = ack | ||
236 | , bufferEnd = no | ||
237 | , bufferData = x } = tag no x' ack | ||
238 | where | ||
239 | x' = decodeRawCryptoMsg cd | ||
240 | tag = case someLossyness (msgID x') of Lossy -> PacketReceivedLossy | ||
241 | _ -> PacketReceived | ||
242 | |||
243 | |||
diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs deleted file mode 100644 index 13da804f..00000000 --- a/src/Network/Tox/TCP.hs +++ /dev/null | |||
@@ -1,313 +0,0 @@ | |||
1 | {-# LANGUAGE RecursiveDo #-} | ||
2 | {-# LANGUAGE PartialTypeSignatures #-} | ||
3 | {-# LANGUAGE LambdaCase #-} | ||
4 | {-# LANGUAGE FlexibleContexts #-} | ||
5 | module Network.Tox.TCP | ||
6 | ( module Network.Tox.TCP | ||
7 | , NodeInfo(..) | ||
8 | ) where | ||
9 | |||
10 | import Debug.Trace | ||
11 | import Control.Arrow | ||
12 | import Control.Concurrent | ||
13 | import Control.Concurrent.STM | ||
14 | import Control.Exception | ||
15 | import Control.Monad | ||
16 | import Crypto.Random | ||
17 | import Data.Aeson (ToJSON(..),FromJSON(..)) | ||
18 | import qualified Data.Aeson as JSON | ||
19 | import Data.Functor.Contravariant | ||
20 | import Data.Functor.Identity | ||
21 | import Data.Hashable | ||
22 | import qualified Data.HashMap.Strict as HashMap | ||
23 | import Data.IP | ||
24 | import Data.Maybe | ||
25 | import Data.Monoid | ||
26 | import Data.Serialize | ||
27 | import Data.Word | ||
28 | import qualified Data.Vector as Vector | ||
29 | import Network.Socket (SockAddr(..)) | ||
30 | import qualified Text.ParserCombinators.ReadP as RP | ||
31 | import System.IO.Error | ||
32 | import System.Timeout | ||
33 | |||
34 | import ControlMaybe | ||
35 | import Crypto.Tox | ||
36 | import Data.ByteString (hPut,hGet,ByteString,length) | ||
37 | import Data.TableMethods | ||
38 | import Data.Tox.Relay | ||
39 | import qualified Data.Word64Map | ||
40 | import DebugTag | ||
41 | import DPut | ||
42 | import Network.Address (setPort,PortNumber,localhost4,fromSockAddr) | ||
43 | import Network.Kademlia.Routing | ||
44 | import Network.Kademlia.Search hiding (sendQuery) | ||
45 | import Network.QueryResponse | ||
46 | import Network.QueryResponse.TCP | ||
47 | import Network.Tox.DHT.Handlers (toxSpace) | ||
48 | import Network.Tox.Onion.Transport hiding (encrypt,decrypt) | ||
49 | import Network.Tox.Onion.Handlers (unwrapAnnounceResponse) | ||
50 | import qualified Network.Tox.NodeId as UDP | ||
51 | |||
52 | |||
53 | withSize :: Sized x => (Size x -> m (p x)) -> m (p x) | ||
54 | withSize f = case size of len -> f len | ||
55 | |||
56 | |||
57 | type NodeId = UDP.NodeId | ||
58 | |||
59 | -- example: | ||
60 | -- KEyW2Bm.S-DpIGp72380BAfgintUWX1KX.6ZU.4m5Ex@80.99.99.99:33400{tcp:443} | ||
61 | instance Show NodeInfo where | ||
62 | show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}" | ||
63 | |||
64 | nodeId :: NodeInfo -> NodeId | ||
65 | nodeId ni = UDP.nodeId $ udpNodeInfo ni | ||
66 | |||
67 | nodeAddr :: NodeInfo -> SockAddr | ||
68 | nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni | ||
69 | |||
70 | nodeIP :: NodeInfo -> IP | ||
71 | nodeIP ni = UDP.nodeIP $ udpNodeInfo ni | ||
72 | |||
73 | tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) => | ||
74 | TransportCrypto -> StreamHandshake NodeInfo x y | ||
75 | tcpStream crypto = StreamHandshake | ||
76 | { streamHello = \addr h -> do | ||
77 | (skey, hello) <- atomically $ do | ||
78 | n24 <- transportNewNonce crypto | ||
79 | skey <- transportNewKey crypto | ||
80 | base24 <- transportNewNonce crypto | ||
81 | return $ (,) skey $ Hello $ Asymm | ||
82 | { senderKey = transportPublic crypto | ||
83 | , asymmNonce = n24 | ||
84 | , asymmData = pure HelloData | ||
85 | { sessionPublicKey = toPublic $ skey | ||
86 | , sessionBaseNonce = base24 | ||
87 | } | ||
88 | } | ||
89 | noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr) | ||
90 | dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello | ||
91 | hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello | ||
92 | welcomeE <- withSize $ fmap decode . hGet h . constSize | ||
93 | let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w | ||
94 | nil = SessionProtocol | ||
95 | { streamGoodbye = return () | ||
96 | , streamDecode = return Nothing | ||
97 | , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y | ||
98 | } | ||
99 | either (\_ -> return nil) id $ mwelcome <&> \welcome -> do | ||
100 | dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome | ||
101 | noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome) | ||
102 | nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello) | ||
103 | nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome) | ||
104 | let them = sessionPublicKey $ runIdentity $ welcomeData welcome | ||
105 | hvar <- newMVar h | ||
106 | return SessionProtocol | ||
107 | { streamGoodbye = do | ||
108 | dput XTCP $ "Closing " ++ show addr | ||
109 | return () -- No goodbye packet? Seems rude. | ||
110 | , streamDecode = | ||
111 | let go h = decode <$> hGet h 2 >>= \case | ||
112 | Left e -> do | ||
113 | dput XTCP $ "TCP: (" ++ show addr ++ ") Failed to get length: " ++ e | ||
114 | return Nothing | ||
115 | Right len -> do | ||
116 | decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case | ||
117 | Left e -> do | ||
118 | dput XTCP $ "TCP: Failed to decode packet." | ||
119 | return Nothing | ||
120 | Right x -> do | ||
121 | m24 <- timeout 1000000 (takeMVar nread) | ||
122 | fmap join $ forM m24 $ \n24 -> do | ||
123 | let r = decrypt (noncef' n24) x >>= decodePlain | ||
124 | putMVar nread (incrementNonce24 n24) | ||
125 | either (dput XTCP . ("TCP decryption: " ++)) | ||
126 | (\x' -> do | ||
127 | dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x' | ||
128 | return ()) | ||
129 | r | ||
130 | return $ either (const Nothing) Just r | ||
131 | in bracket (takeMVar hvar) (putMVar hvar) | ||
132 | $ \h -> go h `catchIOError` \e -> do | ||
133 | dput XTCP $ "TCP exception: " ++ show e | ||
134 | return Nothing | ||
135 | , streamEncode = \y -> do | ||
136 | dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y | ||
137 | n24 <- takeMVar nsend | ||
138 | dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y | ||
139 | let bs = encode $ encrypt (noncef' n24) $ encodePlain y | ||
140 | ($ h) -- bracket (takeMVar hvar) (putMVar hvar) | ||
141 | $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs) | ||
142 | `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e | ||
143 | dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y | ||
144 | putMVar nsend (incrementNonce24 n24) | ||
145 | dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y | ||
146 | } | ||
147 | , streamAddr = nodeAddr | ||
148 | } | ||
149 | |||
150 | toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol RelayPacket RelayPacket) | ||
151 | , TransportA err NodeInfo RelayPacket (Bool,RelayPacket) ) | ||
152 | toxTCP crypto = tcpTransport 30 (tcpStream crypto) | ||
153 | |||
154 | tcpSpace :: KademliaSpace NodeId NodeInfo | ||
155 | tcpSpace = contramap udpNodeInfo toxSpace | ||
156 | |||
157 | {- | ||
158 | nodeSearch :: TCPClient err () Nonce8 -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo | ||
159 | nodeSearch tcp = Search | ||
160 | { searchSpace = tcpSpace | ||
161 | , searchNodeAddress = nodeIP &&& tcpPort | ||
162 | , searchQuery = getNodes tcp | ||
163 | } | ||
164 | -} | ||
165 | |||
166 | data TCPClient err tid = TCPClient | ||
167 | { tcpCrypto :: TransportCrypto | ||
168 | , tcpClient :: Client err PacketNumber tid NodeInfo (Bool,RelayPacket) | ||
169 | , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo) | ||
170 | } | ||
171 | |||
172 | {- | ||
173 | getTCPNodes :: TCPClient err () Nonce8 -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | ||
174 | getTCPNodes tcp seeking dst = do | ||
175 | r <- getUDPNodes' tcp seeking (udpNodeInfo dst) | ||
176 | let tcps (ns,_,mb) = (ns',ns',mb) | ||
177 | where ns' = do | ||
178 | n <- ns | ||
179 | [ NodeInfo n (fromIntegral 443) , NodeInfo n (fromIntegral 80) , NodeInfo n (UDP.nodePort n) ] | ||
180 | fmap join $ forM r $ \(ns,gw) -> do | ||
181 | let ts = tcps ns | ||
182 | {- | ||
183 | if nodeId gw == nodeId dst | ||
184 | then return $ Just ts | ||
185 | else do | ||
186 | forkIO $ void $ tcpPing (tcpClient tcp) dst | ||
187 | return $ Just ts | ||
188 | -} | ||
189 | forM_ ((\(xs,_,_) -> xs) ts) (forkIO . void . tcpPing (tcpClient tcp)) | ||
190 | return $ Just ts | ||
191 | -} | ||
192 | |||
193 | getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ())) | ||
194 | getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst | ||
195 | |||
196 | getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo)) | ||
197 | getUDPNodes' tcp seeking dst0 = do | ||
198 | mgateway <- atomically $ tcpGetGateway tcp dst0 | ||
199 | fmap join $ forM mgateway $ \gateway -> do | ||
200 | (b,c,n24) <- atomically $ do | ||
201 | b <- transportNewKey (tcpCrypto tcp) | ||
202 | c <- transportNewKey (tcpCrypto tcp) | ||
203 | n24 <- transportNewNonce (tcpCrypto tcp) | ||
204 | return (b,c,n24) | ||
205 | let (dst,gateway') = if UDP.nodeId dst0 == nodeId gateway | ||
206 | then ( dst0 { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 } | ||
207 | , gateway { udpNodeInfo = (udpNodeInfo gateway) | ||
208 | { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }}) | ||
209 | else (dst0,gateway) | ||
210 | wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst) | ||
211 | wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway) | ||
212 | wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst) | ||
213 | let meth :: MethodSerializer | ||
214 | Nonce8 | ||
215 | a -- NodeInfo | ||
216 | (Bool, RelayPacket) | ||
217 | PacketNumber | ||
218 | AnnounceRequest | ||
219 | (Either String AnnounceResponse) | ||
220 | meth = MethodSerializer | ||
221 | { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout | ||
222 | , method = OnionPacketID -- meth | ||
223 | , wrapQuery = \n8 src gateway x -> (,) True $ | ||
224 | OnionPacket n24 $ Addressed (UDP.nodeAddr dst) | ||
225 | $ wrapOnionPure b (wrap2 n24) (nodeAddr gateway') | ||
226 | $ wrapOnionPure c (wrap1 n24) (UDP.nodeAddr dst) | ||
227 | $ NotForwarded $ encryptPayload (wrap0 n24) | ||
228 | $ OnionAnnounce Asymm | ||
229 | { senderKey = transportPublic (tcpCrypto tcp) | ||
230 | , asymmNonce = n24 | ||
231 | , asymmData = pure (x,n8) | ||
232 | } | ||
233 | , unwrapResponse = \case | ||
234 | (_,OnionPacketResponse (OnionAnnounceResponse _ n24' r)) | ||
235 | -> decrypt (wrap0 n24') r >>= decodePlain | ||
236 | x -> Left $ "getUDPNodes: unwrapResponse fail " ++ show x | ||
237 | } | ||
238 | r <- sendQuery (tcpClient tcp) meth (AnnounceRequest zeros32 seeking UDP.zeroID) gateway | ||
239 | forM r $ \response -> do | ||
240 | let (ns,_,mb) = either (const ([],[],Nothing)) (unwrapAnnounceResponse Nothing dst) $ response | ||
241 | return ( (ns,ns, const () <$> mb), gateway ) | ||
242 | |||
243 | |||
244 | handleOOB :: PublicKey -> ByteString -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x)) | ||
245 | handleOOB k bs src dst = do | ||
246 | dput XMisc $ "TODO: handleOOB " ++ show src | ||
247 | return Nothing | ||
248 | |||
249 | handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x)) | ||
250 | handle2route o src dst = do | ||
251 | dput XMisc $ "TODO: handle2route " ++ show src | ||
252 | return Nothing | ||
253 | |||
254 | tcpPing :: Show addr => Client err PacketNumber Nonce8 addr (Bool,RelayPacket) -> addr -> IO (Maybe ()) | ||
255 | tcpPing client dst = do | ||
256 | dput XTCP $ "tcpPing " ++ show dst | ||
257 | sendQuery client meth () dst | ||
258 | where meth = MethodSerializer | ||
259 | { wrapQuery = \n8 src dst () -> (True,RelayPing n8) | ||
260 | , unwrapResponse = \_ -> () | ||
261 | , methodTimeout = \n8 dst -> return (dst,5000000) | ||
262 | , method = PingPacket | ||
263 | } | ||
264 | |||
265 | type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket) | ||
266 | |||
267 | -- | Create a new TCP relay client. Because polymorphic existential record | ||
268 | -- updates are currently hard with GHC, this function accepts parameters for | ||
269 | -- generalizing the table-entry type for pending transactions. Safe trivial | ||
270 | -- defaults are 'id' and 'tryPutMVar'. The resulting customized table state | ||
271 | -- will be returned to the caller along with the new client. | ||
272 | newClient :: TransportCrypto | ||
273 | -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query | ||
274 | -> (a -> RelayPacket -> IO void) -- ^ load mvar for query | ||
275 | -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a) | ||
276 | , TCPCache (SessionProtocol RelayPacket RelayPacket) ) | ||
277 | , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)) | ||
278 | newClient crypto store load = do | ||
279 | (tcpcache,net) <- toxTCP crypto | ||
280 | drg <- drgNew | ||
281 | map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) | ||
282 | return $ (,) (map_var,tcpcache) Client | ||
283 | { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net | ||
284 | , clientDispatcher = DispatchMethods | ||
285 | { classifyInbound = (. snd) $ \case | ||
286 | RelayPing n -> IsQuery PingPacket n | ||
287 | RelayPong n -> IsResponse n | ||
288 | OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8 | ||
289 | OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o | ||
290 | OOBRecv k bs -> IsUnsolicited $ handleOOB k bs | ||
291 | wut -> IsUnknown (show wut) | ||
292 | , lookupHandler = \case | ||
293 | PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler | ||
294 | { methodParse = \case (_,RelayPing n8) -> Right () | ||
295 | _ -> trace ("tcp-non-ping") $ Left "TCP: Non-ping?" | ||
296 | , methodSerialize = \n8 src dst () -> trace ("tcp-made-pong-"++show n8) (False, RelayPong n8) | ||
297 | , methodAction = \src () -> dput XTCP $ "TCP pinged by "++show src | ||
298 | } | ||
299 | w -> trace ("tcp-lookupHandler: "++show w) $ Just NoReply | ||
300 | { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a | ||
301 | , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w | ||
302 | } | ||
303 | , tableMethods = transactionMethods' store (\x -> mapM_ (load x . snd)) (contramap (\(Nonce8 w64) -> w64) w64MapMethods) | ||
304 | $ first (either error Nonce8 . decode) . randomBytesGenerate 8 | ||
305 | } | ||
306 | , clientErrorReporter = logErrors | ||
307 | , clientPending = map_var | ||
308 | , clientAddress = \_ -> return $ NodeInfo | ||
309 | { udpNodeInfo = either error id $ UDP.nodeInfo (UDP.key2id $ transportPublic crypto) (SockAddrInet 0 0) | ||
310 | , tcpPort = 0 | ||
311 | } | ||
312 | , clientResponseId = return | ||
313 | } | ||
diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs deleted file mode 100644 index 217d5b1d..00000000 --- a/src/Network/Tox/Transport.hs +++ /dev/null | |||
@@ -1,86 +0,0 @@ | |||
1 | {-# LANGUAGE DataKinds #-} | ||
2 | {-# LANGUAGE GADTs #-} | ||
3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
4 | {-# LANGUAGE KindSignatures #-} | ||
5 | {-# LANGUAGE LambdaCase #-} | ||
6 | {-# LANGUAGE ScopedTypeVariables #-} | ||
7 | {-# LANGUAGE TupleSections #-} | ||
8 | {-# LANGUAGE TypeOperators #-} | ||
9 | module Network.Tox.Transport (toxTransport, RouteId) where | ||
10 | |||
11 | import Network.QueryResponse | ||
12 | import Crypto.Tox | ||
13 | import Data.Tox.Relay as TCP | ||
14 | import Network.Tox.DHT.Transport as UDP | ||
15 | import Network.Tox.Onion.Transport | ||
16 | import Network.Tox.Crypto.Transport | ||
17 | import OnionRouter | ||
18 | |||
19 | import Network.Socket | ||
20 | |||
21 | toxTransport :: | ||
22 | TransportCrypto | ||
23 | -> OnionRouter | ||
24 | -> (PublicKey -> IO (Maybe UDP.NodeInfo)) | ||
25 | -> UDPTransport | ||
26 | -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ TCP server-bound callback. | ||
27 | -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback. | ||
28 | -> IO ( Transport String SockAddr (CryptoPacket Encrypted) | ||
29 | , Transport String UDP.NodeInfo (DHTMessage Encrypted8) | ||
30 | , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) | ||
31 | , Transport String AnnouncedRendezvous (PublicKey,OnionData) | ||
32 | , Transport String SockAddr (Handshake Encrypted)) | ||
33 | toxTransport crypto orouter closeLookup udp tcp2server tcp2client = do | ||
34 | (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp | ||
35 | (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) | ||
36 | $ forwardOnions crypto udp0 tcp2client | ||
37 | (onion1,udp2) <- partitionAndForkTransport tcp2server | ||
38 | (parseOnionAddr $ lookupSender orouter) | ||
39 | (encodeOnionAddr crypto $ lookupRoute orouter) | ||
40 | udp1 | ||
41 | (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 | ||
42 | let handshakes = layerTransport parseHandshakes encodeHandshakes udp2 | ||
43 | return ( netcrypto | ||
44 | , forwardDHTRequests crypto closeLookup dht | ||
45 | , onion | ||
46 | , dta | ||
47 | , handshakes | ||
48 | ) | ||
49 | |||
50 | |||
51 | -- instance (Sized a, Sized b) => Sized (a,b) where size = _todo | ||
52 | |||
53 | |||
54 | -- Byte value Packet Kind Return address | ||
55 | -- :----------- :-------------------- | ||
56 | -- `0x00` Ping Request DHTNode | ||
57 | -- `0x01` Ping Response - | ||
58 | -- `0x02` Nodes Request DHTNode | ||
59 | -- `0x04` Nodes Response - | ||
60 | -- `0x18` Cookie Request DHTNode, but without sending pubkey in response | ||
61 | -- `0x19` Cookie Response - (no pubkey) | ||
62 | -- | ||
63 | -- `0x21` LAN Discovery DHTNode (No reply, port 33445, trigger Nodes Request/Response) | ||
64 | -- | ||
65 | -- `0x20` DHT Request DHTNode/-forward | ||
66 | -- | ||
67 | -- `0x1a` Crypto Handshake CookieAddress | ||
68 | -- | ||
69 | -- `0x1b` Crypto Data SessionAddress | ||
70 | -- | ||
71 | -- `0x83` Announce Request OnionToOwner | ||
72 | -- `0x84` Announce Response - | ||
73 | -- `0x85` Onion Data Request OnionToOwner | ||
74 | -- `0x86` Onion Data Response - | ||
75 | -- | ||
76 | -- `0xf0` Bootstrap Info SockAddr? | ||
77 | -- | ||
78 | -- `0x80` Onion Request 0 -forward | ||
79 | -- `0x81` Onion Request 1 -forward | ||
80 | -- `0x82` Onion Request 2 -forward | ||
81 | -- `0x8c` Onion Response 3 -return | ||
82 | -- `0x8d` Onion Response 2 -return | ||
83 | -- `0x8e` Onion Response 1 -return | ||
84 | |||
85 | |||
86 | |||