Ability to send onion messages when given a path.

2 files changed, 122 insertions, 58 deletions

diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
index 72398735..08f5cabd 100644
--- a/src/Network/Tox/Onion/Handlers.hs
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -35,7 +35,7 @@ import Data.Bits
 import Data.Ord
 import Data.Functor.Identity
 
-type Client = QR.Client String PacketKind TransactionId OnionDestination Message
+type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
 type Message = OnionMessage Identity
 
 classify :: Message -> MessageClass String PacketKind TransactionId
@@ -59,7 +59,7 @@ classify msg = go msg
 -- The reason for this 20 second timeout in toxcore is that it gives a reasonable
 -- time (20 to 40 seconds) for a peer to announce himself while taking in count
 -- all the possible delays with some extra seconds.
-announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination -> AnnounceRequest -> IO AnnounceResponse
+announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
 announceH routing toks keydb (OnionToOwner naddr retpath) req = do
     case () of
         _ | announcePingId req == zeros32
@@ -76,7 +76,7 @@ announceH routing toks keydb (OnionToOwner naddr retpath) req = do
         let storing = (nodeId naddr == announceSeeking req)
         record <- atomically $ do
             when (withTok && storing) $ do
-                let toxpath = OnionToOwner naddr{ nodeId = announceKey req } retpath
+                let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
                     -- Note: The following distance calculation assumes that
                     -- our nodeid doesn't change and is the same for both
                     -- routing4 and routing6.
@@ -89,16 +89,16 @@ announceH routing toks keydb (OnionToOwner naddr retpath) req = do
                     then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
                     else return $ zeros32
         let k = case record of
-                Nothing                              -> NotStored newtok
-                Just (OnionDestination {}) | storing -> Acknowledged newtok
-                Just (OnionToOwner   ni _)           -> SendBackKey $ id2key (nodeId ni)
+                Nothing                    -> NotStored newtok
+                Just _  | storing          -> Acknowledged newtok
+                Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
         let response = AnnounceResponse k ns
         hPutStrLn stderr $ unwords ["Announce:", show req, "-reply->", show response]
         return response
 
 dataToRouteH ::
           TVar AnnouncedKeys
-          -> Transport err OnionDestination (OnionMessage f)
+          -> Transport err (OnionDestination r) (OnionMessage f)
           -> addr
           -> OnionMessage f
           -> IO ()
@@ -111,18 +111,23 @@ dataToRouteH keydb udp _ (OnionToRoute pub assym) = do
             return rpath
     forM_ mb $ \rpath -> do
         -- forward
-        sendMessage udp rpath $ OnionToRouteResponse assym
+        sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse assym
         hPutStrLn stderr $ "Forwarding data-to-route -->"++show k
 
 type NodeDistance = NodeId
 
+data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3)
+
+toOnionDestination :: AnnouncedRoute -> OnionDestination r
+toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath
+
 data AnnouncedKeys = AnnouncedKeys
     { keyByAge :: !(PSQ NodeId (Down POSIXTime)) -- timeout of 300 seconds
-    , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int,OnionDestination))
+    , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int,AnnouncedRoute))
     }
 
 
-insertKey :: POSIXTime -> NodeId -> OnionDestination -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
+insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
 insertKey tm pub toxpath d keydb = AnnouncedKeys
     { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
     , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
@@ -134,12 +139,12 @@ areq :: Message -> Either String AnnounceRequest
 areq (OnionAnnounce assym) = Right $ fst $ runIdentity $ assymData assym
 areq _                     = Left "Unexpected non-announce OnionMessage"
 
-handlers :: Transport err OnionDestination Message
+handlers :: Transport err (OnionDestination r) Message
             -> Routing
             -> TVar SessionTokens
             -> TVar AnnouncedKeys
             -> PacketKind
-            -> Maybe (MethodHandler String TransactionId OnionDestination Message)
+            -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message)
 handlers net routing toks keydb AnnounceType
     = Just
     $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 0e6e4954..a3c1950f 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -33,6 +33,8 @@ module Network.Tox.Onion.Transport
     , encrypt
     , decrypt
     , peelSymmetric
