8 files changed, 255 insertions, 52 deletions

diff --git a/src/Network/BitTorrent/DHT.hs b/src/Network/BitTorrent/DHT.hs
index fa8071d5..2535c05c 100644
--- a/src/Network/BitTorrent/DHT.hs
+++ b/src/Network/BitTorrent/DHT.hs
@@ -234,7 +234,7 @@ bootstrap :: forall raw dht u ip.
     , Show u
     , Default u
     , Serialize u
-    ) => Maybe BS.ByteString -> [NodeAddr ip] -> DHT raw dht u ip ()
+    ) => Maybe BS.ByteString -> [PacketDestination dht] -> DHT raw dht u ip ()
 bootstrap mbs startNodes = do
   restored <-
     case decode <$> mbs of
@@ -250,7 +250,7 @@ bootstrap mbs startNodes = do
         return ( ns :: [NodeInfo dht ip u] )
   input_nodes <- (restored ++) . T.toList <$> getTable
   -- Step 1: Use iterative searches to flesh out the table..
-  do let knowns = map (map $ nodeAddr . fst) input_nodes
+  do let knowns = map (map $ fst) input_nodes
      -- Below, we reverse the nodes since the table serialization puts the
      -- nearest nodes last and we want to choose a similar node id to bootstrap
      -- faster.
@@ -265,7 +265,7 @@ bootstrap mbs startNodes = do
          when (null ns) $ do
             -- TODO filter duplicated in startNodes list
             -- TODO retransmissions for startNodes
-            (aliveNodes,_) <- unzip <$> queryParallel (pingQ <$> startNodes)
+            (aliveNodes,_) <- unzip <$> queryParallel (coldPingQ <$> startNodes)
             _ <- searchAll $ take 2 aliveNodes
             return ()
   -- Step 2: Repeatedly refresh incomplete buckets until the table is full.
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index 77fede94..60b772b3 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -35,6 +35,7 @@ module Network.BitTorrent.DHT.Query
          -- single response.
        , Iteration
        , pingQ
+       , coldPingQ
        , findNodeQ
        , getPeersQ
        , announceQ
@@ -316,44 +317,72 @@ pingQ :: forall raw dht u ip.
             , FiniteBits (NodeId dht)
             , Show (NodeId dht)
             , Show (QueryMethod dht)
-            ) => NodeAddr ip -> DHT raw dht u ip (NodeInfo dht ip u , Maybe ReflectedIP)
-pingQ addr = do
+            ) => NodeInfo dht ip u -> DHT raw dht u ip (NodeInfo dht ip u , Maybe ReflectedIP)
+pingQ ni = do
   let ping = DHT.pingMessage (Proxy :: Proxy dht)
-  (nid, pong, mip) <- queryNode' addr ping
+  (nid, pong, mip) <- queryNode' ni ping
   let _ = pong `asTypeOf` ping
   -- (nid, PingPayload{}, mip) <- queryNode' addr PingPayload {isPong=False, pingId=pid}
-  return (NodeInfo nid addr def, mip)
+  return (NodeInfo nid (nodeAddr ni) def, mip)
+
+-- | The most basic query. May be used to check if the given node is
+-- alive or get its 'NodeId'.
+coldPingQ :: forall raw dht u ip.
+            ( DHT.Kademlia dht
+            , Address ip
+            , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
+            , Default u
+            , Show u
+            , Ord (TransactionID dht)
+            , Serialize (TransactionID dht)
+            , WireFormat raw dht
+            , SerializableTo raw (Response dht (Ping dht))
+            , SerializableTo raw (Query dht (Ping dht))
+            , Ord (NodeId dht)
+            , FiniteBits (NodeId dht)
+            , Show (NodeId dht)
+            , Show (QueryMethod dht)
+            ) => PacketDestination dht -> DHT raw dht u ip (NodeInfo dht ip u , Maybe ReflectedIP)
+coldPingQ dest = do
+  let ping = DHT.pingMessage (Proxy :: Proxy dht)
+  naddr <- maybe (throwIO $ QueryFailed ProtocolError "unable to construct NodeAddr from PacketDestination")
+                 return
+                 $ fromAddr dest
+  (nid, pong, mip) <- coldQueryNode' naddr dest ping
+  let _ = pong `asTypeOf` ping
+  -- (nid, PingPayload{}, mip) <- queryNode' addr PingPayload {isPong=False, pingId=pid}
+  return (NodeInfo nid naddr def, mip)
 
 -- TODO [robustness] match range of returned node ids with the
 -- expected range and either filter bad nodes or discard response at
 -- all throwing an exception
 -- findNodeQ :: Address ip => TableKey key => key -> IterationI ip NodeInfo
