more tox work

1 files changed, 140 insertions, 32 deletions

diff --git a/Tox.hs b/Tox.hs
index 4df329d3..6969e652 100644
--- a/Tox.hs
+++ b/Tox.hs
@@ -43,7 +43,8 @@ import Foreign.Ptr
 import Foreign.Storable
 import GHC.Generics                     (Generic)
 import Network.Address                  (Address, fromSockAddr, sockAddrPort, testIdBit,
-                                         toSockAddr, setPort, un4map, WantIP(..), ipFamily)
+                                         toSockAddr, setPort, un4map, WantIP(..), ipFamily,
+                                         either4or6)
 import Network.QueryResponse
 import Network.Socket
 import System.Endian
@@ -65,6 +66,7 @@ import Control.Monad
 import Text.Read
 import Kademlia
 import Network.BitTorrent.DHT.Search          (Search (..))
+import Text.Printf
 
 newtype NodeId = NodeId ByteString
  deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
@@ -109,7 +111,7 @@ instance ToJSON NodeInfo where
                         , "port" .= (fromIntegral port :: Int)
                         ]
         | otherwise
-          = JSON.object [ "node-id" .= show nid
+          = JSON.object [ "public_key" .= show nid
                         , "ipv6" .= show ip6
                         , "port" .= (fromIntegral port :: Int)
                         ]
@@ -215,13 +217,47 @@ data TransactionId = TransactionId
  , cryptoNonce    :: Nonce24 -- ^ Used during the encryption layer.
  }
 
+-- https://toktok.ltd/spec#packet-kind
+--  calls this "Packet Kind"
 newtype Method = MessageType Word8
  deriving (Eq, Ord, S.Serialize)
 
-pattern PingType      = MessageType 0
-pattern PongType      = MessageType 1
-pattern GetNodesType  = MessageType 2
-pattern SendNodesType = MessageType 4
+pattern PingType      = MessageType 0 -- 0x00     Ping Request
+pattern PongType      = MessageType 1 -- 0x01     Ping Response
+pattern GetNodesType  = MessageType 2 -- 0x02     Nodes Request
+pattern SendNodesType = MessageType 4 -- 0x04     Nodes Response
+-- 0x18     Cookie Request
+-- 0x19     Cookie Response
+-- 0x1a     Crypto Handshake
+-- 0x1b     Crypto Data
+
+-- TODO: Auth fail:
+pattern DHTRequestType = MessageType 32 -- 0x20     DHT Request
+
+-- 0x21     LAN Discovery
+
+-- TODO: Auth fail:
+pattern OnionRequest0 = MessageType 128 -- 0x80     Onion Request 0
+pattern OnionRequest1 = MessageType 129 -- 0x81     Onion Request 1
+pattern OnionRequest2 = MessageType 130 -- 0x82     Onion Request 2
+pattern AnnounceType  = MessageType 131 -- 0x83     Announce Request
+
+-- 0x84     Announce Response
+-- 0x85     Onion Data Request
+-- 0x86     Onion Data Response
+-- 0x8c     Onion Response 3
+-- 0x8d     Onion Response 2
+-- 0x8e     Onion Response 1
+-- 0xf0     Bootstrap Info
+
+--  TODO Fix these fails...
+--  GetNodesType decipherAndAuth: auth fail
+--  MessageType 128 decipherAndAuth: auth fail
+--  MessageType 129 decipherAndAuth: auth fail
+--  MessageType 130 decipherAndAuth: auth fail
+--  MessageType 131 decipherAndAuth: auth fail
+--  MessageType 32 decipherAndAuth: auth fail
+
 
 instance Show Method where
     showsPrec d PingType        = mappend "PingType"