+    , OnionRoute(..)
+    , N3
     ) where
 
 import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
@@ -86,13 +88,14 @@ deriving instance ( Show (f (AnnounceRequest, Nonce8))
                   , Show (f DataToRoute)
                   ) => Show (OnionMessage f)
 
-data OnionDestination = OnionToOwner NodeInfo (ReturnPath N3) -- ^ Somebody else's path to us.
-                      | OnionDestination NodeInfo             -- ^ Our own onion-path.
+data OnionDestination r
+    = OnionToOwner     NodeInfo (ReturnPath N3) -- ^ Somebody else's path to us.
+    | OnionDestination NodeInfo (Maybe r)       -- ^ Our own onion-path.
     deriving Show
 
-onionKey :: OnionDestination -> Maybe PublicKey
-onionKey (OnionToOwner ni _) = Just $ id2key (nodeId ni)
-onionKey _                   = Nothing
+onionKey :: OnionDestination r -> Maybe PublicKey
+onionKey (OnionToOwner     ni _) = Just $ id2key (nodeId ni)
+onionKey (OnionDestination ni _) = Just $ id2key (nodeId ni)
 
 instance Sized (OnionMessage Encrypted) where
     size = VarSize $ \case
@@ -111,15 +114,14 @@ instance Serialize (OnionMessage Encrypted) where
         case typ :: Word8 of
             0x83 -> OnionAnnounce <$> getAliasedAssym
             0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAssym
-            0x84 -> getOnionReply typ
-            0x86 -> getOnionReply typ
-            t    -> fail $ "Unknown onion payload: " ++ show t
+            t    -> fail ("Unknown onion payload: " ++ show t)
+                    `fromMaybe` getOnionReply t
     put (OnionAnnounce a)                = putWord8 0x83 >> putAliasedAssym a
     put (OnionToRoute k a)               = putWord8 0x85 >> putPublicKey k >> putAliasedAssym a
     put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x
     put (OnionToRouteResponse a)         = putWord8 0x86 >> putAliasedAssym a
 
-onionToOwner :: Assym a -> ReturnPath N3 -> SockAddr -> Either String OnionDestination
+onionToOwner :: Assym a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r)
 onionToOwner assym ret3 saddr = do
     ni <- nodeInfo (key2id $ senderKey assym) saddr
     return $ OnionToOwner ni ret3
@@ -130,36 +132,37 @@ onion :: Sized msg =>
                ByteString
                -> SockAddr
                -> Get (Assym (Encrypted msg) -> t)
-               -> Either String (t, OnionDestination)
+               -> Either String (t, OnionDestination r)
 onion bs saddr getf = do (f,(assym,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs
                          oaddr <- onionToOwner assym ret3 saddr
                          return (f assym, oaddr)
 
-
-parseOnionAddr :: (ByteString, SockAddr) -> Either (OnionMessage Encrypted,OnionDestination) (ByteString,SockAddr)
-parseOnionAddr (msg,saddr)
+parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (NodeInfo,r)))
+                  -> (ByteString, SockAddr)
+                  -> IO (Either (OnionMessage Encrypted,OnionDestination r)
+                                (ByteString,SockAddr))
+parseOnionAddr lookupSender (msg,saddr)
     | Just (typ,bs) <- B.uncons msg
     , let right = Right (msg,saddr)
-          query = either (const right) Left
-          response = either (const right) (Left . \msg -> ( msg , replyAlias saddr msg ))
+          query = return . either (const right) Left
     = case typ of
     0x83 -> query $ onion bs saddr (pure OnionAnnounce)            -- Announce Request
     0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request