-findNodeQ proxy key NodeInfo {..} = do
-  closest <- fmap DHT.foundNodes $  DHT.findNodeMessage proxy key <@> nodeAddr
+findNodeQ proxy key ni = do
+  closest <- fmap DHT.foundNodes $  DHT.findNodeMessage proxy key <@> ni
   $(logInfoS) "findNodeQ" $ "NodeFound\n"
     <> T.pack (L.unlines $ L.map ((' ' :) . show . pPrint) closest)
   return $ Right closest
 
 #ifdef VERSION_bencoding
 getPeersQ :: Address ip => InfoHash -> Iteration BValue KMessageOf () ip PeerAddr
-getPeersQ topic NodeInfo {..} = do
-  GotPeers {..} <- GetPeers topic <@> nodeAddr
-  let dist = distance (toNodeId topic) nodeId
+getPeersQ topic ni = do
+  GotPeers {..} <- GetPeers topic <@> ni
+  let dist = distance (toNodeId topic) (nodeId ni)
   $(logInfoS) "getPeersQ" $ T.pack
          $ "distance: " <> render (pPrint dist) <> " , result: "
         <> case peers of { Left _ -> "NODES"; Right _ -> "PEERS" }
   return peers
 
 announceQ :: Address ip => InfoHash -> PortNumber -> Iteration BValue KMessageOf () ip NodeAddr
-announceQ ih p NodeInfo {..} = do
-  GotPeers {..} <- GetPeers ih <@> nodeAddr
+announceQ ih p ni = do
+  GotPeers {..} <- GetPeers ih <@> ni
   case peers of
     Left  ns
       | False     -> undefined -- TODO check if we can announce
       | otherwise -> return (Left ns)
     Right _ -> do -- TODO *probably* add to peer cache
-      Announced <- Announce False ih Nothing p grantedToken <@> nodeAddr
-      return (Right [nodeAddr])
+      Announced <- Announce False ih Nothing p grantedToken <@> ni
+      return (Right [nodeAddr ni])
 #endif
 
 {-----------------------------------------------------------------------
@@ -393,7 +422,7 @@ ioFindNode :: ( DHT.Kademlia dht
 ioFindNode ih = do
     session <- ask
     return $ \ni -> runDHT session $ do
-        ns <- fmap DHT.foundNodes $ DHT.findNodeMessage Proxy ih <@> nodeAddr ni
+        ns <- fmap DHT.foundNodes $ DHT.findNodeMessage Proxy ih <@> ni
         let ns' = L.map (fmap (const def)) ns
         return $ L.partition (\n -> nodeId n /= toNodeId ih) ns'
 
@@ -422,7 +451,7 @@ ioFindNodes :: ( DHT.Kademlia dht
 ioFindNodes ih = do
     session <- ask
     return $ \ni -> runDHT session $ do
-        ns <- fmap DHT.foundNodes $ DHT.findNodeMessage Proxy ih <@> nodeAddr ni
+        ns <- fmap DHT.foundNodes $ DHT.findNodeMessage Proxy ih <@> ni
         let ns' = L.map (fmap (const def)) ns
         return ([], ns')
 
@@ -504,9 +533,9 @@ probeNode :: ( Default u
             , FiniteBits (NodeId dht)
             , Show (NodeId dht)
             , Show (QueryMethod dht)
-            ) => NodeAddr ip -> DHT raw dht u ip (Bool , Maybe ReflectedIP)
+            ) => NodeInfo dht ip u -> DHT raw dht u ip (Bool , Maybe ReflectedIP)
 probeNode addr = do
-  $(logDebugS) "routing.questionable_node" (T.pack (render (pPrint addr)))
+  $(logDebugS) "routing.questionable_node" (T.pack (render (pPrint $ nodeAddr addr)))
   result <- try $ pingQ addr
   let _ = fmap (const ()) result :: Either QueryFailure ()
   return $ either (const (False,Nothing)) (\(_,mip)->(True,mip)) result
@@ -549,7 +578,7 @@ refreshNodes nid = do
     $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length ns)) <> " nodes."
     _ <- queryParallel $ flip L.map ns $ \n -> do
         $(logWarnS) "refreshNodes" $ "received node: " <> T.pack (show (pPrint n))
-        pingQ (nodeAddr n)
+        pingQ n
         -- pingQ takes care of inserting the node.
     return ()
   return () -- \$ L.concat nss
@@ -622,7 +651,7 @@ insertNode1 = do
         , fallbackID = nid :: NodeId dht
         , adjustID = dhtAdjustID Proxy (DHT.fallbackID params) :: SockAddr -> Event dht ip u -> NodeId dht
         , logMessage = logm :: Char -> String -> IO ()
-        , pingProbe = probe :: NodeAddr ip -> IO (Bool, Maybe ReflectedIP)
+        , pingProbe = probe :: NodeInfo dht ip u -> IO (Bool, Maybe ReflectedIP)
         }
   tbl <- asks routingInfo
   let state = DHT.TableKeeper
@@ -651,7 +680,7 @@ queryNode :: forall raw dht u a b ip.
     , Show (QueryMethod dht)
     , SerializableTo raw (Response dht (Ping dht))
     , SerializableTo raw (Query dht (Ping dht))
-    ) => NodeAddr ip -> a -> DHT raw dht u ip (NodeId dht, b)
+    ) => NodeInfo dht ip u -> a -> DHT raw dht u ip (NodeId dht, b)
 queryNode addr q = fmap (\(n,b,_) -> (n,b)) $ queryNode' addr q
 
 queryNode' :: forall raw dht u a b ip.
@@ -672,15 +701,39 @@ queryNode' :: forall raw dht u a b ip.
     , Show (QueryMethod dht)
     , SerializableTo raw (Response dht (Ping dht))
     , SerializableTo raw (Query dht (Ping dht))
-    ) => NodeAddr ip -> a -> DHT raw dht u ip (NodeId dht, b, Maybe ReflectedIP)
-queryNode' addr q = do
-  nid <- myNodeIdAccordingTo addr
+    ) => NodeInfo dht ip u -> a -> DHT raw dht u ip (NodeId dht, b, Maybe ReflectedIP)
+queryNode' ni q = do
+  let addr = nodeAddr ni
+      dest = makeAddress (Left $ nodeId ni) (toSockAddr addr)
+  coldQueryNode' addr dest q
+
+coldQueryNode' :: forall raw dht u a b ip.
+    ( Address ip
+    , Default u
+    , Show u
+    , DHT.Kademlia dht
+    , KRPC dht (Query dht a) (Response dht b)
+    , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
+    , Ord (TransactionID dht)
+    , Serialize (TransactionID dht)
+    , WireFormat raw dht
+    , SerializableTo raw (Response dht b)
+    , SerializableTo raw (Query dht a)
+    , Ord (NodeId dht)
+    , FiniteBits (NodeId dht)
+    , Show (NodeId dht)
+    , Show (QueryMethod dht)
+    , SerializableTo raw (Response dht (Ping dht))
+    , SerializableTo raw (Query dht (Ping dht))
+    ) => NodeAddr ip -> PacketDestination dht -> a -> DHT raw dht u ip (NodeId dht, b, Maybe ReflectedIP)
+coldQueryNode' addr dest q = do
+  nid <- myNodeIdAccordingTo $ fromMaybe (error "TODO: coldQueryNode' myNodeIdAccordingTo") $ fromAddr dest
   dta <- asks dhtData
   qextra <- liftIO $ makeQueryExtra dta nid (Proxy :: Proxy (Query dht q)) (Proxy :: Proxy (Response dht b))
   let read_only = False -- TODO: check for NAT issues. (BEP 43)
   -- let KRPC.Method name = KRPC.method :: KRPC.Method dht (Query dht a) (Response dht b)
   mgr <- asks manager
-  (Response rextra r, remoteId, witnessed_ip) <- liftIO $ query' mgr (toSockAddr addr) (Query qextra q)
+  (Response rextra r, remoteId, witnessed_ip) <- liftIO $ query' mgr dest (Query qextra q)
   -- \$(logDebugS) "queryNode" $ "Witnessed address: " <> T.pack (show witnessed_ip)
   --                             <> " by " <> T.pack (show (toSockAddr addr))
   _ <- insertNode (NodeInfo remoteId addr def) witnessed_ip
@@ -704,6 +757,6 @@ queryNode' addr q = do
          , SerializableTo raw (Query dht (Ping dht))
          , WireFormat raw dht
          , Kademlia dht
-         ) => a -> NodeAddr ip -> DHT raw dht u ip b
+         ) => a -> NodeInfo dht ip u -> DHT raw dht u ip b
 q <@> addr = snd <$> queryNode addr q
 {-# INLINE (<@>) #-}
diff --git a/src/Network/DHT.hs b/src/Network/DHT.hs
index 0dab29cd..285cf9ff 100644
--- a/src/Network/DHT.hs
+++ b/src/Network/DHT.hs
@@ -115,7 +115,7 @@ insertNode param@TableParameters{..} state info witnessed_ip0 = do
     myThreadId >>= flip labelThread "DHT.insertNode.pingResults"
     forM_ ps $ \(CheckPing ns)-> do
       forM_ ns $ \n -> do
-        (b,mip) <- pingProbe (nodeAddr n)
+        (b,mip) <- pingProbe n
         let alive = PingResult n b
         logMessage 'D' $ "PingResult "++show (nodeId n,b)
         _ <- join $ atomically $ atomicInsert param state tm alive mip
diff --git a/src/Network/DHT/Types.hs b/src/Network/DHT/Types.hs
index 0102a53f..47f98ebe 100644
--- a/src/Network/DHT/Types.hs
+++ b/src/Network/DHT/Types.hs
@@ -18,7 +18,7 @@ import GHC.Generics
 data TableParameters msg ip u = TableParameters
     { maxBuckets :: Int
     , fallbackID :: NodeId msg
-    , pingProbe :: NodeAddr ip -> IO (Bool, Maybe ReflectedIP)
+    , pingProbe :: NodeInfo msg ip u -> IO (Bool, Maybe ReflectedIP)
     , logMessage :: Char -> String -> IO ()
     , adjustID :: SockAddr -> Event msg ip u -> NodeId msg
     }
diff --git a/src/Network/DatagramServer.hs b/src/Network/DatagramServer.hs
index 1376748f..ca968a8c 100644
--- a/src/Network/DatagramServer.hs
+++ b/src/Network/DatagramServer.hs
@@ -329,7 +329,7 @@ query :: forall h a b raw msg.
     , SerializableTo raw a
     , WireFormat raw msg
     , KRPC msg a b
-    ) => Manager raw msg -> SockAddr -> a -> IO b
+    ) => Manager raw msg -> PacketDestination msg -> a -> IO b
 query mgr addr params = queryK mgr addr params (\_ x _ _ -> x)
 
 -- | Like 'query' but possibly returns your externally routable IP address.
@@ -340,7 +340,7 @@ query' :: forall h a b raw msg.
     , Serialize (TransactionID msg)
     , SerializableTo raw a , WireFormat raw msg
     , KRPC msg a b
-    ) => Manager raw msg -> SockAddr -> a -> IO (b , NodeId msg, Maybe ReflectedIP)
+    ) => Manager raw msg -> PacketDestination msg -> a -> IO (b , NodeId msg, Maybe ReflectedIP)
 query' mgr addr params = queryK mgr addr params (\_ b nid ip -> (b,nid,ip))
 
 -- | Enqueue a query, but give us the complete BEncoded content sent by the
@@ -354,7 +354,7 @@ queryRaw :: forall h a b raw msg.
     , SerializableTo raw a
     , WireFormat raw msg
     , KRPC msg a b
-    ) => Manager raw msg -> SockAddr -> a -> IO (b , raw)
+    ) => Manager raw msg -> PacketDestination msg -> a -> IO (b , raw)
 queryRaw mgr addr params = queryK mgr addr params (\raw x _ _ -> (x,raw))
 
 queryK :: forall h a b x raw msg.
@@ -366,11 +366,12 @@ queryK :: forall h a b x raw msg.
     , Serialize (TransactionID msg)
     , KRPC msg a b
     ) =>