@@ -275,8 +311,13 @@ data Ciphered = Ciphered { cipheredMAC   :: Poly1305.Auth
 getMessage :: S.Get (Message Ciphered)
 getMessage = do
         typ <- S.get
-        nid <- S.get
-        tid <- S.get
+        (nid,tid) <- case typ of -- Seriously... what the fuck?
+            DHTRequestType -> flip (,) <$> S.get <*> S.get
+            OnionRequest0  -> flip (,) <$> S.get <*> S.get
+            OnionRequest1  -> flip (,) <$> S.get <*> S.get
+            -- OnionRequest2  -> flip (,) <$> S.get <*> S.get
+            AnnounceType   -> flip (,) <$> S.get <*> S.get
+            _              -> (,) <$> S.get <*> S.get
         mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16
         cnt <- S.remaining
         bs <- S.getBytes cnt
@@ -288,8 +329,13 @@ getMessage = do
 putMessage :: Message Ciphered -> S.Put
 putMessage (Message {..}) = do
         S.put msgType
-        S.put msgOrigin
-        S.put msgNonce
+        case msgType of -- Seriously... what the fuck?
+            DHTRequestType -> S.put msgNonce  >> S.put msgOrigin
+            OnionRequest0  -> S.put msgNonce  >> S.put msgOrigin
+            OnionRequest1  -> S.put msgNonce  >> S.put msgOrigin
+            -- OnionRequest2  -> S.put msgNonce  >> S.put msgOrigin
+            AnnounceType   -> S.put msgNonce  >> S.put msgOrigin
+            _              -> S.put msgOrigin >> S.put msgNonce
         let Ciphered (Poly1305.Auth mac) bs = msgPayload
         S.putByteString (BA.convert mac)
         S.putByteString bs
@@ -365,6 +411,8 @@ withSecret f sk recipient nonce x = f hash crypt x
     (hash, crypt) = computeSharedSecret sk recipient nonce
 
 
+-- Encrypt-then-Mac:  Encrypt the cleartext, then compute the MAC on the
+-- ciphertext, and prepend it to the ciphertext
 encipherAndHash :: Poly1305.State -> XSalsa.State -> ByteString -> Ciphered
 encipherAndHash hash crypt m = Ciphered a c
   where
@@ -379,6 +427,30 @@ decipherAndAuth hash crypt (Ciphered mac c)
     m = fst . XSalsa.combine crypt $ c
     a = Poly1305.finalize . Poly1305.update hash $ c
 
+nibble :: Word8 -> Char
+nibble b = intToDigit (fromIntegral (b .&. 0x0F))
+
+xxd :: Int -> ByteString -> [String]
+xxd offset bs | B.null bs = []
+xxd offset bs             = printf "%03x: %s" offset ds : xxd (offset + B.length xs) bs'
+ where
+    ds = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte])
+                 $ B.unpack xs
+    (xs,bs') = B.splitAt 16 bs
+
+showPayloadError ciphered naddr flow err = unlines (map (prefix ++) xs)
+ where
+    xs = unwords [show (msgType ciphered), err]
+         : xxd 0 (BA.convert mac <> ciphertext)
+
+    Message { msgPayload = Ciphered (Poly1305.Auth mac) ciphertext } = ciphered
+
+    prefix = show naddr <> flow
+
+
+showParseError bs addr err = unlines $
+        concat [ either show show (either4or6 addr), " --> ", err ]
+        : xxd 0 bs
 
 -- TODO:
 -- Represents the encrypted portion of a Tox packet.
@@ -387,10 +459,12 @@ decipherAndAuth hash crypt (Ciphered mac c)
 -- Generic packet type: Message (Payload ByteString)
 
 parsePacket :: SecretKey -> SecretsCache -> ByteString -> SockAddr -> Either String (Message ByteString, NodeInfo)
-parsePacket sk cache bs addr = do ciphered <- S.runGet getMessage bs
-                                  msg <- decryptMessage sk cache ciphered
-                                  ni <- nodeInfo (msgOrigin msg) addr
-                                  return (msg, ni)
+parsePacket sk cache bs addr = left (showParseError bs addr) $ do
+    ciphered <- S.runGet getMessage bs
+    ni <- nodeInfo (msgOrigin ciphered) addr
+    left (showPayloadError ciphered ni " --> ") $ do
+    msg <- decryptMessage sk cache ciphered
+    return (msg, ni)
 
 encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (ByteString, SockAddr)
 encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg
@@ -416,20 +490,23 @@ newClient addr = do
     let pubkey = key2id $ toPublic secret
     cache <- newEmptyCache
     drg <- getSystemDRG
-    let tentative_info = NodeInfo
+    let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr)
+        tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr)
+        tentative_info = NodeInfo
                 { nodeId   = pubkey
-                , nodeIP   = fromMaybe (toEnum 0) $ fromSockAddr addr
+                , nodeIP   = fromMaybe (toEnum 0) (fromSockAddr addr)
                 , nodePort = fromMaybe 0 $ sockAddrPort addr
                 }
+        tentative_info4 = tentative_info { nodeIP = tentative_ip4 }
     tentative_info6 <-
-        maybe tentative_info
+        maybe (tentative_info { nodeIP = tentative_ip6 })
               (\ip6 -> tentative_info { nodeIP = IPv6 ip6 })
             <$> global6
     addr4 <- atomically $ newTChan
     addr6 <- atomically $ newTChan
     routing <- atomically $ do
         let nobkts = R.defaultBucketCount :: Int
-        tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info nobkts
+        tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 nobkts
         tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 nobkts
         let updateIPVote tblvar addrvar a = do
                 bkts <- readTVar tblvar
