Reply to Announce with AnnounceResponse.

1 files changed, 105 insertions, 19 deletions

diff --git a/ToxMessage.hs b/ToxMessage.hs
index 9ea57d27..06026b49 100644
--- a/ToxMessage.hs
+++ b/ToxMessage.hs
@@ -1,9 +1,15 @@
+{-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveFunctor, DeriveTraversable,DeriveDataTypeable #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DataKinds, KindSignatures #-}
 module ToxMessage where
 
+import Debug.Trace
 import Data.ByteString (ByteString)
 import qualified Crypto.MAC.Poly1305 as Poly1305 (Auth(..))
 import qualified Crypto.PubKey.Curve25519 as Curve25519
@@ -23,6 +29,8 @@ import Foreign.Ptr
 import Foreign.Marshal.Alloc
 import System.Endian
 import Foreign.Storable
+import GHC.TypeLits
+import Data.Tuple
 
 newtype Auth = Auth Poly1305.Auth
  deriving (Eq, ByteArrayAccess)
@@ -165,6 +173,17 @@ instance Serialize (Aliased Assymetric) where
 newtype Cookie = Cookie UnclaimedAssymetric
  deriving (Eq, Ord,Data)
 
+newtype ReturnPath (n::Nat) = ReturnPath ByteString
+ deriving (Eq, Ord,Data)
+
+emptyReturnPath :: ReturnPath 0
+emptyReturnPath = ReturnPath B.empty
+
+instance KnownNat n => Serialize (ReturnPath n) where
+    -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
+    get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
+    put (ReturnPath bs) = putByteString bs
+
 data Symmetric = Symmetric
     { symmetricNonce :: Nonce24
     , symmetricAuth  :: Auth
@@ -209,10 +228,10 @@ data Packet where
     --
     --   If the return path is non empty, we should respond with OnionResponse3
     --   rather than AnnounceResponse directly.
-    Announce :: Aliased Assymetric -> Packet --0x83
+    Announce :: Aliased Assymetric -> ReturnPath 3 -> Packet --0x83
     AnnounceResponse :: Nonce8 -> UnclaimedAssymetric -> Packet -- 0x84
 
-    OnionResponse3 :: Symmetric -> ByteString -> Packet -- 0x8c
+    OnionResponse3 :: ReturnPath 3 -> Packet -> Packet -- 0x8c
     OnionResponse2 :: Symmetric -> ByteString -> Packet -- 0x8d
     OnionResponse1 :: Symmetric -> ByteString -> Packet -- 0x8e
 
@@ -222,9 +241,59 @@ data Packet where
 
  deriving (Eq, Ord,Data)
 
+class KnownNat n => OnionPacket n where
+    mkOnion :: ReturnPath n -> Packet -> Packet
+
+instance OnionPacket 0 where mkOnion _ = id
+instance OnionPacket 3 where mkOnion = OnionResponse3
+
 newtype PacketKind = PacketKind Word8
  deriving (Eq, Ord, Serialize)
 
+-- TODO: Auth fail:
+pattern OnionRequest0Type = PacketKind 128 -- 0x80     Onion Request 0
+pattern OnionRequest1Type = PacketKind 129 -- 0x81     Onion Request 1
+pattern OnionRequest2Type = PacketKind 130 -- 0x82     Onion Request 2
+pattern AnnounceType  = PacketKind 131 -- 0x83     Announce Request
+pattern AnnounceResponseType = PacketKind 132 -- 0x84     Announce Response
+-- 0x85     Onion Data Request (data to route request packet)
+-- 0x86     Onion Data Response (data to route response packet)
+-- 0x8c     Onion Response 3
+-- 0x8d     Onion Response 2
+pattern OnionResponse3Type = PacketKind 140 -- 0x8c     Onion Response 3
+pattern OnionResponse2Type = PacketKind 141 -- 0x8d     Onion Response 2
+pattern OnionResponse1Type = PacketKind 142 -- 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
+
+-- TODO: Auth fail:
+pattern DHTRequestType = PacketKind 32 -- 0x20     DHT Request
+
+pattern PingType      = PacketKind 0 -- 0x00     Ping Request
+pattern PongType      = PacketKind 1 -- 0x01     Ping Response
+pattern GetNodesType  = PacketKind 2 -- 0x02     Nodes Request
+pattern SendNodesType = PacketKind 4 -- 0x04     Nodes Response
+
+
+instance Show PacketKind where
+    showsPrec d PingType = mappend "PingType"
+    showsPrec d PongType = mappend "PongType"
+    showsPrec d GetNodesType = mappend "GetNodesType"
+    showsPrec d SendNodesType = mappend "SendNodesType"
+    showsPrec d DHTRequestType = mappend "DHTRequestType"
+    showsPrec d OnionRequest0Type = mappend "OnionRequest0"
+    showsPrec d OnionResponse1Type = mappend "OnionResponse1"
+    showsPrec d OnionResponse3Type = mappend "OnionResponse3"
+    showsPrec d AnnounceType = mappend "AnnounceType"
+    showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
+
 pktKind :: Packet -> PacketKind
 
 -- These are (Assymetric -> Assymetric) queries.
@@ -286,10 +355,25 @@ pktKind OnionResponse3   {} = PacketKind 0x8c
 
 data PacketClass =
     AssymetricClass (Assymetric -> Packet) (Packet -> Assymetric)
-    | AliasedClass (Aliased Assymetric -> Packet) (Packet -> Aliased Assymetric)
+    | forall n. OnionPacket n => AliasedClass ((Aliased Assymetric,ReturnPath n) -> Packet) (Packet -> (Aliased Assymetric,ReturnPath n))
+    | forall n. OnionPacket n => OnionClass ((Packet,ReturnPath n) -> Packet) (Packet -> (Packet,ReturnPath n))
     | NoncedUnclaimedClass (Nonce8 -> UnclaimedAssymetric -> Packet)
                            (Packet -> (Nonce8, UnclaimedAssymetric))
     | Unclassified
+{-
+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
+-}
 
 pktClass :: PacketKind -> PacketClass
 pktClass (PacketKind 0) = AssymetricClass Ping (\(Ping a) -> a)
@@ -301,9 +385,11 @@ pktClass (PacketKind 0x18) = AssymetricClass CookieRequest (\(CookieRequest a) -
 pktClass (PacketKind 0x80) = AssymetricClass OnionRequest0 (\(OnionRequest0 a) -> a)
 -- pktClass (PacketKind 0x86) = AssymetricClass (DataToRouteResponse . Aliased) (\(DataToRouteResponse (Aliased a)) -> a)
 
-pktClass (PacketKind 0x83) = AliasedClass Announce (\(Announce a)-> a)
+pktClass (PacketKind 0x83) = AliasedClass (uncurry Announce) (\(Announce a r)-> (a,r))
 pktClass (PacketKind 0x84) = NoncedUnclaimedClass AnnounceResponse (\(AnnounceResponse n8 uncl)-> (n8,uncl))
 
+pktClass (PacketKind 0x8c) = OnionClass (uncurry OnionResponse3 . swap) (\(OnionResponse3 r a)-> (a,r))
+
 pktClass _ = Unclassified
 
 
@@ -315,27 +401,27 @@ getPacket = do
     typ <- get
     case pktClass typ of
         AssymetricClass toPacket _      -> toPacket <$> get
-        AliasedClass    toPacket _      -> toPacket <$> get
+        AliasedClass    toPacket _      -> do
+            trace ("PARSE "++show typ) $ return ()
+            cnt <- remaining
+            a <- isolate (cnt - 59*3) get
+            r <- get
+            trace ("PARSED "++show typ) $ return ()
+            return $ toPacket (a,r)
+        OnionClass      toPacket _      -> do
+            trace ("ONION-PARSE "++show typ) $ return ()
+            p <- get
+            trace ("ONION-PARSED "++show typ) $ return ()
+            return $ toPacket p
         NoncedUnclaimedClass toPacket _ -> toPacket <$> get <*> get
+        Unclassified -> fail $ "todo: unserialize packet "++show typ
 
 putPacket p = do
     put $ pktKind p
     case pktClass (pktKind p) of
         AssymetricClass _ fromPacket      -> put $ fromPacket p
         AliasedClass    _ fromPacket      -> put $ fromPacket p
+        OnionClass      _ fromPacket      -> put $ swap $ fromPacket p
         NoncedUnclaimedClass _ fromPacket -> put $ fromPacket p -- putting a pair.
+        Unclassified -> fail $ "todo: serialize packet "++show (pktKind 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
--}