-    Manager raw msg -> SockAddr -> a -> (raw -> b -> NodeId msg -> Maybe ReflectedIP -> x) -> IO x
-queryK mgr@Manager{..} addr params kont = do
+    Manager raw msg -> PacketDestination msg -> a -> (raw -> b -> NodeId msg -> Maybe ReflectedIP -> x) -> IO x
+queryK mgr@Manager{..} dest params kont = do
   tid <- liftIO $ genTransactionId transactionCounter
-  let Method meth = method :: Method msg a b
-  let signature = querySignature meth tid addr
+  let addr = toSockAddr dest
+      Method meth = method :: Method msg a b
+      signature = querySignature meth tid addr
   logMsg 'D' "query.sending" signature
 
   mres <- liftIO $ do
@@ -380,7 +381,7 @@ queryK mgr@Manager{..} addr params kont = do
         ctx = error "TODO TOX ToxCipherContext or () for Mainline"
     q <- buildQuery cli addr meth tid params
     let qb = encodePayload (q :: msg a) :: msg raw
-        qbs = encodeHeaders ctx qb
+        qbs = encodeHeaders ctx qb dest
     sendQuery sock addr qbs
       `onException` unregisterQuery (tid, addr) pendingCalls
 
@@ -528,7 +529,8 @@ handleQuery mgr@Manager{..} hs meth raw q addr = void $ fork $ do
   res <- dispatchHandler mgr hs meth q addr
   let  res' = either buildError Just res
        ctx = error "TODO TOX ToxCipherContext 2 or () for Mainline"
-       resbs = fmap (encodeHeaders ctx) res' :: Maybe BS.ByteString
+       dest = makeAddress (Right q) addr
+       resbs = fmap (\raw -> encodeHeaders ctx raw dest) res' :: Maybe BS.ByteString
   -- TODO: Generalize this debug print.
   --     resbe = either toBEncode toBEncode res
   -- .(logOther "q") \$ T.unlines
diff --git a/src/Network/DatagramServer/Mainline.hs b/src/Network/DatagramServer/Mainline.hs
index 89a275c1..1f07b13f 100644
--- a/src/Network/DatagramServer/Mainline.hs
+++ b/src/Network/DatagramServer/Mainline.hs
@@ -79,6 +79,7 @@ import Data.Typeable
 import Network.Socket (SockAddr (..),PortNumber,HostAddress)
 import Text.PrettyPrint                as PP hiding ((<>))
 import Text.PrettyPrint.HughesPJClass  hiding (($$), (<>))
+import Data.Hashable
 
 
 -- | This transaction ID is generated by the querying node and is
@@ -290,6 +291,9 @@ instance Envelope KMessageOf where
         }
       deriving (Show, Eq, Ord, Typeable)
 
+    newtype PacketDestination KMessageOf = MainlineNode SockAddr
+      deriving (Show, Eq, Ord, Typeable)
+
     envelopePayload (Q q) = queryArgs q
     envelopePayload (R r) = respVals r
     envelopePayload (E _) = error "TODO: messagePayload for KError"
@@ -302,6 +306,9 @@ instance Envelope KMessageOf where
     envelopeClass (R r) = Response (respIP r)
     envelopeClass (E e) = Error e
 
+    -- replyAddress :: envelope a -> SockAddr -> PacketDestination envelope
+    makeAddress _ addr = MainlineNode addr
+
     buildReply self addr qry response =
         (R (KResponse response (envelopeTransaction qry) (Just $ ReflectedIP addr)))
 
@@ -311,6 +318,20 @@ instance Envelope KMessageOf where
 
     fromRoutableNode = not . queryIsReadOnly
 
+instance Hashable (PacketDestination KMessageOf) where
+  hashWithSalt s (MainlineNode sockaddr) = hashWithSalt s (show sockaddr)
+
+-- Serialize, Pretty) PacketDestination KMessageOf = MainlineNode SockAddr
+instance Serialize (PacketDestination KMessageOf) where
+    put (MainlineNode addr) = putSockAddr addr
+    get = MainlineNode <$> getSockAddr
+
+instance Pretty (PacketDestination KMessageOf) where
+    pPrint (MainlineNode addr) = PP.text $ show addr
+
+instance Address (PacketDestination KMessageOf) where
+    toSockAddr (MainlineNode addr) = addr
+    fromSockAddr addr = Just $ MainlineNode addr
 
 instance WireFormat BValue KMessageOf where
     type SerializableTo BValue = BEncode
