Initialize Tox secret key.

5 files changed, 56 insertions, 11 deletions

diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs
index d94f028f..b775e7d3 100644
--- a/src/Network/BitTorrent/DHT/Session.hs
+++ b/src/Network/BitTorrent/DHT/Session.hs
@@ -116,6 +116,7 @@ import Data.Text as Text
 import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
 import Data.Serialize as S
 import Network.DHT.Types
+import Network.DatagramServer.Types
 
 
 import Data.Torrent as Torrent
@@ -343,10 +344,12 @@ locFromCS cs = case getCallStack cs of
 -- | Run DHT session. You /must/ properly close session using
 -- 'closeNode' function, otherwise socket or other scarce resources may
 -- leak.
-newNode :: ( Address ip
+newNode :: forall raw dht ip u.
+           ( Address ip
            , FiniteBits (NodeId dht)
            , Serialize (NodeId dht)
            , Kademlia dht
+           , WireFormat raw dht
            )
           => -- [NodeHandler] -- ^ handlers to run on accepted queries;
              Options       -- ^ various dht options;
@@ -363,13 +366,18 @@ newNode opts naddr logger mbid = do
     nodeAddr = toSockAddr naddr
     initNode = do
       s      <- getInternalState
-      (_, m) <- allocate (newManager rpcOpts (logt logger) nodeAddr []) closeManager
+      (myId, infovar, getst) <- liftIO $ do
+        (i, ctx) <- initializeServerState (Proxy :: Proxy (dht raw)) mbid
+        var <- atomically (newTVar Nothing)
+        let getst dest = do
+              info <- atomically . readTVar $ var
+              return ( maybe i myNodeId info, ctx)
+        return (i, var, getst)
+      (_, m) <- allocate (newManager rpcOpts (logt logger) nodeAddr getst []) closeManager
       liftIO $ do
         dta <- initializeDHTData
-        myId   <- maybe genNodeId return mbid
-        node   <- Node opts myId s m
-                <$> atomically (newTVar Nothing)
-                <*> newTVarIO S.empty
+        node   <- Node opts myId s m infovar
+                <$> newTVarIO S.empty
                 <*> pure dta
                 <*> pure logger
         return node
diff --git a/src/Network/DatagramServer.hs b/src/Network/DatagramServer.hs
index ca968a8c..8c4ec928 100644
--- a/src/Network/DatagramServer.hs
+++ b/src/Network/DatagramServer.hs
@@ -199,6 +199,7 @@ data Manager raw msg = Manager
   , pendingCalls       :: {-# UNPACK #-} !(PendingCalls msg raw)
   -- , handlers           :: [Handler h msg raw] -- TODO delete this, it's not used
   , logMsg             :: Char -> String -> T.Text -> IO ()
+  , serverState        :: PacketDestination msg -> IO (NodeId msg, CipherContext raw msg)
   }
 
 sockAddrFamily :: SockAddr -> Family
@@ -212,15 +213,16 @@ sockAddrFamily (SockAddrCan _        ) = AF_CAN
 newManager :: Options                       -- ^ various protocol options;
            -> (Char -> String -> T.Text -> IO ()) -- ^ loging function
            -> SockAddr                      -- ^ address to listen on;
+           -> ( PacketDestination msg -> IO (NodeId msg, CipherContext raw msg) )
            -> [Handler h msg raw] -- ^ handlers to run on incoming queries.
            -> IO (Manager raw msg)                -- ^ new rpc manager.
-newManager opts @ Options {..} logmsg servAddr handlers = do
+newManager opts @ Options {..} logmsg servAddr getst handlers = do
     validateOptions opts
     sock  <- bindServ
     tref  <- newEmptyMVar
     tran  <- newIORef optSeedTransaction
     calls <- newIORef M.empty
-    return $ Manager sock opts tref tran calls logmsg
+    return $ Manager sock opts tref tran calls logmsg getst
   where
     bindServ = do
       let family = sockAddrFamily servAddr
@@ -377,8 +379,7 @@ queryK mgr@Manager{..} dest params kont = do
   mres <- liftIO $ do
     ares <- registerQuery (tid, addr) pendingCalls
 
-    let cli = error "TODO TOX client node id"
-        ctx = error "TODO TOX ToxCipherContext or () for Mainline"
+    (cli,ctx) <- serverState dest
     q <- buildQuery cli addr meth tid params
     let qb = encodePayload (q :: msg a) :: msg raw
         qbs = encodeHeaders ctx qb dest
diff --git a/src/Network/DatagramServer/Mainline.hs b/src/Network/DatagramServer/Mainline.hs
index 1f07b13f..fea64ee6 100644
--- a/src/Network/DatagramServer/Mainline.hs
+++ b/src/Network/DatagramServer/Mainline.hs
@@ -51,6 +51,7 @@ module Network.DatagramServer.Mainline
        , KQueryArgs
        , QueryExtra(..)
        , ResponseExtra(..)
+       , PacketDestination(..)
 
        , NodeId(..)
        , nodeIdSize
@@ -347,6 +348,10 @@ instance WireFormat BValue KMessageOf where
     encodeHeaders _ kmsg _ = L.toStrict $ BE.encode kmsg
     encodePayload msg = fmap BE.toBEncode msg
 
+    initializeServerState _ mbid = do
+        i <- maybe genNodeId return mbid
+        return (i, ())
+
 -- | KRPC 'compact list' compatible encoding: contact information for
 -- nodes is encoded as a 26-byte string. Also known as "Compact node
 -- info" the 20-byte Node ID in network byte order has the compact
diff --git a/src/Network/DatagramServer/Tox.hs b/src/Network/DatagramServer/Tox.hs
index 8d2f9289..1763e74c 100644
--- a/src/Network/DatagramServer/Tox.hs
+++ b/src/Network/DatagramServer/Tox.hs
@@ -45,6 +45,7 @@ import Crypto.Error.Types
 import Data.Hashable
 import Text.PrettyPrint as PP hiding ((<>))
 import Text.PrettyPrint.HughesPJClass  hiding (($$), (<>))
+import Data.ByteArray (convert)
 
 
 type Key32   = Word256 -- 32 byte key
@@ -391,4 +392,10 @@ instance WireFormat ByteString Message where
     decodeHeaders ctx bs = runGet getMessage bs >>= decipher ctx
     encodeHeaders ctx msg recipient = runPut $ putMessage $ encipher ctx (toxID recipient) msg
 
+    initializeServerState _ _ = do
+        k <- generateSecretKey
+        let Right nid = S.decode $ convert $ toPublic k
+        return (nid, ToxCipherContext k)
+
+
 instance Read (NodeId Message) where readsPrec d s = map (\(w,xs) -> (NodeId w, xs)) $ decodeHex s
diff --git a/src/Network/DatagramServer/Types.hs b/src/Network/DatagramServer/Types.hs
index 14968764..6aa7aeaa 100644
--- a/src/Network/DatagramServer/Types.hs
+++ b/src/Network/DatagramServer/Types.hs
@@ -35,7 +35,7 @@ import Data.IP
 import Network.Socket
 import Text.PrettyPrint as PP hiding ((<>))
 import Text.PrettyPrint.HughesPJClass  hiding (($$), (<>))
-import Text.Read        (readMaybe)
+import Text.Read        (readMaybe, readEither)
 import Data.Serialize                  as S
 import qualified Data.ByteString.Char8 as Char8
 import qualified Data.ByteString as BS
@@ -43,6 +43,7 @@ import Data.ByteString.Base16          as Base16
 import System.Entropy
 import Network.DatagramServer.Error
 import Data.LargeWord
+import Data.Char
 
 
 class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
@@ -274,6 +275,26 @@ deriving instance ( Show (NodeId dht)
                   , Show addr
                   , Show u ) => Show (NodeInfo dht addr u)
 
+hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
+
+instance ( FiniteBits (NodeId dht)
+         , Read (NodeId dht)
+         , Read (NodeAddr addr)
+         , Default u
+         ) => Read (NodeInfo dht addr u) where
+  readsPrec i = RP.readP_to_S $ do
+    RP.skipSpaces
+    let n = finiteBitSize (undefined :: NodeId dht) `div` 4
+    hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
+    RP.char '@' RP.+++ RP.satisfy isSpace
+    addrstr <- RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
+                RP.+++ RP.munch (not . isSpace)
+    addr <- either fail return $ readEither addrstr
+    nid <- either fail return $ readEither hexhash
+    return $ NodeInfo nid addr def
+
+
+
 mapAddress :: (addr -> b) -> NodeInfo dht addr u -> NodeInfo dht b u
 mapAddress f ni = ni { nodeAddr = fmap f (nodeAddr ni) }
 
@@ -348,6 +369,9 @@ class (Envelope envelope, Address (PacketDestination envelope)) => WireFormat ra
     encodeHeaders :: CipherContext raw envelope -> envelope raw -> PacketDestination envelope -> ByteString
     encodePayload :: SerializableTo raw a => envelope a -> envelope raw
 
+    initializeServerState :: Proxy (envelope raw) -> Maybe (NodeId envelope) -> IO (NodeId envelope, CipherContext raw envelope)
+
+
 encodeHexDoc :: Serialize x => x -> Doc
 encodeHexDoc nid = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid