1 files changed, 158 insertions, 15 deletions

diff --git a/Tox.hs b/Tox.hs
index 77cd0ae0..25c650b3 100644
--- a/Tox.hs
+++ b/Tox.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
 module Tox where
 
 import Control.Arrow
@@ -21,9 +22,10 @@ import Crypto.PubKey.Curve25519
 import Crypto.PubKey.ECC.Types
 import Crypto.Random
 import Data.Bool
-import Data.ByteArray                   as BA
-import Data.ByteString                  (ByteString)
-import Data.ByteString                  as B
+import qualified Data.ByteArray               as BA
+         ;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)
@@ -39,26 +41,122 @@ import Foreign.Ptr
 import Foreign.Storable
 import GHC.Generics                     (Generic)
 import Network.Address                  (Address, fromSockAddr, sockAddrPort,
-                                         toSockAddr, withPort)
+                                         toSockAddr, setPort,un4map)
 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
 
 newtype NodeId = NodeId ByteString
- deriving (Eq,Ord,Show,ByteArrayAccess)
+ deriving (Eq,Ord,ByteArrayAccess, Bits)
+
+instance Show NodeId where
+    show (NodeId bs) = C8.unpack $ Base16.encode bs
 
 instance S.Serialize NodeId where
     get = NodeId <$> S.getBytes 32
     put (NodeId bs) = S.putByteString bs
 
+instance FiniteBits NodeId where
+    finiteBitSize _ = 256
+
+instance Read NodeId where
+    readsPrec _ str
+        | (bs, xs) <- Base16.decode $ C8.pack str
+        , B.length bs == 32
+                    = [ (NodeId bs, drop 40 str) ]
+        | otherwise = []
+
+zeroID :: NodeId
+zeroID = NodeId $ B.replicate 32 0
+
 data NodeInfo = NodeInfo
   { nodeId   :: NodeId
-  , nodeIP :: IP
+  , nodeIP   :: IP
   , nodePort :: PortNumber
   }
