Implemented "dhtkey" publish method.

7 files changed, 140 insertions, 34 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 324146c1..aebf16cc 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -107,8 +107,9 @@ data DHTQuery nid ni = forall addr r tok.
     , qshowTok :: tok -> Maybe String
     }
 
-data DHTAnnouncable nid ni = forall dta r. Show r => DHTAnnouncable
+data DHTAnnouncable = forall dta ni r. Show r => DHTAnnouncable
     { announceParseData :: String -> String -> IO (Either String dta)
+    , announceParseAddress :: String -> Either String ni
     , announceSendData :: dta -> Maybe ni -> IO (Maybe r)
     }
 
@@ -135,7 +136,7 @@ data DHT = forall nid ni. ( Show     ni
     { dhtBuckets       :: TVar (BucketList ni)
     , dhtPing          :: ni -> IO Bool
     , dhtQuery         :: Map.Map String (DHTQuery nid ni)
-    , dhtAnnouncables  :: Map.Map String (DHTAnnouncable nid ni)
+    , dhtAnnouncables  :: Map.Map String DHTAnnouncable
     , dhtParseId       :: String -> Either String nid
     , dhtSearches      :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
     , dhtFallbackNodes :: IO [ni]
@@ -465,7 +466,7 @@ clientSession s@Session{..} sock cnum h = do
                               where
                                 go | null destination = fmap (maybe (Left "Timeout.") Right)
                                                         . flip announceSendData Nothing
-                                   | otherwise        = case readEither destination of
+                                   | otherwise        = case announceParseAddress destination of
                                         Right ni -> fmap (maybe (Left "Timeout.") Right)
                                                     . flip announceSendData (Just ni)
                                         Left  e  -> const $ return $ Left ("Bad destination: "++e)
@@ -641,6 +642,7 @@ main = do
                                     [ ("peer", DHTAnnouncable { announceSendData = \dta -> \case
                                                                     Just ni -> Mainline.announce bt dta ni
                                                                     Nothing -> return Nothing
+                                                              , announceParseAddress = readEither
                                                               , announceParseData = \str tokstr -> do
                                                                     port <- atomically $ readTVar peerPort
                                                                     let ih = read str
@@ -648,6 +650,7 @@ main = do
                                                                     return $ Right $ Mainline.mkAnnounce port ih tok
                                                               })
                                     , ("port", DHTAnnouncable { announceParseData = \portstr _ -> return $ readEither portstr
+                                                              , announceParseAddress = const $ Right ()
                                                               , announceSendData = \dta -> \case
                                                                     Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
                                                                                   return $ Just dta
@@ -718,6 +721,7 @@ main = do
                                                                             (token :: Nonce32)
                                                                             ni
                                                                     Nothing -> return Nothing
+                                                               , announceParseAddress = readEither
                                                                , announceParseData = \str tokstr -> do
                                                                     r <- return $ do
                                                                         pubkey <- Tox.id2key <$> readEither str
@@ -725,6 +729,22 @@ main = do
                                                                         Right (pubkey :: PublicKey, tok :: Nonce32)
                                                                     hPutStrLn stderr ("PARSED(toxid): "++show (fmap (Control.Arrow.first Tox.key2id) r))
                                                                     return r
+                                                               })
+                                    , ("dhtkey", DHTAnnouncable { announceSendData = \(pubkey,()) -> \case
+                                                                    Just addr -> do
+                                                                        dkey <- Tox.getContactInfo tox
+                                                                        sendMessage
+                                                                            (Tox.toxToRoute tox)
+                                                                            (addr :: Tox.AnnouncedRendezvous)
+                                                                            (pubkey,Tox.OnionDHTPublicKey dkey)
+                                                                        return $ Just ()
+                                                                    Nothing -> return Nothing
+                                                               , announceParseAddress = readEither
+                                                               , announceParseData = \str _ -> do
+                                                                    r <- return $ do
+                                                                        pubkey <- Tox.id2key <$> readEither str
+                                                                        Right (pubkey :: PublicKey, ())
+                                                                    return r
                                                                })]
                     }
                 dhts = Map.fromList $
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index eb4c6027..c0e1dee0 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -196,7 +196,7 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
         mkclient (tbl,var) handlers =
             let client = Client
                     { clientNet           = addHandler eprinter (handleMessage client) $ modifynet client net
-                    , clientDispatcher    = dispatch tbl var handlers -- (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers)
+                    , clientDispatcher    = dispatch tbl var handlers
                     , clientErrorReporter = eprinter { reportTimeout = reportTimeout ignoreErrors }
                     , clientPending       = var
                     , clientAddress       = selfAddr
@@ -208,7 +208,7 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
 data Tox = Tox
     { toxDHT :: DHT.Client
     , toxOnion :: Onion.Client RouteId
-    , toxToRoute :: Transport String Onion.Rendezvous Onion.DataToRoute
+    , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
     , toxCrypto :: Transport String SockAddr NetCrypto
     , toxCryptoKeys :: TransportCrypto
     , toxRouting :: DHT.Routing
@@ -217,6 +217,26 @@ data Tox = Tox
     , toxOnionRoutes :: OnionRouter
     }
 
+getContactInfo :: Tox -> IO DHT.DHTPublicKey
+getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
+    r4 <- readTVar $ DHT.routing4 toxRouting
+    r6 <- readTVar $ DHT.routing6 toxRouting
+    nonce <- transportNewNonce toxCryptoKeys
+    let self = nodeId n4
+        n4 = R.thisNode r4
+        n6 = R.thisNode r6
+        n4s = R.kclosest DHT.toxSpace 4 self r4
+        n6s = R.kclosest DHT.toxSpace 4 self r6
+        ns = filter (DHT.isGlobal . nodeIP) [n4,n6]
+              ++ concat (zipWith (\a b -> [a,b]) n4s n6s)
+    return $ do
+    timestamp <- round . (* 1000000) <$> getPOSIXTime
+    return DHT.DHTPublicKey
+        { dhtpkNonce = timestamp
+        , dhtpk      = id2key self
+        , dhtpkNodes = DHT.SendNodes $ take 4 ns
+        }
+
 isLocalHost :: SockAddr -> Bool
 isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001)
 isLocalHost _                       = False
diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs
index 5bd9caa1..0787c2c1 100644
--- a/src/Network/Tox/DHT/Transport.hs
+++ b/src/Network/Tox/DHT/Transport.hs
@@ -43,6 +43,7 @@ import Data.Monoid
 import Data.Serialize             as S
 import Data.Tuple
 import Data.Word
+import Foreign.C (CTime(..))
 import Network.Socket
 
 type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)
