path: root/src/Data/Tox.hs

{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DeriveTraversable     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UnboxedTuples         #-}
module Data.Tox where

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.RPC hiding (NodeId)
import qualified Network.RPC as Envelope (NodeId)
import Crypto.PubKey.ECC.Types

type Key32   = Word256 -- 32 byte key
type Nonce8  = Word64  -- 8 bytes
type Nonce24 = Word192 -- 24 bytes
type NodeId  = Word256 -- 32 bytes (mainline uses only 20-byte node IDs)


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
    , msgNonce   :: Nonce24
    , msgPayload :: a
    }
 deriving (Show, Generic, Functor, Foldable, Traversable)

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
    , 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
    type NodeId Message = NodeId

    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