@@ -457,6 +534,7 @@ newClient addr = do
             map_var <- atomically $ newTVar (drg, mempty)
             return $ Left (mapT,map_var)
     let net = onInbound (updateRouting outgoingClient routing)
+              $ addVerbosity
               $ layerTransport (parsePacket secret cache)
                                (encodePacket secret cache)
               $ udp
@@ -477,6 +555,10 @@ newClient addr = do
         handlers PingType     = handler PongType pingH
         handlers GetNodesType = handler SendNodesType $ getNodesH routing
         handlers _            = Nothing
+        -- TODO DHTRequest public key (onion)
+        -- TODO DHTRequest NAT ping
+        -- TODO BootstrapInfo 0xf0
+        -- 
 
         genNonce24 var (TransactionId nonce8 _) = atomically $ do
             (g,pending) <- readTVar var
@@ -545,16 +627,36 @@ dropEnd8 :: ByteString -> ByteString
 dropEnd8 bs = B.take (B.length bs - 8) bs
 
 
+-- Add detailed printouts for every packet.
+addVerbosity tr =
+    tr { awaitMessage = do
+            m <- awaitMessage tr
+            forM_ m $ mapM_ $ \(msg,addr) -> do
+                hPutStrLn stderr ( (show addr)
+                                    ++ " --> " ++ show (msgType msg))
+            return m
+       , sendMessage = \addr msg -> do
+            hPutStrLn stderr ( (show addr)
+                                ++ " <-- " ++ show (msgType msg))
+            sendMessage tr addr msg
+       }
+
 classify :: Message ByteString -> MessageClass String Method TransactionId
 classify (Message { msgType    = typ
                   , msgPayload = bs
                   , msgNonce   = nonce24 }) = go $ TransactionId (last8 bs) nonce24
  where
     go = case typ of
-            PingType      -> IsQuery PingType
-            GetNodesType  -> IsQuery GetNodesType
-            PongType      -> IsResponse
-            SendNodesType -> IsResponse
+            PingType       -> IsQuery typ
+            GetNodesType   -> IsQuery typ
+            PongType       -> IsResponse
+            SendNodesType  -> IsResponse
+            DHTRequestType -> IsQuery typ
+            OnionRequest0  -> IsQuery typ
+            OnionRequest1  -> IsQuery typ
+            OnionRequest2  -> IsQuery typ
+            AnnounceType   -> IsQuery typ
+            _              -> const $ IsUnknown ("Unknown message type: "++show typ)
 
 encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b
     = Message { msgType    = typ
@@ -631,6 +733,12 @@ pingH _ Ping = return Pong
 prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
 prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
 
+-- TODO: This should cover more cases
+isLocal (IPv6 ip6) = (ip6 == toEnum 0)
+isLocal (IPv4 ip4) = (ip4 == toEnum 0)
+
+isGlobal = not . isLocal
+
 getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes
 getNodesH routing addr (GetNodes nid) = do
     let preferred = prefer4or6 addr Nothing
@@ -639,13 +747,16 @@ getNodesH routing addr (GetNodes nid) = do
         ni4 <- R.thisNode <$> readTVar (routing4 routing)
         ni6 <- R.thisNode <$> readTVar (routing6 routing)
         return $ case ipFamily (nodeIP addr) of
-            Want_IP4 -> (id, (++ [ni6]))
-            Want_IP6 -> ((++ [ni4]), id)
-    ks  <- bool (return []) (go append4 $ routing4 routing) (preferred /= Want_IP6)
-    ks6 <- bool (return []) (go append6 $ routing6 routing) (preferred /= Want_IP4)
-    return $ case preferred of
-        Want_IP6 -> SendNodes (take 4 $ ks6 ++ ks)
-        Want_IP4 -> SendNodes (take 4 $ ks ++ ks6)
+            Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
+            Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
+            _                                -> (id, id)
+    ks  <- go append4 $ routing4 routing
+    ks6 <- go append6 $ routing6 routing
+    let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
+                                      Want_IP4 -> (ks,ks6)
+    return $ SendNodes
+           $ if null ns2 then ns1
+                         else take 4 (take 3 ns1 ++ ns2)
  where
     go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var)
 
@@ -671,9 +782,6 @@ toxSend meth unwrap msg client nid addr = do
     -- sendQuery will return (Just (Left _)) on a parse error.  We're going to
     -- blow it away with the join-either sequence.
     -- TODO: Do something with parse errors.
-    -- "Failed reading: Malformed ping.\nEmpty call stack\n"
-    -- "Failed reading: unsupported address family\nEmpty call stack\n"
-    either print (const $ return ()) $ fromMaybe (Left "Nothing") reply
     return $ join $ either (const Nothing) Just <$> reply
  where
     serializer = MethodSerializer