@@ -201,7 +202,11 @@ instance Serialize DHTRequest where
 -- | `32`        | Our DHT public key                  |
 -- | `[39, 204]` | Maximum of 4 nodes in packed format |
 data DHTPublicKey = DHTPublicKey
-    { dhtpkNonce :: Nonce8    -- no_replay
+    { dhtpkNonce :: Word64    -- ^ The `no_replay` number is protection if
+                              -- someone tries to replay an older packet and
+                              -- should be set to an always increasing number.
+                              -- It is 8 bytes so you should set a high
+                              -- resolution monotonic time as the value.
     , dhtpk      :: PublicKey -- dht public key
     , dhtpkNodes :: SendNodes -- other reachable nodes
     }
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
index 0c137bf5..3eec0390 100644
--- a/src/Network/Tox/Onion/Handlers.hs
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -242,14 +242,6 @@ sendOnion getTimeout client req oaddr unwrap =
           $ join mb
 
 -- | Lookup the secret counterpart for a given alias key.
-selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector
-selectAlias crypto pkey = do
-        ks <- filter (\(sk,pk) -> pk == id2key pkey)
-                                <$> readTVar (userKeys crypto)
-        maybe (return SearchingAlias)
-              (return . uncurry AnnouncingAlias)
-              (listToMaybe ks)
-
 getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
             -> TransportCrypto
             -> Client r
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 4c3de3e6..6635fad1 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -25,6 +25,8 @@ module Network.Tox.Onion.Transport
     , OnionMessage(..)
     , Rendezvous(..)
     , DataToRoute(..)
+    , OnionData(..)
+    , AnnouncedRendezvous(..)
     , AnnounceResponse(..)
     , AnnounceRequest(..)
     , Forwarding(..)
@@ -41,6 +43,7 @@ module Network.Tox.Onion.Transport
     , N3
     , onionKey
     , onionAliasSelector
+    , selectAlias
     ) where
 
 import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