@@ -323,7 +344,7 @@ instance WireFormat BValue KMessageOf where
     decodeHeaders _ = BE.fromBEncode
     decodePayload kmsg = mapM BE.fromBEncode kmsg
 
-    encodeHeaders _ kmsg = L.toStrict $ BE.encode kmsg
+    encodeHeaders _ kmsg _ = L.toStrict $ BE.encode kmsg
     encodePayload msg = fmap BE.toBEncode msg
 
 -- | KRPC 'compact list' compatible encoding: contact information for
diff --git a/src/Network/DatagramServer/Tox.hs b/src/Network/DatagramServer/Tox.hs
index f666b951..8d2f9289 100644
--- a/src/Network/DatagramServer/Tox.hs
+++ b/src/Network/DatagramServer/Tox.hs
@@ -11,10 +11,13 @@
 {-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UnboxedTuples         #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RankNTypes #-}
 module Network.DatagramServer.Tox where
 
 import Data.Bits
 import Data.ByteString (ByteString)
+import Data.ByteArray as BA (ByteArrayAccess,length,withByteArray)
 import qualified Data.Serialize as S
 -- import qualified Data.ByteString.Lazy  as L
 import qualified Data.ByteString.Char8 as Char8
@@ -23,12 +26,25 @@ import Data.Word
 import Data.LargeWord
 import Data.IP
 import Data.Serialize
--- import Network.Address (NodeInfo(..)) -- Serialize IP
+import Network.Address
 import GHC.Generics (Generic)
 import Network.Socket
 import Network.DatagramServer.Types
 import qualified Network.DatagramServer.Types as Envelope (NodeId)
 import Crypto.PubKey.ECC.Types
+import Crypto.PubKey.Curve25519
+import Crypto.ECC.Class
+import qualified Crypto.Cipher.XSalsa as Salsa20
+import Data.LargeWord
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Data.Typeable
+import StaticAssert
+import Crypto.Error.Types
+import Data.Hashable
+import Text.PrettyPrint as PP hiding ((<>))
+import Text.PrettyPrint.HughesPJClass  hiding (($$), (<>))
 
 
 type Key32   = Word256 -- 32 byte key
@@ -203,7 +219,9 @@ instance Serialize NodeFormat where
 --   [Sendback data, length=8 bytes]
 --   ]
 
-data ToxCipherContext = ToxCipherContext -- TODO
+data ToxCipherContext = ToxCipherContext
+    { dhtSecretKey :: SecretKey
+    }
 
 newtype Ciphered = Ciphered { cipheredBytes :: ByteString }
 
@@ -227,29 +245,51 @@ putMessage (Message {..}) = do
         let Ciphered bs = msgPayload
         putByteString bs
 
+id2key :: NodeId Message -> PublicKey
+id2key recipient = case publicKey recipient of
+    CryptoPassed key -> key
+    CryptoFailed e   -> error ("id2key: "++show e)
+
+lookupSecret :: ToxCipherContext -> NodeId Message -> TransactionID Message -> Salsa20.State
+lookupSecret ctx recipient nonce = Salsa20.initialize 20 key nonce
+ where
+    key = ecdh (Proxy :: Proxy Curve_X25519) (dhtSecretKey ctx) (id2key recipient) -- ByteArrayAccess b => b
+
 decipher :: ToxCipherContext -> Message Ciphered -> Either String (Message ByteString)
-decipher = error "TODO TOX: decipher"
+decipher ctx ciphered = Right (fst . Salsa20.combine st . cipheredBytes <$> ciphered)
+ where
+    st = lookupSecret ctx (msgClient ciphered) (msgNonce ciphered)
 
-encipher :: ToxCipherContext -> Message ByteString -> Message Ciphered
-encipher = error "TODO TOX: encipher"
+encipher :: ToxCipherContext -> NodeId Message -> Message ByteString -> Message Ciphered
+encipher ctx recipient plain = Ciphered . fst . Salsa20.combine st <$> plain
+ where
+    st = lookupSecret ctx recipient (msgNonce plain)
 
 -- see rfc7748
