2 files changed, 269 insertions, 111 deletions

diff --git a/Tox.hs b/Tox.hs
index 8ee065d6..a14e223b 100644
--- a/Tox.hs
+++ b/Tox.hs
@@ -7,71 +7,78 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
 module Tox where
 
 import Control.Applicative
 import Control.Arrow
-import Control.Concurrent (MVar)
+import Control.Concurrent                     (MVar)
 import Control.Concurrent.STM
-import qualified Crypto.Cipher.Salsa    as Salsa
-import qualified Crypto.Cipher.XSalsa   as XSalsa
+import Control.Monad
+import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
+import qualified Crypto.Cipher.Salsa          as Salsa
+import qualified Crypto.Cipher.XSalsa         as XSalsa
 import Crypto.ECC.Class
-import qualified Crypto.Error           as Cryptonite
+import qualified Crypto.Error                 as Cryptonite
 import Crypto.Error.Types
-import qualified Crypto.MAC.Poly1305    as Poly1305
+import qualified Crypto.MAC.Poly1305          as Poly1305
 import Crypto.PubKey.Curve25519
 import Crypto.PubKey.ECC.Types
 import Crypto.Random
+import qualified Data.Aeson                   as JSON
+         ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
+import Data.Bitraversable                     (bisequence)
+import Data.Bits
+import Data.Bits.ByteString                   ()
 import Data.Bool
 import qualified Data.ByteArray               as BA
-         ;import Data.ByteArray               (ByteArrayAccess,Bytes)
+         ;import Data.ByteArray               (ByteArrayAccess, Bytes)
 import qualified Data.ByteString              as B
          ;import Data.ByteString              (ByteString)
-import qualified Data.ByteString.Base16 as Base16
-import qualified Data.ByteString.Char8  as C8
-import Data.ByteString.Lazy             (toStrict)
+import qualified Data.ByteString.Base16       as Base16
+import qualified Data.ByteString.Char8        as C8
+import Data.ByteString.Lazy                   (toStrict)
+import Data.Char
 import Data.Data
+import Data.Hashable
 import Data.IP
 import Data.Maybe