-    0x84 -> response $ runGet (getOnionReply 0x84) bs              -- Announce Response
-    0x86 -> response $ runGet (getOnionReply 0x86) bs              -- Onion Data Response
-    _ -> right
-
-getOnionReply :: Word8 -> Get (OnionMessage Encrypted)
-getOnionReply 0x84 = OnionAnnounceResponse <$> get <*> get <*> get
-getOnionReply 0x86 = OnionToRouteResponse <$> getOnionAssym
-
-replyAlias :: SockAddr -> OnionMessage Encrypted -> OnionDestination
-replyAlias saddr (OnionAnnounceResponse  _ _ _)
-    = OnionDestination
-    $ either (error "replyAlias: bad protocol") id
-    $ nodeInfo zeroID saddr -- TODO OnionAnnounceResponse has no sender key
-replyAlias saddr (OnionToRouteResponse asym)
-    = OnionDestination $ asymNodeInfo saddr asym
+    _ -> case flip runGet bs <$> getOnionReply typ of
+            Just (Right msg@(OnionAnnounceResponse n8 _ _)) -> do
+                maddr <- lookupSender saddr n8
+                maybe (return right) -- Response unsolicited or too late.
+                      (return . Left . \(ni,r) -> (msg,OnionDestination ni (Just r)))
+                      maddr
+            Just (Right msg@(OnionToRouteResponse asym)) -> do
+                let ni = asymNodeInfo saddr asym
+                return $ Left (msg, OnionDestination ni Nothing)
+            _ -> return right
+
+getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted))
+getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get
+getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAssym
+getOnionReply _    = Nothing
 
 putOnionMsg :: OnionMessage Encrypted -> Put
 putOnionMsg (OnionAnnounce                a) = putOnionAssym 0x83 (return ()) a
@@ -167,10 +170,18 @@ putOnionMsg (OnionToRoute pubkey          a) = putOnionAssym 0x85 (putPublicKey
 putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x
 putOnionMsg (OnionToRouteResponse         a) = putOnionAssym 0x86 (return ()) a
 
-encodeOnionAddr :: (OnionMessage Encrypted,OnionDestination) -> (ByteString, SockAddr)
-encodeOnionAddr (msg,OnionToOwner ni p) = ( runPut $ putResponse (OnionResponse p msg)
-                                          , nodeAddr ni )
-encodeOnionAddr (msg,OnionDestination a) = ( runPut (putOnionMsg msg), nodeAddr a) -- TODO: Construct (OnionRequest N0)?
+encodeOnionAddr :: (NodeInfo -> r -> IO (Maybe OnionRoute))
+                   -> (OnionMessage Encrypted,OnionDestination r)
+                   -> IO (Maybe (ByteString, SockAddr))
+encodeOnionAddr _ (msg,OnionToOwner ni p) =
+    return $ Just ( runPut $ putResponse (OnionResponse p msg)
+                  , nodeAddr ni )
+encodeOnionAddr _        (msg,OnionDestination _  Nothing   ) = return Nothing
+encodeOnionAddr getRoute (msg,OnionDestination ni (Just rid)) = do
+    let go route = do
+            return (runPut $ putRequest $ wrapForRoute msg ni route, nodeAddr ni)
+    getRoute ni rid >>= mapM go
+
 
 forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport
 forwardOnions crypto udp = udp { awaitMessage = forwardAwait crypto udp }
@@ -253,7 +264,8 @@ data OnionResponse n = OnionResponse
 deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n)
 
 instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where
-    get = OnionResponse <$> get <*> (get >>= getOnionReply)
+    get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding")
+                                             . getOnionReply)
     put (OnionResponse p m) = put p >> putOnionMsg m
 
 
@@ -525,7 +537,7 @@ instance Sized OnionData where
                              -- should be treated as variable sized.
             VarSize f   -> f dhtpk
 