+--
+-- Crypto.ECC
+-- Crypto.PubKey.Curve25519
+-- Crypto.Cipher.XSalsa
+--
 curve25519 :: Curve
 curve25519 = CurveFP (CurvePrime prime curvecommon)
  where
     prime = 2^255 - 19 -- (≅ 1 modulo 4)
 
+    sqrt_of_39420360 = 14781619447589544791020593568409986887264606134616475288964881837755586237401
+
     -- 1 * v^2 = u^3 + 486662*u^2 + u
 
     curvecommon = CurveCommon
         { ecc_a = 486662
         , ecc_b = 1
-        , ecc_g = Point 9 14781619447589544791020593568409986887264606134616475288964881837755586237401 -- base point
+        , ecc_g = Point 9 sqrt_of_39420360 -- base point
         , ecc_n = 2^252 + 0x14def9dea2f79cd65812631a5cf5d3ed -- order
         , ecc_h = 8 -- cofactor
         }
 
-
+-- crypto_box uses xsalsa20 symmetric encryption and poly1305 authentication.
+-- https://en.wikipedia.org/wiki/Poly1305
 
 instance Envelope Message where
     newtype TransactionID Message = TID Nonce24
@@ -263,6 +303,11 @@ instance Envelope Message where
     newtype QueryExtra Message = QueryNonce { qryNonce :: Nonce8 }
     newtype ResponseExtra Message = ResponseNonce { rspNonce :: Nonce8 }
 
+    data PacketDestination Message = ToxAddr { toxID :: NodeId Message
+                                             , toxSockAddr :: SockAddr
+                                             }
+        deriving (Eq,Ord,Show)
+
     envelopePayload = msgPayload
 
     envelopeTransaction = msgNonce
@@ -272,15 +317,70 @@ instance Envelope Message where
     envelopeClass Message { msgType = GetNodes  } = Query GetNodes
     envelopeClass Message { msgType = SendNodes } = Response Nothing
 
+    makeAddress qry = ToxAddr (either id msgClient qry)
+
     buildReply self addr qry payload = (fmap (const payload) qry) { msgClient = self }
 
     -- buildQuery :: NodeId envelope -> SockAddr -> QueryMethod envelope -> TransactionID envelope -> a -> IO (envelope a)
-    -- buildQuery nid addr meth tid q = todo
+    buildQuery nid addr meth tid q = return $ Message
+        { msgType = meth
+        , msgClient = nid
+        , msgNonce = tid
+        , msgPayload = q
+        }
 
     uniqueTransactionId cnt = do
       return $ either (error "failed to create TransactionId") TID
              $ S.decode $ Char8.pack (take 24 $ show cnt ++ repeat ' ')
 
+
+staticAssert isLittleEndian -- assumed by 'withWord64Ptr'
+
+with3Word64Ptr :: Nonce24 -> (Ptr Word64 -> IO a) -> IO a
+with3Word64Ptr (LargeKey wlo (LargeKey wmid whi)) kont =
+    allocaBytes (sizeOf wlo * 3) $ \p -> do
+        pokeElemOff p 0 wlo
+        pokeElemOff p 1 wmid
+        pokeElemOff p 2 whi
+        kont p
+
+with4Word64Ptr :: Key32 -> (Ptr Word64 -> IO a) -> IO a
+with4Word64Ptr (LargeKey wlo (LargeKey wmid (LargeKey whi whighest))) kont =
+    allocaBytes (sizeOf wlo * 4) $ \p -> do
+        pokeElemOff p 0 wlo
+        pokeElemOff p 1 wmid
+        pokeElemOff p 2 whi
+        pokeElemOff p 3 whighest
+        kont p
+
+
+instance ByteArrayAccess (TransactionID Message) where
+    length _ = 24
+    withByteArray (TID nonce) kont = with3Word64Ptr nonce (kont . castPtr)
+
+instance ByteArrayAccess (NodeId Message) where
+    length _ = 32
+    withByteArray (NodeId nonce) kont = with4Word64Ptr nonce (kont . castPtr)
+
+
+instance Hashable (NodeId Message) where
+    hashWithSalt s (NodeId (LargeKey a (LargeKey b (LargeKey c d)))) =
+        hashWithSalt s (a,b,c,d)
+
+instance Hashable (PacketDestination Message) where
+    hashWithSalt s (ToxAddr nid addr) = hashWithSalt s nid
+
+instance Serialize (PacketDestination Message) where
+    put (ToxAddr (NodeId nid) addr) = put nid >> putSockAddr addr
+    get = ToxAddr <$> (NodeId <$> get) <*> getSockAddr
+
+instance Pretty (PacketDestination Message) where
+    pPrint = PP.text . show
+
+instance Address (PacketDestination Message) where
+    toSockAddr (ToxAddr _ addr) = addr
+    fromSockAddr _ = Nothing
+
 instance WireFormat ByteString Message where
     type SerializableTo ByteString = Serialize
     type CipherContext ByteString Message = ToxCipherContext
