4 files changed, 136 insertions, 37 deletions

diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index c9adc860..a3f13ac7 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -105,7 +105,6 @@ data Routing = Routing
     , sched6      :: !( TVar (Int.PSQ POSIXTime) )
     , routing6    :: !( TVar (R.BucketList NodeInfo) )
     , committee6  :: TriadCommittee NodeId SockAddr
-    , orouter     :: OnionRouter
     }
 
 newRouting :: SockAddr -> TransportCrypto
@@ -124,8 +123,9 @@ newRouting addr crypto update4 update6 = do
     tentative_info6 <-
         maybe (tentative_info { nodeIP = tentative_ip6 })
               (\ip6 -> tentative_info { nodeIP = IPv6 ip6 })
-            <$> global6
-    orouter <- newOnionRouter
+            <$> case addr of
+                    SockAddrInet {} -> return Nothing
+                    _               -> global6
     atomically $ do
         let nobkts = R.defaultBucketCount :: Int
         tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 nobkts
@@ -134,7 +134,7 @@ newRouting addr crypto update4 update6 = do
         committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6
         sched4 <- newTVar Int.empty
         sched6 <- newTVar Int.empty
-        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6 orouter
+        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6
 
 
 -- TODO: This should cover more cases
@@ -200,7 +200,7 @@ serializer :: PacketKind
                 -> (Message -> Maybe (Assym (Nonce8,pong)))
                 -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
 serializer pktkind mkping mkpong = MethodSerializer
-        { methodTimeout  = 5
+        { methodTimeout  = \tid addr -> return (addr, 5000000)
         , method         = pktkind
         -- wrapQuery :: tid -> addr -> addr -> qry -> x
         , wrapQuery      = \tid src dst ping -> mkping $ wrapAssym tid src dst (, ping)
@@ -232,20 +232,20 @@ unwrapNodes (SendNodes ns) = (ns,ns,())
 
 getNodes :: Client -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],()))
 getNodes client nid addr = do
-    hPutStrLn stderr $ show addr ++ " <-- getnodes " ++ show nid
+    -- hPutStrLn stderr $ show addr ++ " <-- getnodes " ++ show nid
     reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
-    hPutStrLn stderr $ show addr ++ " -sendnodes-> " ++ show reply
+    -- hPutStrLn stderr $ show addr ++ " -sendnodes-> " ++ show reply
     return $ fmap unwrapNodes $ join reply
 
-updateRouting :: Client -> Routing -> NodeInfo -> Message -> IO ()
-updateRouting client routing naddr msg = do
+updateRouting :: Client -> Routing -> OnionRouter -> NodeInfo -> Message -> IO ()
+updateRouting client routing orouter naddr msg = do
     let typ = fst $ dhtMessageType $ fst $ DHTTransport.encrypt (error "updateRouting") msg naddr
         tid = mapMessage (\n24 (n8,_) -> TransactionId n8 n24) msg
-    hPutStrLn stderr $ "updateRouting "++show (typ,tid)
+    -- hPutStrLn stderr $ "updateRouting "++show (typ,tid)
     -- TODO: check msg type
     case prefer4or6 naddr Nothing of
-        Want_IP4 -> updateTable client naddr (orouter routing) (routing4 routing) (committee4 routing) (sched4 routing)
-        Want_IP6 -> updateTable client naddr (orouter routing) (routing6 routing) (committee6 routing) (sched6 routing)
+        Want_IP4 -> updateTable client naddr orouter (routing4 routing) (committee4 routing) (sched4 routing)
+        Want_IP6 -> updateTable client naddr orouter (routing6 routing) (committee6 routing) (sched6 routing)
 
 updateTable :: Client -> NodeInfo -> OnionRouter -> TVar (R.BucketList NodeInfo) -> TriadCommittee NodeId SockAddr -> TVar (Int.PSQ POSIXTime) -> IO ()
 updateTable client naddr orouter tbl committee sched = do