-encrypt :: TransportCrypto -> OnionMessage Identity -> OnionDestination -> (OnionMessage Encrypted, OnionDestination)
+encrypt :: TransportCrypto -> OnionMessage Identity -> OnionDestination r -> (OnionMessage Encrypted, OnionDestination r)
 encrypt crypto msg rpath = ( transcode ( (. (runIdentity . either id assymData))
                                          . encryptMessage skey okey)
                                        msg
@@ -545,31 +557,78 @@ encryptMessage skey destKey n a = ToxCrypto.encrypt secret plain
     secret = computeSharedSecret skey destKey n
     plain  = encodePlain a
 
-decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination -> Either String (OnionMessage Identity, OnionDestination)
-decrypt crypto msg addr = (, addr) <$> (sequenceMessage $ transcode (decryptMessage crypto) msg)
+decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> Either String (OnionMessage Identity, OnionDestination r)
+decrypt crypto msg addr = do
+    msg <- sequenceMessage $ transcode (\n -> decryptMessage crypto n . left (senderkey addr)) msg
+    Right (msg, addr)
+
+senderkey :: OnionDestination r -> t -> (Maybe PublicKey, t)
+senderkey addr e = (onionKey addr, e)
 
 decryptMessage :: Serialize x =>
                   TransportCrypto
                   -> Nonce24
-                  -> Either (Encrypted x) (Assym (Encrypted x))
+                  -> Either (Maybe PublicKey, Encrypted x)
+                            (Assym (Encrypted x))
                   -> (Either String ∘ Identity) x
-decryptMessage crypto n (Right assymE) = plain $ ToxCrypto.decrypt secret e
+decryptMessage crypto n arg
+    | Just secret <- msecret = plain $ ToxCrypto.decrypt secret e
+    | otherwise              = Composed $ Left "decryptMessage: Unknown sender"
  where
-    secret = computeSharedSecret (transportSecret crypto) (senderKey assymE) n
-    e      = assymData assymE
-    plain  = Composed . fmap Identity . (>>= decodePlain)
-decryptMessage crypto n (Left e) = _todo -- OnionAnnounceResponse has no sender key
+    msecret  = do sender <- mkey
+                  Just $ computeSharedSecret (transportSecret crypto) sender n
+    (mkey,e) = either id (Just . senderKey &&& assymData) arg
+    plain    = Composed . fmap Identity . (>>= decodePlain)
 
 
 sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
-sequenceMessage (OnionAnnounce a)        = fmap OnionAnnounce        $ sequenceA $ fmap uncomposed a
+sequenceMessage (OnionAnnounce a)        = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a
 sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
 sequenceMessage (OnionToRoute pub a)     = pure $ OnionToRoute pub a
 sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a
 
 transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Assym (f a)) -> g a) -> OnionMessage f -> OnionMessage g
-transcode f (OnionAnnounce a)        = OnionAnnounce        $ a { assymData = f (assymNonce a) (Right a) }
+transcode f (OnionAnnounce a)        = OnionAnnounce $ a { assymData = f (assymNonce a) (Right a) }
 transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta
 transcode f (OnionToRoute pub a)     = OnionToRoute pub     a
 transcode f (OnionToRouteResponse a) = OnionToRouteResponse a
 
+
+data OnionRoute = OnionRoute
+    { routeNonce  :: Nonce24
+    , routeAliasA :: SecretKey
+    , routeAliasB :: SecretKey
+    , routeAliasC :: SecretKey
+    , routeNodeA  :: NodeInfo
+    , routeNodeB  :: NodeInfo
+    , routeNodeC  :: NodeInfo
+    }
+
+wrapForRoute :: OnionMessage Encrypted -> NodeInfo -> OnionRoute -> OnionRequest N0
+wrapForRoute msg ni r = OnionRequest
+    { onionNonce = routeNonce r
+    , onionForward = wrapOnion (routeAliasA r)
+                               (routeNonce r)
+                               (id2key . nodeId $ routeNodeA r)
+                               (nodeAddr $ routeNodeB r)
+                   $ wrapOnion (routeAliasB r)
+                               (routeNonce r)
+                               (id2key . nodeId $ routeNodeB r)
+                               (nodeAddr $ routeNodeC r)
+                   $ wrapOnion (routeAliasC r)
+                               (routeNonce r)
+                               (id2key . nodeId $ routeNodeC r)
+                               (nodeAddr ni)
+                   $ NotForwarded msg
+    , pathFromOwner = NoReturnPath
+    }
+
+wrapOnion :: Serialize (Forwarding n msg) =>
+           SecretKey
+           -> Nonce24
+           -> PublicKey
+           -> SockAddr
+           -> Forwarding n msg
+           -> Forwarding (S n) msg
+wrapOnion skey nonce destkey saddr fwd =
+    Forwarding (toPublic skey) $ encryptMessage skey destkey nonce (Addressed saddr fwd)