Renamed Data.Tox -> Network.DatagramServer.Tox

2 files changed, 280 insertions, 1 deletions

diff --git a/src/Network/DatagramServer/Mainline.hs b/src/Network/DatagramServer/Mainline.hs
index 2177d076..70b9b184 100644
--- a/src/Network/DatagramServer/Mainline.hs
+++ b/src/Network/DatagramServer/Mainline.hs
@@ -65,7 +65,7 @@ import Control.Exception.Lifted as Lifted
 #ifdef VERSION_bencoding
 import Data.BEncode as BE
 #else
-import qualified Data.Tox as Tox
+import qualified Network.DatagramServer.Tox as Tox
 #endif
 import Data.ByteString as B
 import Data.ByteString.Char8 as BC
diff --git a/src/Network/DatagramServer/Tox.hs b/src/Network/DatagramServer/Tox.hs
new file mode 100644
index 00000000..ad376c68
--- /dev/null
+++ b/src/Network/DatagramServer/Tox.hs
@@ -0,0 +1,279 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DeriveTraversable     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms       #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UnboxedTuples         #-}
+module Network.DatagramServer.Tox where
+
+import Data.Bits
+import Data.ByteString (ByteString)
+import Data.Data (Data)
+import Data.Word
+import Data.LargeWord
+import Data.IP
+import Data.Serialize
+-- import Network.BitTorrent.Address (NodeInfo(..)) -- Serialize IP
+import GHC.Generics (Generic)
+import Network.Socket
+import Network.DatagramServer.Types
+import qualified Network.DatagramServer.Types as Envelope (NodeId)
+import Crypto.PubKey.ECC.Types
+
+type Key32   = Word256 -- 32 byte key
+type Nonce8  = Word64  -- 8 bytes
+type Nonce24 = Word192 -- 24 bytes
+
+
+data NodeFormat  = NodeFormat
+    { nodePublicKey :: Key32 -- 32 byte public key
+    , nodeIsTCP :: Bool -- This has no analog in mainline NodeInfo structure
+    , nodeIP :: IP -- IPv4 or IPv6  address
+    , nodePort :: PortNumber
+    }
+ deriving (Eq, Ord, Show)
+
+encodeFamily :: (Family, SocketType) -> Word8
+encodeFamily (AF_INET   , Datagram) = 2
+encodeFamily (AF_INET6  , Datagram) = 10
+encodeFamily (AF_INET   , Stream  ) = 130
+encodeFamily (AF_INET6  , Stream  ) = 138
+encodeFamily _ = error "Unsupported protocol"
+
+newtype MessageType = MessageType Word8
+ deriving (Eq, Ord, Show, Read)
+
+instance Serialize MessageType where
+    put (MessageType b) = put b
+    get = MessageType <$> get
+
+pattern Ping      = MessageType 0
+pattern Pong      = MessageType 1
+pattern GetNodes  = MessageType 2
+pattern SendNodes = MessageType 4
+{-
+ #define NET_PACKET_PING_REQUEST    0   /* Ping request packet ID. */
+ #define NET_PACKET_PING_RESPONSE   1   /* Ping response packet ID. */
+ #define NET_PACKET_GET_NODES       2   /* Get nodes request packet ID. */
+ #define NET_PACKET_SEND_NODES_IPV6 4   /* Send nodes response packet ID for other addresses. */
+ #define NET_PACKET_COOKIE_REQUEST  24  /* Cookie request packet */
+ #define NET_PACKET_COOKIE_RESPONSE 25  /* Cookie response packet */
+ #define NET_PACKET_CRYPTO_HS       26  /* Crypto handshake packet */
+ #define NET_PACKET_CRYPTO_DATA     27  /* Crypto data packet */
+ #define NET_PACKET_CRYPTO          32  /* Encrypted data packet ID. */
+ #define NET_PACKET_LAN_DISCOVERY   33  /* LAN discovery packet ID. */
+
+ /* See:  docs/Prevent_Tracking.txt and onion.{c, h} */
+ #define NET_PACKET_ONION_SEND_INITIAL 128
+ #define NET_PACKET_ONION_SEND_1 129
+ #define NET_PACKET_ONION_SEND_2 130
+
+ #define NET_PACKET_ANNOUNCE_REQUEST 131
+ #define NET_PACKET_ANNOUNCE_RESPONSE 132
+ #define NET_PACKET_ONION_DATA_REQUEST 133
+ #define NET_PACKET_ONION_DATA_RESPONSE 134
+
+ #define NET_PACKET_ONION_RECV_3 140
+ #define NET_PACKET_ONION_RECV_2 141
+ #define NET_PACKET_ONION_RECV_1 142
+ -}
+
+
+-- FIXME Orphan Serialize intance for large words
+instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where
+   put (LargeKey lo hi) = put hi >> put lo
+   get = flip LargeKey <$> get <*> get
+
+-- | Use with 'PingPayload', 'GetNodesPayload', or 'SendNodesPayload'
+data Message a = Message
+    { msgType    :: MessageType
+    , msgClient  :: NodeId Message
+    , msgNonce   :: Nonce24
+    , msgPayload :: a
+    }
+ deriving (Show, Generic, Functor, Foldable, Traversable)
+
+deriving instance Show (NodeId Message) -- TODO: print as hex
+
+isQuery :: Message a -> Bool
+isQuery (Message { msgType = SendNodes })                  = False
+isQuery (Message { msgType = MessageType typ }) | even typ = True
+isQuery _                                                  = False
+
+isResponse :: Message a -> Bool
+isResponse m = not (isQuery m)
+
+isError :: Message a -> Bool
+isError _ = False
+
+data PingPayload = PingPayload
+    { isPong :: Bool
+    , pingId :: Nonce8
+    }
+
+data GetNodesPayload = GetNodesPayload
+    { nodesForWho :: NodeId Message
+    , nodesNonce :: Nonce8
+    }
+
+data SendNodesPayload = SendNodesPayload
+
+-- From: docs/updates/DHT.md
+--
+-- 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]
+--
+-- see also: DHT.h (pack_nodes() and unpack_nodes())
+instance Serialize NodeFormat where
+
+    get = do
+        typ <- get :: Get Word8
+        (ip,istcp) <-
+            case typ :: Word8 of
+                2   -> (,False) . IPv4 <$> get
+                130 -> (,True) . IPv4 <$> get
+                10  -> (,False) . IPv6 <$> get
+                138 -> (,True) . IPv6 <$> get
+                _   -> fail "Unsupported type of Tox node_format structure"
+        port <- get
+        pubkey <- get
+        return $ NodeFormat { nodeIsTCP     = istcp
+                            , nodeIP        = ip
+                            , nodePort      = port
+                            , nodePublicKey = pubkey
+                            }
+
+    put (NodeFormat{..}) = do
+        put $ case (# nodeIP, nodeIsTCP #) of
+                (# IPv4 _, False #) -> 2
+                (# IPv4 _, True  #) -> 130
+                (# IPv6 _, False #) -> 10
+                (# IPv6 _, True  #) -> 138 :: Word8
+        put nodeIP
+        put nodePort
+        put nodePublicKey
+
+-- Note: the char array is a public key, the 32-bytes is provided by libsodium-dev
+-- in /usr/include/sodium/crypto_box.h as the symbol crypto_box_PUBLICKEYBYTES
+-- but toxcore/crypto_core.c will fail to compile if it is not 32.
+
+
+-- Ping(Request and response):
+--
+-- [byte with value: 00 for request, 01 for response]
+-- [char array (client node_id), length=32 bytes]
+-- [random 24 byte nonce]
+-- [Encrypted with the nonce and private key of the sender:
+--   [1 byte type (0 for request, 1 for response)]
+--   [random 8 byte (ping_id)]
+--   ]
+--
+-- ping_id = a random integer, the response must contain the exact same number as the request
+
+
+-- Get nodes (Request):
+--
+-- [byte with value: 02]
+-- [char array (client node_id), length=32 bytes]
+-- [random 24 byte nonce]
+-- [Encrypted with the nonce and private key of the sender:
+--   [char array: requested_node_id (node_id of which we want the ip), length=32 bytes]
+--   [Sendback data (must be sent back unmodified by in the response), length=8 bytes]
+--   ]
+--
+-- Valid replies: a send_nodes packet
+
+-- Send_nodes (response (for all addresses)):
+--
+-- [byte with value: 04]
+-- [char array  (client node_id), length=32 bytes]
+-- [random 24 byte nonce]
+-- [Encrypted with the nonce and private key of the sender:
+--   [uint8_t number of nodes in this packet]
+--   [Nodes in node format, length=?? * (number of nodes (maximum of 4 nodes)) bytes]
+--   [Sendback data, length=8 bytes]
+--   ]
+
+data ToxCipherContext = ToxCipherContext -- TODO
+
+newtype Ciphered = Ciphered { cipheredBytes :: ByteString }
+
+getMessage :: Get (Message Ciphered)
+getMessage = do
+        typ <- get
+        nid <- get
+        tid <- get
+        cnt <- remaining
+        bs <- getBytes cnt
+        return Message { msgType = typ
+                       , msgClient = nid
+                       , msgNonce = tid
+                       , msgPayload = Ciphered bs }
+
+putMessage :: Message Ciphered -> Put
+putMessage (Message {..}) = do
+        put msgType
+        put msgClient
+        put msgNonce
+        let Ciphered bs = msgPayload
+        putByteString bs
+
+decipher :: ToxCipherContext -> Message Ciphered -> Either String (Message ByteString)
+decipher = error "TODO TOX: decipher"
+
+encipher :: ToxCipherContext -> Message ByteString -> Message Ciphered
+encipher = error "TODO TOX: encipher"
+
+-- see rfc7748
+curve25519 :: Curve
+curve25519 = CurveFP (CurvePrime prime curvecommon)
+ where
+    prime = 2^255 - 19 -- (≅ 1 modulo 4)
+
+    -- 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_n = 2^252 + 0x14def9dea2f79cd65812631a5cf5d3ed -- order
+        , ecc_h = 8 -- cofactor
+        }
+
+
+
+instance Envelope Message where
+    type TransactionID Message = Nonce24
+    newtype NodeId Message = NodeId Word256
+        deriving (Serialize, Eq, Ord, Bits, FiniteBits)
+
+    envelopePayload = msgPayload
+
+    envelopeTransaction = msgNonce
+
+    envelopeClass Message { msgType = Ping      } = Query
+    envelopeClass Message { msgType = Pong      } = Response
+    envelopeClass Message { msgType = GetNodes  } = Query
+    envelopeClass Message { msgType = SendNodes } = Response
+
+    buildReply self addr qry payload = (fmap (const payload) qry) { msgClient = self }
+
+instance WireFormat ByteString Message where
+    type SerializableTo ByteString = Serialize
+    type CipherContext ByteString Message = ToxCipherContext
+
+    decodePayload = mapM decode
+    encodePayload = fmap encode
+
+    decodeHeaders ctx bs = runGet getMessage bs >>= decipher ctx
+    encodeHeaders ctx msg = runPut $ putMessage $ encipher ctx msg