+import qualified Data.MinMaxPSQ               as MinMaxPSQ
+         ;import Data.MinMaxPSQ               (MinMaxPSQ')
 import Data.Monoid
-import qualified Data.Serialize         as S
+import Data.Ord
+import qualified Data.Serialize               as S
+import Data.Time.Clock.POSIX                  (POSIXTime, getPOSIXTime)
 import Data.Typeable
 import Data.Word
+import qualified Data.Wrapper.PSQ             as PSQ
+         ;import Data.Wrapper.PSQ             (PSQ)
+import qualified Data.Wrapper.PSQInt          as Int
 import Foreign.Marshal.Alloc
 import Foreign.Ptr
 import Foreign.Storable
-import GHC.Generics                     (Generic)
-import Network.Address                  (Address, fromSockAddr, sockAddrPort, testIdBit,
-                                         toSockAddr, setPort, un4map, WantIP(..), ipFamily,
-                                         either4or6)
+import GHC.Generics                           (Generic)
+import Global6
+import Kademlia
+import Network.Address                        (Address, WantIP (..), either4or6,
+                                               fromSockAddr, ipFamily, setPort,
+                                               sockAddrPort, testIdBit,
+                                               toSockAddr, un4map)
+import Network.BitTorrent.DHT.Search          (Search (..))
+import qualified Network.DHT.Routing          as R
 import Network.QueryResponse
 import Network.Socket
 import System.Endian
-import Data.Hashable
-import Data.Bits
-import Data.Bits.ByteString ()
-import qualified Text.ParserCombinators.ReadP as RP
-import Data.Char
-import TriadCommittee
-import qualified Network.DHT.Routing          as R
-import qualified Data.Wrapper.PSQInt          as Int
-import Data.Time.Clock.POSIX                  (POSIXTime)
-import Global6
-import Data.Ord
 import System.IO
-import qualified Data.Aeson as JSON
-         ;import Data.Aeson (FromJSON, ToJSON, (.=))
-import Control.Monad
-import Text.Read
-import Kademlia
-import Network.BitTorrent.DHT.Search          (Search (..))
+import qualified Text.ParserCombinators.ReadP as RP
 import Text.Printf
-import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
-import Data.Bitraversable (bisequence)
-import ToxMessage (quoted,bin2hex)
-import qualified ToxMessage as Tox
+import Text.Read
+import qualified ToxMessage                   as Tox
+         ;import ToxMessage                   (bin2hex, quoted)
+import TriadCommittee
+import Network.BitTorrent.DHT.Token           as Token
 
 {-
 newtype NodeId = NodeId ByteString
@@ -224,7 +231,7 @@ nodeInfo nid saddr
     | otherwise                       = Left "Address family not supported."
 
 data TransactionId = TransactionId
- { transactionKey :: Nonce8  -- ^ Used to lookup pending query.
+ { transactionKey :: Tox.Nonce8  -- ^ Used to lookup pending query.
  , cryptoNonce    :: Tox.Nonce24 -- ^ Used during the encryption layer.
  }
 
@@ -247,8 +254,7 @@ pattern OnionRequest0 = Tox.PacketKind 128 -- 0x80     Onion Request 0
 pattern OnionRequest1 = Tox.PacketKind 129 -- 0x81     Onion Request 1
 pattern OnionRequest2 = Tox.PacketKind 130 -- 0x82     Onion Request 2
 pattern AnnounceType  = Tox.PacketKind 131 -- 0x83     Announce Request
-
--- 0x84     Announce Response
+pattern AnnounceResponseType = Tox.PacketKind 132 -- 0x84     Announce Response
 -- 0x85     Onion Data Request (data to route request packet)
 -- 0x86     Onion Data Response (data to route response packet)
 -- 0x8c     Onion Response 3
@@ -276,19 +282,6 @@ instance Show Tox.PacketKind where
     showsPrec d AnnounceType    = mappend "AnnounceType"
     showsPrec d (Tox.PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
 
-newtype Nonce8 = Nonce8 Word64
- deriving (Eq, Ord, S.Serialize)
-
-instance ByteArrayAccess Nonce8 where
-    length _ = 8
-    withByteArray (Nonce8 w64) kont =
-        allocaBytes 8 $ \p -> do
-            poke (castPtr p :: Ptr Word64) $ toBE64 w64
-            kont p
-
-instance Show Nonce8 where
-    showsPrec d nonce = quoted (mappend $ bin2hex nonce)
-
 {-
 newtype Tox.Nonce24 = Tox.Nonce24 ByteString
  deriving (Eq, Ord, ByteArrayAccess)
@@ -319,7 +312,7 @@ data Msg = Msg
     { msgType     :: Tox.PacketKind
     , msgNonce    :: Tox.Nonce24
     , msgData     :: ByteString
-    , msgSendBack :: Nonce8
+    , msgSendBack :: Tox.Nonce8
     }
  deriving Show
 
@@ -400,7 +393,7 @@ putMessage (Message {..}) = do
 
 {-
 data Plain a = Plain
-    { plainId      :: Nonce8 -- transactionKey of TransactionId
+    { plainId      :: Tox.Nonce8 -- transactionKey of TransactionId
     , plainPayload :: a
     }
  deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
@@ -426,11 +419,11 @@ key2id pk = case S.decode (BA.convert pk) of
                 Right nid -> nid
 
 
-zeros32 :: Bytes
-zeros32 = BA.replicate 32 0
+zeros32 :: Nonce32
+zeros32 = Nonce32 $ BA.replicate 32 0
 
-zeros24 :: Bytes
-zeros24 = BA.take 24 zeros32
+zeros24 :: ByteString
+zeros24 = BA.take 24 zs where Nonce32 zs = zeros32
 
 hsalsa20 k n = a <> b
  where
@@ -451,7 +444,7 @@ computeSharedSecret sk recipient nonce = (hash, crypt)
     -- cipher state
     st0 = XSalsa.initialize 20 k nonce
     -- Poly1305 key
-    (rs, crypt) = XSalsa.combine st0 zeros32
+    (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
     -- Since rs is 32 bytes, this pattern should never fail...
     Cryptonite.CryptoPassed hash = Poly1305.initialize rs
 
@@ -464,16 +457,25 @@ encryptMessage sk _ recipient plaintext
         else Left . OnionPayload <$> plaintext
 -}
 
-encryptAssymetric :: SecretKey -> NodeId -> NodeId -> Msg -> (Tox.PacketKind, Tox.Assymetric)
-encryptAssymetric sk pk recipient (Msg typ nonce plaintext sendback)
-    = ( typ
-      , Tox.Assymetric
-          { senderKey = pk
-          , sent = Tox.UnclaimedAssymetric
-                   { assymetricNonce = nonce
-                   , assymetricData  = withSecret encipherAndHash sk recipient nonce (plaintext <> S.encode sendback)
-                   }
-          } )
+encryptAssymetric :: SecretKey -> NodeId -> NodeId -> Msg -> Tox.Assymetric
+encryptAssymetric sk pk recipient (Msg typ nonce plaintext sendback) = assym
+ where
+    assym = Tox.Assymetric
+      { senderKey = pk
+      , sent = Tox.UnclaimedAssymetric
+           { assymetricNonce = nonce
+           , assymetricData  = withSecret encipherAndHash sk recipient nonce (plaintext <> S.encode sendback)
+           }
+      }
+
+encryptUnclm :: SecretKey -> NodeId -> NodeId -> Msg -> Tox.UnclaimedAssymetric
+encryptUnclm sk pk recipient (Msg typ nonce plaintext _) = unclm
+ where
+    unclm = Tox.UnclaimedAssymetric
+       { assymetricNonce = nonce
+       , assymetricData  = withSecret encipherAndHash sk recipient nonce plaintext
+       }
+
 
 {-
 decryptMessage :: SecretKey -> SecretsCache -> Message Ciphered -> Either String (Message ByteString)
@@ -481,15 +483,29 @@ decryptMessage sk _ ciphertext
     = mapM (withSecret decipherAndAuth sk (msgOrigin ciphertext) (msgNonce ciphertext)) ciphertext
 -}
 
-decryptAssymetric :: SecretKey -> (Tox.PacketKind, Tox.Assymetric) -> Either String Msg
-decryptAssymetric sk (typ,assym)
+decryptAssymetric :: SecretKey -> Tox.PacketKind -> Tox.Assymetric -> Either String Msg
+decryptAssymetric sk typ assym
     = f <$> withSecret decipherAndAuth sk
                                        (Tox.senderKey assym)
                                        nonce
                                        (Tox.assymetricData . Tox.sent $ assym)
  where
     nonce = Tox.assymetricNonce . Tox.sent $ assym
-    f bs = uncurry (Msg typ nonce) . second (either (const (Nonce8 0)) id . S.decode) $ B.splitAt (B.length bs - 8) bs
+    f bs = uncurry (Msg typ nonce)
+            . second (either (const (Tox.Nonce8 0)) id . S.decode)
+            $ B.splitAt (B.length bs - 8) bs
+
+{-
+decryptUnclm :: SecretKey -> Tox.PacketKind -> NodeId -> Tox.Nonce8 -> Tox.UnclaimedAssymetric -> Either String Msg
+decryptUnclm sk typ sender n8 unclm
+    = f <$> withSecret decipherAndAuth sk
+                                       sender
+                                       nonce
+                                       (Tox.assymetricData  unclm)
+ where
+    nonce = Tox.assymetricNonce unclm
+    f bs = Msg typ nonce bs n8
+-}
 
 withSecret f sk recipient nonce x = f hash crypt x
  where
@@ -544,7 +560,7 @@ unzipMessage msg = either (\x -> Left  msg { msgPayload = x })
 
 -- TODO:
 -- Represents the encrypted portion of a Tox packet.
--- data Payload a = Payload a !Nonce8
+-- data Payload a = Payload a !Tox.Nonce8
 --
 -- Generic packet type: Message (Payload ByteString)
 
@@ -565,22 +581,40 @@ encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache
 
 msgLayer :: SecretKey
             -> NodeId
-            -> Transport String NodeInfo (Tox.PacketKind,Tox.Assymetric)
+            -> Transport String NodeInfo (Tox.PacketKind,InterediateRep)
             -> Transport String NodeInfo Msg
 msgLayer sk pk = layerTransport parse serialize
  where
-    parse x addr = fmap (,addr) $ decryptAssymetric sk x
-    serialize x addr = (encryptAssymetric sk pk (nodeId addr) x, addr)
-
-asymLayer :: Transport String SockAddr Tox.Packet -> Transport String NodeInfo (Tox.PacketKind,Tox.Assymetric)
+    parse (typ,Assym  x)  addr = fmap (,addr) $ decryptAssymetric sk typ x
+    parse (typ,Assym' x)  addr = fmap (,addr) $ decryptAssymetric sk typ x
+    parse (typ,Unclm n x) addr = Right ( Msg typ (Tox.assymetricNonce x) (S.encode (Tox.assymetricData x)) n
+                                       , addr)
+    serialize x addr = case Tox.pktClass (msgType x) of
+        Tox.AssymetricClass      {} -> ((msgType x, Assym  $ encryptAssymetric sk pk (nodeId addr) x), addr)
+        Tox.AliasedClass         {} -> ((msgType x, Assym' $ encryptAssymetric sk pk (nodeId addr) x), addr)
+        Tox.NoncedUnclaimedClass {} -> ((msgType x, Unclm (msgSendBack x) $ encryptUnclm sk pk (nodeId addr) x),addr)
+
+data InterediateRep = Assym Tox.Assymetric
+                    | Assym' Tox.Assymetric
+                    | Unclm Tox.Nonce8 Tox.UnclaimedAssymetric
+
+asymLayer :: Transport String SockAddr Tox.Packet -> Transport String NodeInfo (Tox.PacketKind,InterediateRep)
 asymLayer = layerTransport parse serialize
  where
     parse x addr = case Tox.pktClass (Tox.pktKind x) of
-                    Tox.AssymetricClass top fromp -> fmap ((Tox.pktKind x,y),) $ nodeInfo (Tox.senderKey y) addr where y = fromp x
-
-    serialize (typ,assym) addr = (x,nodeAddr addr)
-        where x = case Tox.pktClass typ of
-                    Tox.AssymetricClass top _ -> top assym
+        Tox.AssymetricClass top fromp      -> go Tox.senderKey  fromp Assym
+        Tox.AliasedClass    top fromp      -> go Tox.senderKey  ((\(Tox.Aliased a) -> a) . fromp) Assym'
+        Tox.NoncedUnclaimedClass top fromp -> go (const zeroID) fromp (uncurry Unclm)
+      where go mkaddr fromp c = let y = fromp x
+                                in fmap ((Tox.pktKind x,c y),)
+                                    $ nodeInfo (mkaddr y) addr
+
+    serialize (typ,Assym assym) addr = (x,nodeAddr addr)
+        where x = case Tox.pktClass typ of Tox.AssymetricClass top _ -> top assym
+    serialize (typ,Assym' assym) addr = (x,nodeAddr addr)
+        where x = case Tox.pktClass typ of Tox.AliasedClass    top _ -> top (Tox.Aliased assym)
+    serialize (typ,Unclm nonce unclm) addr = (x,nodeAddr addr)
+        where x = case Tox.pktClass typ of Tox.NoncedUnclaimedClass top _ -> top nonce unclm
 
 toxLayer :: Transport String SockAddr ByteString -> Transport String SockAddr Tox.Packet
 toxLayer = layerTransport (\x addr -> (,addr) <$> S.decode x)
@@ -605,11 +639,13 @@ trimPackets :: SockAddr -> ByteString -> IO (Maybe (ByteString -> ByteString))
 trimPackets addr bs = do
     hPutStrLn stderr $ "GOT " ++ show (Tox.PacketKind (B.head bs))
     return $ case Tox.PacketKind (B.head bs) of
-                        PingType      -> Just id
-                        PongType      -> Just id
-                        SendNodesType -> Just id
-                        GetNodesType  -> Just id
-                        _             -> Nothing
+                        PingType             -> Just id
+                        PongType             -> Just id
+                        SendNodesType        -> Just id
+                        GetNodesType         -> Just id
+                        AnnounceType         -> Just id
+                        AnnounceResponseType -> Just id
+                        _                    -> Nothing
 
 newClient :: SockAddr -> IO (ToxClient, Routing)
 newClient addr = do
@@ -664,18 +700,23 @@ newClient addr = do
             let mapT = transactionMethods (contramapT nonceKey mapMethods) gen
             map_var <- atomically $ newTVar (drg, mempty)
             return $ Left (mapT,map_var)
+    keydb <- atomically $ newTVar $ AnnouncedKeys PSQ.empty MinMaxPSQ.empty
+    toks <- do
+        nil <- nullSessionTokens
+        atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
     let net = addHandler (handleMessage client)
               $ addVerbosity
               $ msgLayer secret pubkey
               $ onInbound (updateRouting client routing)
               $ asymLayer
+              -- $ addHandler (handleMessage aclient)
               $ toxLayer
               $ addVerbosity2
               $ addHandler trimPackets udp
 
-        dispatch tbl var = DispatchMethods
+        dispatch tbl var handlers = DispatchMethods
             { classifyInbound = classify
-            , lookupHandler = handlers var
+            , lookupHandler = handlers -- var
             , tableMethods = tbl
             }
 
@@ -685,8 +726,11 @@ newClient addr = do
 
 
         -- handlers :: TVar -> Method -> Maybe Handler
-        handlers var PingType       = handler PongType pingH
-        handlers var GetNodesType   = handler SendNodesType $ getNodesH routing
+        -- handlers :: forall h u. (TVar (h, u (MVar Msg)) -> Tox.PacketKind -> Maybe Handler)
+        handlers :: Tox.PacketKind -> Maybe Handler
+        handlers PingType       = handler PongType pingH
+        handlers GetNodesType   = handler SendNodesType $ getNodesH routing
+        handlers AnnounceType   = handler AnnounceResponseType $ announceH routing toks keydb
         {-
         handlers var OnionRequest0  = noreply OnionRequest0
                                       $ onionSend0H (symmetricCipher (return symkey)
@@ -697,28 +741,33 @@ newClient addr = do
                                       $ onionResponse1H (symmetricDecipher (return symkey))
                                                         udp
         -}
-        handlers var _              = Nothing
+        handlers _              = Nothing
         -- TODO DHTRequest public key (onion)
         -- TODO DHTRequest NAT ping
         -- TODO BootstrapInfo 0xf0
 
+        announceHandlers _ = Nothing
+
         genNonce24 var (TransactionId nonce8 _) = atomically $ do
             (g,pending) <- readTVar var
             let (bs, g') = randomBytesGenerate 24 g
             writeTVar var (g',pending)
             return $ TransactionId nonce8 (Tox.Nonce24 bs)
 
-        client = either mkclient mkclient tblvar
+        client = either mkclient mkclient tblvar handlers
 
         mkclient :: DRG g =>
                     ( TransactionMethods (g,t (MVar Msg))
                                          TransactionId
                                          Msg
                     , TVar (g, t (MVar Msg))
-                    ) -> ToxClient
-        mkclient (tbl,var) = Client
+                    )
+                    -- -> (forall h u. (TVar (h, u (MVar Msg)) -> Tox.PacketKind -> Maybe Handler))
+                    -> (Tox.PacketKind -> Maybe Handler)
+                    -> ToxClient
+        mkclient (tbl,var) handlers = Client
             { clientNet           = net
-            , clientDispatcher    = dispatch tbl var
+            , clientDispatcher    = dispatch tbl var handlers
             , clientErrorReporter = (printErrors stderr) { reportTimeout = reportTimeout ignoreErrors }
             , clientPending       = var
             , clientAddress       = \maddr -> atomically $ do
@@ -756,15 +805,15 @@ toxSpace = R.KademliaSpace
 
 
 {-
-last8 :: ByteString -> Nonce8
+last8 :: ByteString -> Tox.Nonce8
 last8 bs
     | let len = B.length bs
     , (len >= 8)
-      = Nonce8 $ let bs'     = B.drop (len - 8) bs
+      = Tox.Nonce8 $ let bs'     = B.drop (len - 8) bs
                      Right w = S.runGet S.getWord64be bs'
                  in w
     | otherwise
-      = Nonce8 0
+      = Tox.Nonce8 0
 
 dropEnd8 :: ByteString -> ByteString
 dropEnd8 bs = B.take (B.length bs - 8) bs
@@ -772,7 +821,7 @@ dropEnd8 bs = B.take (B.length bs - 8) bs
 
 data Payload a = Payload
     { payload :: a
-    , sendback :: Nonce8
+    , sendback :: Tox.Nonce8
     }
 
 instance S.Serialize a => S.Serialize (Payload a) where
@@ -826,7 +875,7 @@ classify (Msg { msgType     = typ
             _              -> const $ IsUnknown ("Unknown message type: "++show typ)
 
 {-
-encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b
+encodePayload typ (TransactionId (Tox.Nonce8 tid) nonce) self dest b
     = Message { msgType       = typ
               , msgOrigin     = nodeId self
               , msgNonce      = nonce
@@ -856,12 +905,13 @@ transitionCommittee committee (RoutingTransition ni Stranger) = do
         hPutStrLn stderr $ "delVote "++show (nodeId ni)
 transitionCommittee committee _ = return $ return ()
 
-updateRouting :: ToxClient -> Routing -> NodeInfo -> (Tox.PacketKind, Tox.Assymetric) -> IO ()
-updateRouting client routing naddr (typ,msg) = do
+updateRouting :: ToxClient -> Routing -> NodeInfo -> (Tox.PacketKind, InterediateRep) -> IO ()
+updateRouting client routing naddr (typ,Assym msg) = do
     hPutStrLn stderr $ "updateRouting "++show typ
     case prefer4or6 naddr Nothing of
         Want_IP4 -> updateTable client naddr (routing4 routing) (committee4 routing) (sched4 routing)
         Want_IP6 -> updateTable client naddr (routing6 routing) (committee6 routing) (sched6 routing)
+updateRouting _ _ _ _ = return ()
 
 updateTable client naddr tbl committee sched = do
         self <- atomically $ R.thisNode <$> readTVar tbl
@@ -1034,12 +1084,47 @@ putCiphered (Ciphered (Poly1305.Auth mac) bs) = do
         S.putByteString (BA.convert mac)
         S.putByteString bs
 
-data Announce = Announce
-    { announcePingId  :: NodeId -- Ping ID
-    , announceSeeking :: NodeId -- Public key we are searching for
-    , announceKey     :: NodeId -- Public key that we want those sending back data packets to use
+newtype Nonce32 = Nonce32 ByteString
+ deriving (Eq, Ord, ByteArrayAccess, Data)
+
+instance S.Serialize Nonce32 where
+    get = Nonce32 <$> S.getBytes 32
+    put (Nonce32 bs) = S.putByteString bs
+
+data AnnounceRequest = AnnounceRequest
+    { announcePingId  :: Nonce32 -- Ping ID
+    , announceSeeking :: NodeId  -- Public key we are searching for
+    , announceKey     :: NodeId  -- Public key that we want those sending back data packets to use
+    }
+
+instance S.Serialize AnnounceRequest where
+    get = AnnounceRequest <$> S.get <*> S.get <*> S.get
+    put (AnnounceRequest p s k) = S.put (p,s,k)
+
+data KeyRecord = NotStored    Nonce32
+               | SendBackKey  Tox.PubKey
+               | Acknowledged Nonce32
+
+instance S.Serialize KeyRecord where
+    get = do
+        is_stored <- S.get :: S.Get Word8
+        case is_stored of
+            1 -> SendBackKey  <$> S.get
+            2 -> Acknowledged <$> S.get
+            _ -> NotStored    <$> S.get
+    put (NotStored n32)    = S.put (0 :: Word8) >> S.put n32
+    put (SendBackKey key)  = S.put (1 :: Word8) >> S.put key
+    put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32
+
+data AnnounceResponse = AnnounceResponse
+    { is_stored     :: KeyRecord
+    , announceNodes :: SendNodes
     }
 
+instance S.Serialize AnnounceResponse where
+    get = AnnounceResponse <$> S.get <*> S.get
+    put (AnnounceResponse st ns) = S.put st >> S.put ns
+
 pingH :: NodeInfo -> Ping -> IO Pong
 pingH _ Ping = return Pong
 
@@ -1075,6 +1160,50 @@ getNodesH routing addr (GetNodes nid) = do
 
     k = 4
 
+-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
+-- some secret bytes generated when the instance is created, the current time
+-- divided by a 20 second timeout, the public key of the requester and the source
+-- ip/port that the packet was received from. Since the ip/port that the packet
+-- was received from is in the `ping_id`, the announce packets being sent with a
+-- ping id must be sent using the same path as the packet that we received the
+-- `ping_id` from or announcing will fail.
+--
+-- 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 -> NodeInfo -> AnnounceRequest -> IO AnnounceResponse
+announceH routing toks keydb naddr req = do
+    case () of
+        _ | announcePingId req == zeros32
+          -> go False
+
+        _ | Nonce32 bs <- announcePingId req
+          , let tok = fromPaddedByteString 32 bs
+          -> checkToken toks naddr tok >>= go
+ where
+    go withTok = do
+        ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
+        tm <- getPOSIXTime
+        let storing = (nodeId naddr == announceSeeking req)
+        record <- atomically $ do
+            when (withTok && storing) $ do
+                let ni = Tox.Aliased (naddr { nodeId = announceKey req })
+                    -- Note: The following distance calculation assumes that
+                    -- our nodeid doesn't change and is the same for both
+                    -- routing4 and routing6.
+                    d = xor (nodeId (tentativeId routing))
+                            (announceSeeking req)
+                modifyTVar' keydb (insertKey tm (announceSeeking req) ni d)
+            ks <- readTVar keydb
+            return $ snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
+        newtok <- if storing
+                    then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
+                    else return $ zeros32
+        let k = case record of
+                Nothing                         -> NotStored newtok
+                Just (Tox.Aliased ni) | storing -> Acknowledged newtok
+                Just (Tox.Aliased ni)           -> SendBackKey (nodeId ni)
+        return $ AnnounceResponse k ns
 
 {-
 symmetricCipher :: DRG g => STM ByteString -> STM g -> (g -> STM ()) -> ByteString -> IO (Tox.Nonce24, SymmetricCiphered)
@@ -1157,9 +1286,9 @@ onionResponse1H symdecipher udp addr Message{ msgNonce
 -}
 
 intKey :: TransactionId -> Int
-intKey (TransactionId (Nonce8 w) _) = fromIntegral w
+intKey (TransactionId (Tox.Nonce8 w) _) = fromIntegral w
 
-nonceKey :: TransactionId -> Nonce8
+nonceKey :: TransactionId -> Tox.Nonce8
 nonceKey (TransactionId n _) = n
 
 -- randomBytesGenerate :: ByteArray byteArray => Int -> gen -> (byteArray, gen)
@@ -1168,7 +1297,7 @@ gen :: forall gen. DRG gen => gen -> (TransactionId, gen)
 gen g = let (bs, g')  = randomBytesGenerate 24 g
             (ws, g'') = randomBytesGenerate 8 g'
             Right w   = S.runGet S.getWord64be ws
-        in ( TransactionId (Nonce8 w) (Tox.Nonce24 bs), g'' )
+        in ( TransactionId (Tox.Nonce8 w) (Tox.Nonce24 bs), g'' )
 
 
 
@@ -1206,3 +1335,16 @@ toxSearch qry = Search
 
 nodeSearch client = toxSearch (getNodes client)
 
+
+type NodeDistance = Tox.PubKey
+
+data AnnouncedKeys = AnnouncedKeys
+    { keyByAge :: PSQ NodeId (Down POSIXTime) -- timeout of 300 seconds
+    , keyAssoc :: MinMaxPSQ' Tox.PubKey NodeDistance (Tox.Aliased NodeInfo)
+    }
+
+insertKey :: POSIXTime -> Tox.PubKey -> Tox.Aliased NodeInfo -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
+insertKey tm pub ni d keydb = AnnouncedKeys
+    { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
+    , keyAssoc = MinMaxPSQ.insert' pub ni d (keyAssoc keydb)
+    }
diff --git a/src/Network/BitTorrent/DHT/Token.hs b/src/Network/BitTorrent/DHT/Token.hs
index 08079b75..756b5a98 100644
--- a/src/Network/BitTorrent/DHT/Token.hs
+++ b/src/Network/BitTorrent/DHT/Token.hs
@@ -21,6 +21,9 @@
 module Network.BitTorrent.DHT.Token
        ( -- * Token
          Token
+       , maxInterval
+       , toPaddedByteString
+       , fromPaddedByteString
 
          -- * Session tokens
        , TokenMap
@@ -74,7 +77,19 @@ instance Show Token where
 
 -- | Meaningless token, for testing purposes only.
 instance Default Token where
-  def = Token "0xdeadbeef"
+  def = makeToken (0::Int) 0
+
+-- | Prepend token with 0x20 bytes to fill the available width.
+--
+-- If n > 8, then this will also guarantee a nonzero token, which is useful for
+-- Tox ping-id values for announce responses.
+toPaddedByteString :: Int -> Token -> BS.ByteString
+toPaddedByteString n (Token bs) = BS.append (BS.replicate (n - BS.length bs) 0x20) bs
+
+fromPaddedByteString :: Int -> BS.ByteString -> Token
+fromPaddedByteString n bs = Token $ BS.drop (n - len) bs
+ where
+    len = BS.length tok where Token tok = def
 
 -- | The secret value used as salt.
 type Secret = Int
@@ -85,6 +100,7 @@ makeToken :: Hashable a => a -> Secret -> Token
 makeToken n s = Token $ toBS $ hashWithSalt s n
   where
     toBS = toStrict . toLazyByteString . int64BE . fromIntegral
+{-# INLINE makeToken #-}
 
 -- | Constant space 'Node' to 'Token' map based on the secret value.
 data TokenMap = TokenMap