From 036bfce939c38f7fc98b96e1a9bf11135929cb5d Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 5 Aug 2017 03:38:54 -0400 Subject: Alternative Tox packet representation. --- ToxMessage.hs | 289 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 289 insertions(+) create mode 100644 ToxMessage.hs diff --git a/ToxMessage.hs b/ToxMessage.hs new file mode 100644 index 00000000..6853a4a1 --- /dev/null +++ b/ToxMessage.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor, DeriveTraversable,DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +module ToxMessage where + +import Data.ByteString (ByteString) +import qualified Crypto.MAC.Poly1305 as Poly1305 (Auth(..)) +import qualified Crypto.PubKey.Curve25519 as Curve25519 +import Data.ByteArray as BA (ByteArrayAccess, Bytes) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Base16 as Base16 +import Data.Bits +import Data.Hashable +import Data.Bits.ByteString () +import Data.Word +import Data.Data +import Data.Ord +import Data.Serialize + +newtype Auth = Auth Poly1305.Auth + deriving (Eq, ByteArrayAccess) + +instance Ord Auth where + compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b + +instance Data Auth where + gfoldl k z x = z x + + -- Well, this is a little wonky... XXX + gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes))) + + toConstr _ = con_Auth + + dataTypeOf _ = mkDataType "ToxMessage" [con_Auth] + +con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix + +instance Serialize Auth where + get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16 + put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs +-- +-- | An 'Aliased' 'PubKey' is one that is not the DHT key and so should not go +-- into the kademlia routing table buckets. +-- +-- Note: This includes the long-term tox-id key that humans use to friend each +-- other and is often refered to as your "real public key" by the Tox +-- documents. For the purposes of the DHT, it is an alias. +newtype Aliased a = Aliased a + deriving (Eq,Ord,Show,Data,Functor,Foldable,Traversable,Serialize) + +newtype Nonce24 = Nonce24 ByteString + deriving (Eq, Ord, ByteArrayAccess,Data) + +quoted :: ShowS -> ShowS +quoted shows s = '"':shows ('"':s) + +bin2hex :: ByteArrayAccess bs => bs -> String +bin2hex = C8.unpack . Base16.encode . BA.convert + +instance Show Nonce24 where + showsPrec d nonce = quoted (mappend $ bin2hex nonce) + +instance Serialize Nonce24 where + get = Nonce24 <$> getBytes 24 + put (Nonce24 bs) = putByteString bs + +newtype Nonce8 = Nonce8 Word64 + deriving (Eq, Ord,Data) + +-- TODO: This should probably be represented by Curve25519.PublicKey, but +-- ByteString has more instances... +newtype PubKey = PubKey ByteString + deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable) + +instance Serialize PubKey where + get = PubKey <$> getBytes 32 + put (PubKey bs) = putByteString bs + +instance Show PubKey where + show (PubKey bs) = C8.unpack $ Base16.encode bs + +instance FiniteBits PubKey where + finiteBitSize _ = 256 + +instance Read PubKey where + readsPrec _ str + | (bs, xs) <- Base16.decode $ C8.pack str + , B.length bs == 32 + = [ (PubKey bs, drop 64 str) ] + | otherwise = [] + + + +-- | A chunk of data encrypted with public-key cryptography. +data ImplicitAssymetric = ImplicitAssymetric + { assymetricAuth :: Auth + , assymetricBytes :: ByteString + } + deriving (Eq, Ord,Data) + +getRemaining = remaining >>= getBytes + +instance Serialize ImplicitAssymetric where + get = ImplicitAssymetric <$> get <*> getRemaining + put (ImplicitAssymetric auth bs) = put auth >> putByteString bs + +-- | Like ImplicitAssymetric, but includes the nonce used to encrypt. +data UnclaimedAssymetric = UnclaimedAssymetric + { assymetricNonce :: Nonce24 + , assymetricData :: !ImplicitAssymetric + } + deriving (Eq, Ord, Data) + +instance Serialize UnclaimedAssymetric where + get = UnclaimedAssymetric <$> get <*> get + put (UnclaimedAssymetric nonce dta) = put nonce >> put dta + +-- | Like UnclaimedAssymetric, but includes the public key of the sender. +data Assymetric = Assymetric + { senderKey :: PubKey + , sent :: !UnclaimedAssymetric + } + deriving (Eq, Ord,Data) + +-- get requires isolate. +instance Serialize Assymetric where + get = Assymetric <$> get <*> get + put (Assymetric key dta) = put key >> put dta + +newtype Cookie = Cookie UnclaimedAssymetric + deriving (Eq, Ord,Data) + +data Symmetric = Symmetric + { symmetricNonce :: Nonce24 + , symmetricAuth :: Auth + , symmetricBytes :: ByteString + } + deriving (Eq, Ord,Data) + +data Packet where + Ping :: Assymetric -> Packet -- 0x00 -- Assymetric query + Pong :: Assymetric -> Packet -- 0x01 -- Assymetric response + + GetNodes :: Assymetric -> Packet -- 0x02 -- Assymetric query + SendNodes :: Assymetric -> Packet -- 0x04 -- Assymetric response + + CookieRequest :: Assymetric -> Packet -- 0x18 + CookieResponse :: UnclaimedAssymetric -> Packet -- 0x19 + + OnionRequest0 :: Assymetric -> Packet -- 0x80 + + + CryptoHandshake :: Cookie -> UnclaimedAssymetric -> Packet -- 0x1a + + CryptoData :: Word16 -> ImplicitAssymetric -> Packet -- 0x1b + + DHTRequest :: PubKey -> Assymetric -> Packet -- 0x20 -- Sometimes Assymetric query + + DataToRoute :: PubKey -> Aliased Assymetric -> Packet + DataToRouteResponse :: Aliased Assymetric -> Packet + + LanDiscovery :: PubKey -> Packet -- 0x21 + + OnionRequest1 :: Aliased Assymetric -> Symmetric -> Packet -- 0x81 + OnionRequest2 :: Aliased Assymetric -> Symmetric -> Packet -- 0x82 + + OnionRequest3 :: ByteString -> Symmetric -> Packet -- 0x82 + + Announce :: Aliased Assymetric -> Packet --0x83 + AnnounceResponse :: Nonce8 -> UnclaimedAssymetric -> Packet -- 0x84 + + OnionResponse3 :: Symmetric -> ByteString -> Packet -- 0x8c + OnionResponse2 :: Symmetric -> ByteString -> Packet -- 0x8d + OnionResponse1 :: Symmetric -> ByteString -> Packet -- 0x8e + + + GetBootstrapInfo :: ByteString -> Packet -- 0xf0 + 77 bytes -- ByteString query + BootstrapInfo :: Word32 -> ByteString -> Packet -- 0xf0 + version + (256 byte motd) -- ByteSTring response + + deriving (Eq, Ord,Data) + +newtype PacketKind = PacketKind Word8 + deriving (Eq, Ord, Serialize) + +pktKind :: Packet -> PacketKind + +-- These are (Assymetric -> Assymetric) queries. +pktKind Ping {} = PacketKind 0x00 +pktKind Pong {} = PacketKind 0x01 +pktKind GetNodes {} = PacketKind 0x02 +pktKind SendNodes {} = PacketKind 0x04 + + +-- This is a (Assymetric -> UnclaimedAssymetric) query +pktKind CookieRequest {} = PacketKind 0x18 +pktKind CookieResponse {} = PacketKind 0x19 + +-- Query (Assymetric -> (Nonce8,UnclaimedAssymetric)) +pktKind Announce {} = PacketKind 0x83 +pktKind AnnounceResponse {} = PacketKind 0x84 + +-- Query (Assymetric -> ByteString) +pktKind OnionRequest0 {} = PacketKind 0x80 + + +-- This is a (ByteString -> ByteString) query +pktKind GetBootstrapInfo {} = PacketKind 0xf0 +pktKind BootstrapInfo {} = PacketKind 0xf0 + + +-- Trigering event. No direct response. (PubKey -> ()) +pktKind LanDiscovery {} = PacketKind 0x21 + +-- Two cases: +-- Half-established: (Cookie,UnclaimedAssymetric) -> (Cookie,UnclaimedAssymetric) +-- Session established: (Cookie,UnclaimedAssymetric) -> (Word16,ImplicitAssymetric) +pktKind CryptoHandshake {} = PacketKind 0x1a + +-- Session data, no direct response. +-- (reponse to CryptoHandshake, or other data) +pktKind CryptoData {} = PacketKind 0x1b + +-- Two cases: +-- ( (PubKey, Assymetric) -> response ) +-- ( (PubKey, Assymetric) -> () ) +pktKind DHTRequest {} = PacketKind 0x20 + + +-- Query ( (PubKey,Aliased Assymetric) -> Aliased Assymetric) +pktKind DataToRoute {} = PacketKind 0x85 +pktKind DataToRouteResponse {} = PacketKind 0x86 + +-- 3 Queries ( (Aliased Assymetric, Symmetric ) +-- -> ( Symmetric, ByteString ) ) +pktKind OnionRequest1 {} = PacketKind 0x81 +pktKind OnionResponse1 {} = PacketKind 0x8e + +pktKind OnionRequest2 {} = PacketKind 0x82 +pktKind OnionResponse2 {} = PacketKind 0x8d + +pktKind OnionRequest3 {} = PacketKind 0x82 +pktKind OnionResponse3 {} = PacketKind 0x8c + +data PacketClass = + AssymetricClass (Assymetric -> Packet) (Packet -> Assymetric) + | Unclassified + +pktClass :: PacketKind -> PacketClass +pktClass (PacketKind 0) = AssymetricClass Ping (\(Ping a) -> a) +pktClass (PacketKind 1) = AssymetricClass Pong (\(Pong a) -> a) +pktClass (PacketKind 2) = AssymetricClass GetNodes (\(GetNodes a) -> a) +pktClass (PacketKind 4) = AssymetricClass SendNodes (\(SendNodes a) -> a) + +pktClass (PacketKind 0x18) = AssymetricClass CookieRequest (\(CookieRequest a) -> a) +pktClass (PacketKind 0x80) = AssymetricClass OnionRequest0 (\(OnionRequest0 a) -> a) +pktClass (PacketKind 0x86) = AssymetricClass (DataToRouteResponse . Aliased) (\(DataToRouteResponse (Aliased a)) -> a) + + -- (indexConstr (dataTypeOf (error "dataTypeOf Packet" :: Packet)) 0) -- Ping + +instance Serialize Packet where + get = getPacket + put = putPacket + +getPacket = do + typ <- get + case pktClass typ of + AssymetricClass toPacket fromPacket -> toPacket <$> get + +putPacket p = do + put $ pktKind p + case pktClass (pktKind p) of + AssymetricClass toPacket fromPacket -> put $ fromPacket p + +{- +data Packet' where + :: Assymetric -> Packet + :: UnclaimedAssymetric -> Packet + :: Word16 -> ImplicitAssymetric -> Packet + :: PubKey -> Assymetric -> Packet + :: PubKey -> Packet + :: Aliased Assymetric -> Symmetric -> Packet + :: ByteString -> Symmetric -> Packet + :: Aliased Assymetric -> Packet + :: Symmetric -> ByteString -> Packet + :: ByteString -> Packet + :: Word32 -> ByteString -> Packet +-} -- cgit v1.2.3