summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Network/QueryResponse.hs24
-rw-r--r--src/Network/Tox.hs27
-rw-r--r--src/Network/Tox/DHT/Handlers.hs10
-rw-r--r--src/Network/Tox/Onion/Transport.hs6
4 files changed, 45 insertions, 22 deletions
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index b757aed7..0345dd88 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -503,6 +503,17 @@ ignoreEOF def e | isEOFError e = pure def
503udpBufferSize :: Int 503udpBufferSize :: Int
504udpBufferSize = 65536 504udpBufferSize = 65536
505 505
506-- | Wrapper around 'B.sendTo' that silently ignores DoesNotExistError.
507saferSendTo :: Socket -> ByteString -> SockAddr -> IO ()
508saferSendTo sock bs saddr = void (B.sendTo sock bs saddr)
509 `catch` \e ->
510 -- sendTo: does not exist (Network is unreachable)
511 -- Occurs when IPv6 or IPv4 network is not available.
512 -- Currently, we require -threaded to prevent a forever-hang in this case.
513 if isDoesNotExistError e
514 then return ()
515 else throw e
516
506-- | A 'udpTransport' uses a UDP socket to send and receive 'ByteString's. The 517-- | A 'udpTransport' uses a UDP socket to send and receive 'ByteString's. The
507-- argument is the listen-address for incoming packets. This is a useful 518-- argument is the listen-address for incoming packets. This is a useful
508-- low-level 'Transport' that can be transformed for higher-level protocols 519-- low-level 'Transport' that can be transformed for higher-level protocols
@@ -520,22 +531,19 @@ udpTransport bind_address = do
520 Just . Right <$!> B.recvFrom sock udpBufferSize 531 Just . Right <$!> B.recvFrom sock udpBufferSize
521 kont $! r 532 kont $! r
522 , sendMessage = case family of 533 , sendMessage = case family of
523 -- TODO: sendTo: does not exist (Network is unreachable)
524 -- Occurs when IPv6 network is not available.
525 -- Currently, we require -threaded to prevent a forever-hang in this case.
526 AF_INET6 -> \case 534 AF_INET6 -> \case
527 (SockAddrInet port addr) -> \bs -> 535 (SockAddrInet port addr) -> \bs ->
528 -- Change IPv4 to 4mapped6 address. 536 -- Change IPv4 to 4mapped6 address.
529 void $ B.sendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0 537 saferSendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0
530 addr6 -> \bs -> void $ B.sendTo sock bs addr6 538 addr6 -> \bs -> saferSendTo sock bs addr6
531 AF_INET -> \case 539 AF_INET -> \case
532 (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do 540 (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do
533 let host4 = toBE32 raw4 541 let host4 = toBE32 raw4
534 -- Change 4mapped6 to ordinary IPv4. 542 -- Change 4mapped6 to ordinary IPv4.
535 -- hPutStrLn stderr $ "4mapped6 -> "++show (SockAddrInet port host4) 543 -- hPutStrLn stderr $ "4mapped6 -> "++show (SockAddrInet port host4)
536 void $ B.sendTo sock bs (SockAddrInet port host4) 544 saferSendTo sock bs (SockAddrInet port host4)
537 addr@(SockAddrInet6 {}) -> \bs -> hPutStrLn stderr ("Discarding packet to "++show addr) 545 addr@(SockAddrInet6 {}) -> \bs -> hPutStrLn stderr ("Discarding packet to "++show addr)
538 addr4 -> \bs -> void $ B.sendTo sock bs addr4 546 addr4 -> \bs -> saferSendTo sock bs addr4
539 _ -> \addr bs -> void $ B.sendTo sock bs addr 547 _ -> \addr bs -> saferSendTo sock bs addr
540 , closeTransport = close sock 548 , closeTransport = close sock
541 } 549 }
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 9f41fbe5..7179e3c2 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -284,24 +284,31 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do
284 284
285newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> Maybe NetCryptoSessions -> Maybe SecretKey -> IO Tox 285newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> Maybe NetCryptoSessions -> Maybe SecretKey -> IO Tox
286newTox keydb addr mbSessionsState suppliedDHTKey = do 286newTox keydb addr mbSessionsState suppliedDHTKey = do
287 udp <- addVerbosity <$> udpTransport addr 287 udp <- {- addVerbosity <$> -} udpTransport addr
288 (crypto,sessionsState) <- case mbSessionsState of 288 (crypto0,sessionsState) <- case mbSessionsState of
289 Nothing -> do 289 Nothing -> do
290 crypto0 <- newCrypto 290 crypto <- newCrypto
291 let crypto = fromMaybe crypto0 $do
292 k <- suppliedDHTKey
293 return crypto0
294 { transportSecret = k
295 , transportPublic = toPublic k
296 }
297 sessionsState <- newSessionsState crypto defaultUnRecHook defaultCryptoDataHooks 291 sessionsState <- newSessionsState crypto defaultUnRecHook defaultCryptoDataHooks
298 return (crypto,sessionsState) 292 return (crypto,sessionsState)
299 Just s -> return (transportCrypto s, s) 293 Just s -> return (transportCrypto s, s)
294
295 let crypto = fromMaybe crypto0 $do
296 k <- suppliedDHTKey
297 return crypto0
298 { transportSecret = k
299 , transportPublic = toPublic k
300 }
301 forM_ suppliedDHTKey $ \k -> do
302 maybe (hPutStrLn stderr "failed to encode suppliedDHTKey")
303 (C8.hPutStrLn stderr . C8.append "Using suppliedDHTKey: ")
304 $ encodeSecret k
305
300 drg <- drgNew 306 drg <- drgNew
301 let lookupClose _ = return Nothing 307 let lookupClose _ = return Nothing
302 308
303 routing <- DHT.newRouting addr crypto updateIP updateIP 309 routing <- DHT.newRouting addr crypto updateIP updateIP
304 orouter <- newOnionRouter 310 let ignoreErrors _ = return () -- Set this to (hPutStrLn stderr) to debug onion route building.
311 orouter <- newOnionRouter ignoreErrors
305 (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp 312 (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp
306 let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt 313 let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
307 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers crypto routing) id 314 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers crypto routing) id
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index 89f3d442..fc28e2d2 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -383,12 +383,20 @@ isCookieRequest _ _ = Left "Bad cookie request"
383mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie -> DHTMessage ((,) Nonce8) 383mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie -> DHTMessage ((,) Nonce8)
384mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie) 384mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie)
385 385
386isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest
387isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a
388isDHTRequest _ _ = Left "Bad dht relay request"
389
390dhtRequestH :: NodeInfo -> DHTRequest -> IO ()
391dhtRequestH ni req = do
392 hPutStrLn stderr $ "Unhandled DHT Request: " ++ show req
386 393
387handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler 394handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler
388handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH 395handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH
389handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing 396handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing
390handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto 397handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto
391handlers _ _ _ = error "TODO handlers" 398handlers _ _ DHTRequestType = Just $ NoReply (isDHTRequest snd) $ dhtRequestH
399handlers _ _ typ = error $ "TODO DHT handlers " ++ show typ
392 400
393nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo 401nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo
394nodeSearch client = Search 402nodeSearch client = Search
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 39ea8c46..5b7aad0b 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -247,8 +247,8 @@ encodeOnionAddr getRoute (msg,OnionDestination _ ni (Just rid)) = do
247 , nodeAddr $ routeNodeA route) 247 , nodeAddr $ routeNodeA route)
248 mapM' f x = do 248 mapM' f x = do
249 let _ = x :: Maybe OnionRoute 249 let _ = x :: Maybe OnionRoute
250 hPutStrLn stderr $ "ONION encode sending to " ++ show ni 250 -- hPutStrLn stderr $ "ONION encode sending to " ++ show ni
251 hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (fmap (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x) 251 -- hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (fmap (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x)
252 mapM f x -- ONION encode getRoute -> Nothing 252 mapM f x -- ONION encode getRoute -> Nothing
253 getRoute ni rid >>= mapM' go 253 getRoute ni rid >>= mapM' go
254 254
@@ -846,7 +846,7 @@ parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
846 (Left (dataFromKey dtr, dataToRoute dtr)) 846 (Left (dataFromKey dtr, dataToRoute dtr))
847 return (pk,dtr,omsg) 847 return (pk,dtr,omsg)
848 848
849 eInner = foldr1 (<|>) eInners 849 eInner = foldr (<|>) (Left "no user key") eInners
850 850
851 e = do 851 e = do
852 (pk,dtr,omsg) <- eInner 852 (pk,dtr,omsg) <- eInner