@@ -262,7 +262,7 @@ toxKademlia client committee orouter var sched
                    { tblTransition = \tr -> do
                         io1 <- transitionCommittee committee tr
                         io2 <- touchBucket toxSpace (15*60) var sched tr
-                        hookBucketList orouter tr
+                        hookBucketList toxSpace var orouter tr
                         return $ do
                             io1 >> io2
                             {-
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs
index 959d689c..d0c57416 100644
--- a/src/Network/Tox/NodeId.hs
+++ b/src/Network/Tox/NodeId.hs
@@ -223,7 +223,10 @@ instance Sized NodeInfo where
 instance S.Serialize NodeInfo where
     get = do
         addrfam <- S.get :: S.Get Word8
-        ip <- getIP addrfam
+        let fallback = do -- FIXME: Handle unrecognized address families.
+                IPv6 <$> S.get
+                return $ IPv6 (read "::" :: IPv6)
+        ip <- getIP addrfam <|> fallback
         port <- S.get :: S.Get PortNumber
         nid <- S.get
         return $ NodeInfo nid ip port
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
index 08f5cabd..91dd843e 100644
--- a/src/Network/Tox/Onion/Handlers.hs
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Network.Tox.Onion.Handlers where
 
+import Network.Kademlia.Search
 import Network.Tox.DHT.Transport
 import Network.Tox.DHT.Handlers hiding (Message,Client)
 import Network.Tox.Onion.Transport
@@ -11,9 +13,11 @@ import qualified Data.Wrapper.PSQ             as PSQ
          ;import Data.Wrapper.PSQ             (PSQ)
 import Crypto.Error.Types                     (CryptoFailable (..),
                                                throwCryptoError)
+import Control.Arrow
 
 import System.IO
 import qualified Data.ByteArray               as BA
+import Data.Function
 import Data.Serialize as S
 import qualified Data.Wrapper.PSQInt as Int
 import Network.Kademlia
@@ -59,23 +63,27 @@ 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.
+-- dhtd: src/Network/Tox/Onion/Handlers.hs:(67,1)-(101,23): Non-exhaustive patterns in function announceH
 announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
-announceH routing toks keydb (OnionToOwner naddr retpath) req = do
+announceH routing toks keydb oaddr req = do
     case () of
         _ | announcePingId req == zeros32
           -> go False
 
         _ -> let Nonce32 bs = announcePingId req
                  tok        = fromPaddedByteString 32 bs
-             in checkToken toks naddr tok >>= go
+             in checkToken toks (onionNodeInfo oaddr) tok >>= go
         `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
  where
     go withTok = do
+        let naddr = onionNodeInfo oaddr
         ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
         tm <- getPOSIXTime
-        let storing = (nodeId naddr == announceSeeking req)
+        let storing = case oaddr of
+                        OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
+                        _                  -> Nothing
         record <- atomically $ do
-            when (withTok && storing) $ do
+            forM_ storing $ \retpath -> when withTok $ do
                 let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
                     -- Note: The following distance calculation assumes that
                     -- our nodeid doesn't change and is the same for both
@@ -85,12 +93,12 @@ announceH routing toks keydb (OnionToOwner naddr retpath) req = do
                 modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
             ks <- readTVar keydb
             return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
-        newtok <- if storing
-                    then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
-                    else return $ zeros32
+        newtok <- maybe (return $ zeros32)
+                        (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
+                        storing
         let k = case record of
                 Nothing                    -> NotStored newtok
-                Just _  | storing          -> Acknowledged newtok
+                Just _  | isJust storing   -> Acknowledged newtok
                 Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
         let response = AnnounceResponse k ns
         hPutStrLn stderr $ unwords ["Announce:", show req, "-reply->", show response]
@@ -151,3 +159,58 @@ handlers net routing toks keydb AnnounceType
     $ announceH routing toks keydb
 handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
 
+toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> Client r
+               -> Search NodeId (IP, PortNumber) (Maybe Nonce32) NodeInfo PublicKey
+toxidSearch getTimeout client = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = announce getTimeout client
+    }
+
+announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+                   -> MethodSerializer
+                        TransactionId
+                        (OnionDestination r)
+                        (OnionMessage Identity)
+                        PacketKind
+                        AnnounceRequest
+                        (Maybe AnnounceResponse)
+announceSerializer getTimeout = MethodSerializer
+    { methodTimeout = getTimeout
+    , method = AnnounceType
+    , wrapQuery = \(TransactionId n8 n24) src dst req ->
+        -- :: tid -> addr -> addr -> a -> OnionMessage Identity
+        OnionAnnounce $ Assym
+            { -- The public key is our real long term public key if we want to
+              -- announce ourselves, a temporary one if we are searching for
+              -- friends.
+              senderKey = fromJust $ onionKey src -- TODO: FIXME: this should be a temporary alias key
+            , assymNonce = n24
+            , assymData = Identity (req, n8)
+            }
+    , unwrapResponse = \case -- :: OnionMessage Identity -> b
+        OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
+        _                              -> Nothing
+    }
+
+unwrapAnnounceResponse :: AnnounceResponse -> ([NodeInfo], [PublicKey], Maybe Nonce32)
+unwrapAnnounceResponse (AnnounceResponse is_stored (SendNodes ns))
+    = case is_stored of
+        NotStored n32    -> (ns, [],  Just n32)
+        SendBackKey k    -> (ns, [k], Nothing)
+        Acknowledged n32 -> (ns, [],  Just n32)
+
+announce :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> Client r
+            -> NodeId
+            -> NodeInfo
+            -> IO (Maybe ([NodeInfo],[PublicKey],Maybe Nonce32))
+announce getTimeout client nid ni =
+    -- Four tries and then we tap out.
+    flip fix 4 $ \loop n -> do
+    let oaddr = OnionDestination ni Nothing
+    mb <- QR.sendQuery client (announceSerializer getTimeout) (AnnounceRequest zeros32 nid zeroID) oaddr
+    maybe (if n>0 then loop $! n - 1 else return Nothing)
+          (return . Just . unwrapAnnounceResponse)
+          $ join mb
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index a3c1950f..b5ac748a 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -35,6 +35,8 @@ module Network.Tox.Onion.Transport
     , peelSymmetric
     , OnionRoute(..)
     , N3
+    , onionKey
+    , onionNodeInfo
     ) where
 
 import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
@@ -42,10 +44,11 @@ import Network.QueryResponse
 import Crypto.Tox hiding (encrypt,decrypt)
 import Network.Tox.NodeId
 import qualified Crypto.Tox as ToxCrypto
-import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes,nodeInfo,DHTPublicKey,asymNodeInfo)
+import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey,asymNodeInfo)
 
 import Debug.Trace
 import Control.Arrow
+import Control.Applicative
 import Control.Concurrent.STM
 import Control.Monad
 import qualified Data.ByteString  as B
@@ -88,14 +91,23 @@ deriving instance ( Show (f (AnnounceRequest, Nonce8))
                   , Show (f DataToRoute)
                   ) => Show (OnionMessage f)
 
+msgNonce :: OnionMessage f -> Nonce24
+msgNonce (OnionAnnounce a)               = assymNonce a
+msgNonce (OnionAnnounceResponse _ n24 _) = n24
+msgNonce (OnionToRoute _ a)              = assymNonce a
+msgNonce (OnionToRouteResponse a)        = assymNonce a
+
 data OnionDestination r
     = OnionToOwner     NodeInfo (ReturnPath N3) -- ^ Somebody else's path to us.
     | OnionDestination NodeInfo (Maybe r)       -- ^ Our own onion-path.
     deriving Show
 
+onionNodeInfo :: OnionDestination r -> NodeInfo
+onionNodeInfo (OnionToOwner     ni _) = ni
+onionNodeInfo (OnionDestination ni _) = ni
+
 onionKey :: OnionDestination r -> Maybe PublicKey
-onionKey (OnionToOwner     ni _) = Just $ id2key (nodeId ni)
-onionKey (OnionDestination ni _) = Just $ id2key (nodeId ni)
+onionKey od = Just $ id2key . nodeId $ onionNodeInfo od
 
 instance Sized (OnionMessage Encrypted) where
     size = VarSize $ \case
@@ -176,11 +188,19 @@ encodeOnionAddr :: (NodeInfo -> r -> IO (Maybe OnionRoute))
 encodeOnionAddr _ (msg,OnionToOwner ni p) =
     return $ Just ( runPut $ putResponse (OnionResponse p msg)
                   , nodeAddr ni )
-encodeOnionAddr _        (msg,OnionDestination _  Nothing   ) = return Nothing
+encodeOnionAddr _        (msg,OnionDestination _  Nothing   ) = do
+    hPutStrLn stderr $ "ONION encode missing routeid"
+    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
+    let go route0 = do
+            let route = route0 { routeNonce = msgNonce msg } -- TODO: This necessary?
+            return ( runPut $ putRequest $ wrapForRoute msg ni route
+                   , nodeAddr $ routeNodeA route)
+        mapM' f x = do
+            hPutStrLn stderr $ "ONION encode sending to  " ++ show ni
+            hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (mapM (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x)
+            mapM f x
+    getRoute ni rid >>= mapM' go
 
 
 forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport
@@ -239,16 +259,19 @@ deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
 instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
          , Sized (ReturnPath n)
          , Serialize (ReturnPath n)
+         , Typeable n
          ) => Serialize (OnionRequest n) where
     get = do
         -- TODO share code with 'getOnionRequest'
-        n24 <- get
+        n24 <- case eqT :: Maybe (n :~: N3) of
+                Just Refl -> return $ Nonce24 zeros24
+                Nothing   -> get
         cnt <- remaining
         let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n
         fwd <- isolate fwdsize get
         rpath <- get
         return $ OnionRequest n24 fwd rpath
-    put (OnionRequest n f p) = put n >> put f >> put p
+    put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p
 
 -- getRequest :: _
 -- getRequest = OnionRequest <$> get <*> get <*> get
@@ -402,6 +425,7 @@ handleOnionRequest :: forall a proxy n.
                       ( LessThanThree n
                       , KnownPeanoNat n
                       , Sized (ReturnPath n)
+                      , Typeable n
                       ) => proxy n -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionRequest n -> IO a
 handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
     let n = peanoVal rpath
@@ -414,7 +438,7 @@ handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) =
             hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e]
             kont
         Right (Addressed dst msg') -> do
-            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "SUCCESS"]
+            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "-->", either show show (either4or6 dst), "SUCCESS"]
             sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
             kont
 
@@ -472,9 +496,13 @@ getOnionRequest = do
     path <- get
     return (a,path)
 
-putRequest :: (KnownPeanoNat n, Serialize (OnionRequest n)) => OnionRequest n -> Put
+putRequest :: ( KnownPeanoNat n
+              , Serialize (OnionRequest n)
+              , Typeable n
+              ) => OnionRequest n -> Put
 putRequest req = do
-    putWord8 $ 0x80 + fromIntegral (peanoVal req)
+    let tag = 0x80 + fromIntegral (peanoVal req)
+    when (tag <= 0x82) (putWord8 tag)
     put req
 
 putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put
@@ -513,9 +541,14 @@ data AnnounceResponse = AnnounceResponse
 instance Sized AnnounceResponse where
     size = contramap is_stored size <> contramap announceNodes size
 
+getNodeList :: S.Get [NodeInfo]
+getNodeList = do
+    n <- S.get
+    (:) n <$> (getNodeList <|> pure [])
+
 instance S.Serialize AnnounceResponse where
-    get = AnnounceResponse <$> S.get <*> S.get
-    put (AnnounceResponse st ns) = S.put st >> S.put ns
+    get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList)
+    put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns
 
 data DataToRoute = DataToRoute
     { dataFromKey :: PublicKey -- Real public key of sender