@@ -50,13 +53,12 @@ import Network.Tox.NodeId
 import qualified Crypto.Tox as ToxCrypto
 import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey,FriendRequest,asymNodeInfo)
 
-import Debug.Trace
-import Control.Arrow
 import Control.Applicative
+import Control.Arrow
 import Control.Concurrent.STM
 import Control.Monad
-import qualified Data.ByteString  as B
-         ;import Data.ByteString  (ByteString)
+import qualified Data.ByteString    as B
+         ;import Data.ByteString    (ByteString)
 import Data.Coerce
 import Data.Function
 import Data.Functor.Contravariant
@@ -64,14 +66,16 @@ import Data.Functor.Identity
 import Data.IP
 import Data.Maybe
 import Data.Monoid
-import Data.Serialize             as S
+import Data.Serialize               as S
 import Data.Type.Equality
 import Data.Typeable
 import Data.Word
-import GHC.Generics               ()
+import Debug.Trace
+import GHC.Generics                 ()
 import GHC.TypeLits
 import Network.Socket
 import System.IO
+import qualified Text.ParserCombinators.ReadP as RP
 
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
@@ -609,6 +613,15 @@ instance Sized OnionData where
             ConstSize n -> n
             VarSize f   -> f req
 
+instance Serialize OnionData where
+    get = do
+        tag <- get
+        case tag :: Word8 of
+            0x9c -> OnionDHTPublicKey <$> get
+            0x20 -> OnionFriendRequest <$> get
+            _    -> fail $ "Unknown onion data: "++show tag
+    put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk
+    put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr
 
 selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey)
 selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _)
@@ -731,30 +744,86 @@ data Rendezvous = Rendezvous
  deriving Eq
 
 instance Show Rendezvous where
-    show (Rendezvous k ni) = concat [show $ key2id k, ":", show ni]
-
+    showsPrec d (Rendezvous k ni)
+        = showsPrec d (key2id k)
+          . (':' :)
+          . showsPrec d ni
+
+data AnnouncedRendezvous = AnnouncedRendezvous
+    { remoteUserKey :: PublicKey
+    , rendezvous :: Rendezvous
+    }
+  deriving Eq
+
+instance Show AnnouncedRendezvous where
+    showsPrec d (AnnouncedRendezvous remote rendez)
+        = showsPrec d (key2id remote)
+          . (':' :)
+          . showsPrec d rendez
+
+instance Read AnnouncedRendezvous where
+    readsPrec d = RP.readP_to_S $ do
+        ukstr <- RP.munch (/=':')
+        RP.char ':'
+        rkstr <- RP.munch (/=':')
+        RP.char ':'
+        nistr <- RP.munch (const True)
+        return AnnouncedRendezvous
+            { remoteUserKey = id2key $ read ukstr
+            , rendezvous = Rendezvous
+                { rendezvousKey = id2key $ read rkstr
+                , rendezvousNode = read nistr
+                }
+            }
+
+
+selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector
+selectAlias crypto pkey = do
+        ks <- filter (\(sk,pk) -> pk == id2key pkey)
+                                <$> readTVar (userKeys crypto)
+        maybe (return SearchingAlias)
+              (return . uncurry AnnouncingAlias)
+              (listToMaybe ks)
 
 
 parseDataToRoute
     :: TransportCrypto
          -> (OnionMessage Encrypted,OnionDestination r)