@@ -289,6 +389,6 @@ instance WireFormat ByteString Message where
     encodePayload = fmap encode
 
     decodeHeaders ctx bs = runGet getMessage bs >>= decipher ctx
-    encodeHeaders ctx msg = runPut $ putMessage $ encipher ctx msg
+    encodeHeaders ctx msg recipient = runPut $ putMessage $ encipher ctx (toxID recipient) msg
 
 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 13f79afb..14968764 100644
--- a/src/Network/DatagramServer/Types.hs
+++ b/src/Network/DatagramServer/Types.hs
@@ -96,11 +96,21 @@ class Envelope envelope where
     data NodeId envelope
     data QueryExtra envelope
     data ResponseExtra envelope
+    data PacketDestination envelope
 
     envelopePayload     :: envelope a -> a
     envelopeTransaction :: envelope a -> TransactionID envelope
     envelopeClass       :: envelope a -> MessageClass envelope
 
+    -- | > replyAddress qry addr
+    --
+    --    [ qry ]  received query message
+    --
+    --    [ addr ] SockAddr of query origin
+    --
+    -- Returns: Destination address for reply.
+    makeAddress :: Either (NodeId envelope) (envelope a) -> SockAddr -> PacketDestination envelope
+
     -- | > buildReply self addr qry response
     --
     --    [ self ]     this node's id.
@@ -320,8 +330,7 @@ genBucketSample' gen self (q,m,b)
         h = xor b (complement m .&. BS.last hd)
         t = m .&. BS.head tl
 
-
-class Envelope envelope => WireFormat raw envelope where
+class (Envelope envelope, Address (PacketDestination envelope)) => WireFormat raw envelope where
     type SerializableTo raw :: * -> Constraint
     type CipherContext raw envelope
 
@@ -336,7 +345,7 @@ class Envelope envelope => WireFormat raw envelope where
     decodeHeaders :: CipherContext raw envelope -> raw -> Either String (envelope raw)
     decodePayload :: SerializableTo raw a => envelope raw -> Either String (envelope a)
 
-    encodeHeaders :: CipherContext raw envelope -> envelope raw -> ByteString
+    encodeHeaders :: CipherContext raw envelope -> envelope raw -> PacketDestination envelope -> ByteString
     encodePayload :: SerializableTo raw a => envelope a -> envelope raw
 
 encodeHexDoc :: Serialize x => x -> Doc
@@ -359,3 +368,21 @@ instance (Pretty ip, Pretty (NodeId dht)) => Pretty [NodeInfo dht ip u] where
   pPrint = PP.vcat . PP.punctuate "," . map pPrint
 
 
+
+putSockAddr (SockAddrInet port addr)
+    = put (0x34 :: Word8) >> put port >> put addr
+putSockAddr (SockAddrInet6 port flow addr scope)
+    = put (0x36 :: Word8) >> put port >> put addr >> put scope >> put flow
+putSockAddr (SockAddrUnix path)
+    = put (0x75 :: Word8) >> put path
+putSockAddr (SockAddrCan num)
+    = put (0x63 :: Word8) >> put num
+
+getSockAddr = do
+    c <- get
+    case c :: Word8 of
+        0x34 -> SockAddrInet <$> get <*> get
+        0x36 -> (\p a s f -> SockAddrInet6 p f a s) <$> get <*> get <*> get <*> get
+        0x75 -> SockAddrUnix <$> get
+        0x63 -> SockAddrCan <$> get
+        _ -> fail "getSockAddr"