+ deriving (Eq,Ord)
+
+instance S.Serialize NodeInfo where
+    get = do
+        nid <- S.get
+        addrfam <- S.get :: S.Get Word8
+        ip <- case addrfam of
+            2   -> IPv4 <$> S.get
+            10  -> IPv6 <$> S.get
+            130 -> IPv4 <$> S.get -- TODO: TCP
+            138 -> IPv6 <$> S.get -- TODO: TCP
+            _   -> fail "unsupported address family"
+        port <- S.get :: S.Get PortNumber
+        return $ NodeInfo nid ip port
+
+    put (NodeInfo nid ip port) = do
+        S.put nid
+        case ip of
+            IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
+            IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
+        S.put port
+
+-- node format:
+-- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)]
+-- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6]
+-- [port (in network byte order), length=2 bytes]
+-- [char array (node_id), length=32 bytes]
+--
+
+
+hexdigit :: Char -> Bool
+hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
+
+instance Read NodeInfo where
+  readsPrec i = RP.readP_to_S $ do
+    RP.skipSpaces
+    let n = 64 -- characters in node id.
+        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
+                      RP.+++ RP.munch (not . isSpace)
+        nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
+                      RP.char '@' RP.+++ RP.satisfy isSpace
+                      addrstr <- parseAddr
+                      nid <- case Base16.decode $ C8.pack hexhash of
+                              (bs,_) | B.length bs==32 -> return (NodeId bs)
+                              _                        -> fail "Bad node id."
+                      return (nid,addrstr)
+    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
+    let raddr = do
+            ip <- RP.between (RP.char '[') (RP.char ']')
+                         (IPv6 <$> RP.readS_to_P (readsPrec i))
+                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
+            _    <- RP.char ':'
+            port <- toEnum <$> RP.readS_to_P (readsPrec i)
+            return (ip, port)
+
+    (ip,port) <- case RP.readP_to_S raddr addrstr of
+                    [] -> fail "Bad address."
+                    ((ip,port),_):_ -> return (ip,port)
+    return $ NodeInfo nid ip port
+
+
+-- The Hashable instance depends only on the IP address and port number.
+instance Hashable NodeInfo where
+  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
+  {-# INLINE hashWithSalt #-}
+
+
+instance Show NodeInfo where
+    showsPrec _ (NodeInfo nid ip port) =
+        shows nid . ('@' :) . showsip . (':' :) . shows port
+     where
+        showsip
+            | IPv4 ip4 <- ip                          = shows ip4
+            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
+            | otherwise                               = ('[' :) . shows ip . (']' :)
 
 nodeAddr :: NodeInfo -> SockAddr
-nodeAddr (NodeInfo _ ip port) = toSockAddr ip `withPort` port
+nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip
 
 nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
 nodeInfo nid saddr
@@ -113,13 +211,13 @@ quoted :: ShowS -> ShowS
 quoted shows s = '"':shows ('"':s)
 
 bin2hex :: ByteArrayAccess bs => bs -> String
-bin2hex = C8.unpack . Base16.encode . convert
+bin2hex = C8.unpack . Base16.encode . BA.convert
 
 
 data Message a = Message
     { msgType    :: Method
     , msgOrigin  :: NodeId
-    , msgNonce   :: Nonce24
+    , msgNonce   :: Nonce24 -- cryptoNonce of TransactionId
     , msgPayload :: a
     }
  deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
@@ -133,7 +231,7 @@ getMessage = do
         typ <- S.get
         nid <- S.get
         tid <- S.get
-        mac <- Poly1305.Auth . convert <$> S.getBytes 16
+        mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16
         cnt <- S.remaining
         bs <- S.getBytes cnt
         return Message { msgType    = typ
@@ -147,9 +245,21 @@ putMessage (Message {..}) = do
         S.put msgOrigin
         S.put msgNonce
         let Ciphered (Poly1305.Auth mac) bs = msgPayload
-        S.putByteString (convert mac)
+        S.putByteString (BA.convert mac)
         S.putByteString bs
 
+{-
+data Plain a = Plain
+    { plainId      :: Nonce8 -- transactionKey of TransactionId
+    , plainPayload :: a
+    }
+ deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
+
+instance Serialize a => Serialize (Plain a) where
+    get = flip Plain <$> get get
+    put (Plain tid a) = put a >> put tid
+-}
+
 -- TODO: Cache symmetric keys.
 data SecretsCache = SecretsCache
 newEmptyCache = return SecretsCache
@@ -268,7 +378,7 @@ newClient addr = do
             , clientDispatcher    = dispatch tbl
             , clientErrorReporter = ignoreErrors -- TODO
             , clientPending       = var
-            , clientAddress       = atomically (readTVar self)
+            , clientAddress       = \maddr -> atomically (readTVar self)
             , clientResponseId    = genNonce24 var
             }
     if fitsInInt (Proxy :: Proxy Word64)
@@ -323,10 +433,43 @@ handlers PingType     = handler PingType pingH
 handlers GetNodesType = error "find_node"
 handlers _            = Nothing
 
-data Ping = Ping
+data Ping = Ping deriving Show
+data Pong = Pong deriving Show
+
+instance S.Serialize Ping where
+    get = do w8 <- S.get
+             if (w8 :: Word8) /= 0
+                then fail "Malformed ping."
+                else return Ping
+    put Ping = S.put (0 :: Word8)
+
+instance S.Serialize Pong where
+    get = do w8 <- S.get
+             if (w8 :: Word8) /= 1
+                then fail "Malformed pong."
+                else return Pong
+    put Pong = S.put (1 :: Word8)
+
+newtype GetNodes = GetNodes NodeId
+    deriving (Eq,Ord,Show,Read,S.Serialize)
+
+newtype SendNodes = SendNodes [NodeInfo]
+    deriving (Eq,Ord,Show,Read)
+
+instance S.Serialize SendNodes where
+    get = do
+        cnt <- S.get :: S.Get Word8
+        ns <- sequence $ replicate (fromIntegral cnt) S.get
+        return $ SendNodes ns
+
+    put (SendNodes ns) = do
+        let ns' = take 4 ns
+        S.put (fromIntegral (length ns') :: Word8)
+        mapM_ S.put ns'
+
 
-pingH :: NodeInfo -> Ping -> IO Ping
-pingH = error "pingH"
+pingH :: NodeInfo -> Ping -> IO Pong
+pingH _ Ping = return Pong
 
 intKey :: TransactionId -> Int
 intKey (TransactionId (Nonce8 w) _) = fromIntegral w