-         -> IO (Either (DataToRoute,Rendezvous) (OnionMessage Encrypted, OnionDestination r))
+         -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r))
 parseDataToRoute crypto (OnionToRouteResponse dta, od) =
     return $ either (const $ Right (OnionToRouteResponse dta,od)) Left $ do
         -- XXX: Do something with decryption failure?
-        decrypted <- uncomposed
-             $ decryptMessage (rendezvousSecret crypto,rendezvousPublic crypto)
-                              (asymmNonce dta)
-                              (Right dta)
-        return ( runIdentity decrypted
-               , Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od )
+        dtr <- fmap runIdentity
+                 $ uncomposed
+                 $ decryptMessage (rendezvousSecret crypto,rendezvousPublic crypto)
+                                  (asymmNonce dta)
+                                  (Right dta)
+        let (sk,pk) = case onionAliasSelector od of
+                SearchingAlias        -> (onionAliasSecret &&& onionAliasPublic) crypto
+                AnnouncingAlias sk pk -> (sk,pk)
+        omsg <- fmap runIdentity
+                $ uncomposed
+                $ decryptMessage (sk,pk)
+                                 (asymmNonce dta)
+                                 (Left (dataFromKey dtr, dataToRoute dtr))
+        return ( (pk, omsg)
+               , AnnouncedRendezvous
+                    (dataFromKey dtr)
+                    $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od )
 parseDataToRoute _ msg = return $ Right msg
 
 encodeDataToRoute :: TransportCrypto
-                     -> (DataToRoute,Rendezvous)
+                     -> ((PublicKey,OnionData),AnnouncedRendezvous)
                      -> IO (Maybe (OnionMessage Encrypted,OnionDestination r))
-encodeDataToRoute crypto (plain, Rendezvous pub ni) = do
+encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub ni)) = do
     nonce <- atomically $ transportNewNonce crypto
+    asel <- atomically $ selectAlias crypto (key2id me)
+    let (sk,pk) = case asel of
+            AnnouncingAlias sk pk -> (sk,pk)
+            _                     -> (onionAliasSecret crypto, onionAliasPublic crypto)
+    let plain = DataToRoute { dataFromKey = pk
+                            , dataToRoute = encryptMessage sk toxid nonce omsg
+                            }
     let dta = encryptMessage (onionAliasSecret crypto) pub nonce plain
     return $ Just ( OnionToRoute pub -- Public key of destination node
                                  Asymm { senderKey  = onionAliasPublic crypto
diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs
index 2a4e7eee..5cda1524 100644
--- a/src/Network/Tox/Transport.hs
+++ b/src/Network/Tox/Transport.hs
@@ -24,7 +24,7 @@ toxTransport ::
           -> UDPTransport
           -> IO ( Transport String NodeInfo (DHTMessage Encrypted8)
                 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
-                , Transport String Rendezvous DataToRoute
+                , Transport String AnnouncedRendezvous (PublicKey,OnionData)
                 , Transport String SockAddr NetCrypto )
 toxTransport crypto orouter closeLookup udp = do
     (dht,udp1) <- partitionTransport parseDHTAddr (Just . encodeDHTAddr) $ forwardOnions crypto udp
diff --git a/todo.txt b/todo.txt
index cb1ccfba..575ed16b 100644
--- a/todo.txt
+++ b/todo.txt
@@ -60,9 +60,9 @@ p - put/publish a single given datum on a single given node.
 
             p toxid <key-pair> <token> [node-addr]
 
-            p friend <nospam> <rendezvous-addr> <text>
+            p friend <key-pair> <nospam> <rendezvous-addr> <text>
 
-            p dhtkey <rendezvous-addr>
+            p dhtkey <key-pair> - <rendezvous-addr>
 
 a - announce, like put/publish but automatically selects nodes to publish on
     and continually refreshes the records.