Reply to Announce with AnnounceResponse.

3 files changed, 182 insertions, 96 deletions

diff --git a/Tox.hs b/Tox.hs
index a14e223b..4459a08f 100644
--- a/Tox.hs
+++ b/Tox.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns             #-}
@@ -12,6 +13,8 @@
 {-# LANGUAGE TupleSections              #-}
 module Tox where
 
+import Debug.Trace
+import Control.Exception hiding (Handler)
 import Control.Applicative
 import Control.Arrow
 import Control.Concurrent                     (MVar)
@@ -75,10 +78,11 @@ import System.IO
 import qualified Text.ParserCombinators.ReadP as RP
 import Text.Printf
 import Text.Read
-import qualified ToxMessage                   as Tox
+import ToxMessage                   as Tox hiding (Ping,Pong,SendNodes,GetNodes,AnnounceResponse)
          ;import ToxMessage                   (bin2hex, quoted)
 import TriadCommittee
 import Network.BitTorrent.DHT.Token           as Token
+import GHC.TypeLits
 
 {-
 newtype NodeId = NodeId ByteString
@@ -235,53 +239,13 @@ data TransactionId = TransactionId
  , cryptoNonce    :: Tox.Nonce24 -- ^ Used during the encryption layer.
  }
 
-pattern PingType      = Tox.PacketKind 0 -- 0x00     Ping Request
-pattern PongType      = Tox.PacketKind 1 -- 0x01     Ping Response
-pattern GetNodesType  = Tox.PacketKind 2 -- 0x02     Nodes Request
-pattern SendNodesType = Tox.PacketKind 4 -- 0x04     Nodes Response
 -- 0x18     Cookie Request
 -- 0x19     Cookie Response
 -- 0x1a     Crypto Handshake
 -- 0x1b     Crypto Data
 
--- TODO: Auth fail:
-pattern DHTRequestType = Tox.PacketKind 32 -- 0x20     DHT Request
-
 -- 0x21     LAN Discovery
 
--- TODO: Auth fail:
-pattern OnionRequest0 = Tox.PacketKind 128 -- 0x80     Onion Request 0
-pattern OnionRequest1 = Tox.PacketKind 129 -- 0x81     Onion Request 1
-pattern OnionRequest2 = Tox.PacketKind 130 -- 0x82     Onion Request 2
-pattern AnnounceType  = Tox.PacketKind 131 -- 0x83     Announce Request
-pattern AnnounceResponseType = Tox.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 OnionResponse1 = Tox.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
-
-
-instance Show Tox.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 OnionRequest0   = mappend "OnionRequest0"
-    showsPrec d OnionResponse1  = mappend "OnionResponse1"
-    showsPrec d AnnounceType    = mappend "AnnounceType"
-    showsPrec d (Tox.PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
-
 {-
 newtype Tox.Nonce24 = Tox.Nonce24 ByteString
  deriving (Eq, Ord, ByteArrayAccess)
@@ -317,8 +281,8 @@ data Msg = Msg
  deriving Show
 
 
-typeHasEncryptedPayload OnionResponse1 = False
-typeHasEncryptedPayload _              = True
+-- typeHasEncryptedPayload OnionResponse1Type = False
+-- typeHasEncryptedPayload _                  = True
 
 {-
 msgDHTKey Message{ msgOrigin, msgType = PingType      } = Just msgOrigin
@@ -579,42 +543,60 @@ encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache
                                , nodeAddr ni )
 -}
 
+data ToxPath = forall n. (Tox.OnionPacket n) => ToxPath NodeInfo (Tox.ReturnPath n)
+
+instance Show ToxPath where
+    show (ToxPath ni rpath)
+        | natVal rpath == 0 = show ni
+        | otherwise         = "Aliased("++show ni++")"
+
 msgLayer :: SecretKey
             -> NodeId
-            -> Transport String NodeInfo (Tox.PacketKind,InterediateRep)
-            -> Transport String NodeInfo Msg
+            -> Transport String ToxPath (Tox.PacketKind,InterediateRep)
+            -> Transport String ToxPath Msg
 msgLayer sk pk = layerTransport parse serialize
  where
+    parse :: (Tox.PacketKind,InterediateRep) -> ToxPath -> Either String (Msg,ToxPath)
     parse (typ,Assym  x)  addr = fmap (,addr) $ decryptAssymetric sk typ x
     parse (typ,Assym' x)  addr = fmap (,addr) $ decryptAssymetric sk typ x
     parse (typ,Unclm n x) addr = Right ( Msg typ (Tox.assymetricNonce x) (S.encode (Tox.assymetricData x)) n
-                                       , addr)
-    serialize x addr = case Tox.pktClass (msgType x) of
-        Tox.AssymetricClass      {} -> ((msgType x, Assym  $ encryptAssymetric sk pk (nodeId addr) x), addr)
-        Tox.AliasedClass         {} -> ((msgType x, Assym' $ encryptAssymetric sk pk (nodeId addr) x), addr)
-        Tox.NoncedUnclaimedClass {} -> ((msgType x, Unclm (msgSendBack x) $ encryptUnclm sk pk (nodeId addr) x),addr)
+                                                   , addr)
+    serialize :: Msg -> ToxPath -> ((Tox.PacketKind,InterediateRep),ToxPath)
+    serialize x addr@(ToxPath ni _) = case Tox.pktClass (msgType x) of
+        Tox.AssymetricClass      {} -> ((msgType x, Assym  $ encryptAssymetric sk pk (nodeId ni) x), addr)
+        Tox.AliasedClass         {} -> ((msgType x, Assym' $ encryptAssymetric sk pk (nodeId ni) x), addr)
+        Tox.NoncedUnclaimedClass {} -> ((msgType x, Unclm (msgSendBack x) $ encryptUnclm sk pk (nodeId ni) x),addr)
 
 data InterediateRep = Assym Tox.Assymetric
                     | Assym' Tox.Assymetric
                     | Unclm Tox.Nonce8 Tox.UnclaimedAssymetric
 
-asymLayer :: Transport String SockAddr Tox.Packet -> Transport String NodeInfo (Tox.PacketKind,InterediateRep)
-asymLayer = layerTransport parse serialize
+asymLayer :: Transport String SockAddr Tox.Packet -> Transport String ToxPath (Tox.PacketKind,InterediateRep)
+asymLayer = layerTransport parse (\p@(typ,_) -> trace ("SERIALIZE "++show typ) $ serialize p)
  where
+    parse :: Tox.Packet -> SockAddr -> Either String ((Tox.PacketKind,InterediateRep),ToxPath)
     parse x addr = case Tox.pktClass (Tox.pktKind x) of
         Tox.AssymetricClass top fromp      -> go Tox.senderKey  fromp Assym
-        Tox.AliasedClass    top fromp      -> go Tox.senderKey  ((\(Tox.Aliased a) -> a) . fromp) Assym'
+        Tox.AliasedClass    top fromp      -> let (Tox.Aliased a,rpath) = fromp x
+                                              in fmap (\ni -> ( (Tox.pktKind x, Assym' a)
+                                                              , ToxPath ni rpath ))
+                                                      $ nodeInfo (Tox.senderKey a) addr
         Tox.NoncedUnclaimedClass top fromp -> go (const zeroID) fromp (uncurry Unclm)
+        -- OnionClass
       where go mkaddr fromp c = let y = fromp x
-                                in fmap ((Tox.pktKind x,c y),)
-                                    $ nodeInfo (mkaddr y) addr
+                                in fmap ( ((Tox.pktKind x,c y),)
+                                          . (\ni -> ToxPath ni Tox.emptyReturnPath)
+                                        )
+                                        $ nodeInfo (mkaddr y) addr
 
-    serialize (typ,Assym assym) addr = (x,nodeAddr addr)
+    serialize :: (Tox.PacketKind,InterediateRep) -> ToxPath -> (Tox.Packet,SockAddr)
+    serialize (typ,Assym assym) (ToxPath addr rpath) = (x,nodeAddr addr)
         where x = case Tox.pktClass typ of Tox.AssymetricClass top _ -> top assym
-    serialize (typ,Assym' assym) addr = (x,nodeAddr addr)
-        where x = case Tox.pktClass typ of Tox.AliasedClass    top _ -> top (Tox.Aliased assym)
-    serialize (typ,Unclm nonce unclm) addr = (x,nodeAddr addr)
+    serialize (typ,Assym' assym) (ToxPath addr rpath) = (x,nodeAddr addr) -- TODO rpath
+        where x = case Tox.pktClass typ of Tox.AliasedClass    top _ -> top (Tox.Aliased assym, error "todo: ReturnPath")
+    serialize (typ,Unclm nonce unclm) (ToxPath addr rpath) = (Tox.mkOnion rpath x,nodeAddr addr)
         where x = case Tox.pktClass typ of Tox.NoncedUnclaimedClass top _ -> top nonce unclm
+    -- OnionClass
 
 toxLayer :: Transport String SockAddr ByteString -> Transport String SockAddr Tox.Packet
 toxLayer = layerTransport (\x addr -> (,addr) <$> S.decode x)
@@ -630,7 +612,7 @@ data Routing = Routing
     , committee6  :: TriadCommittee NodeId SockAddr
     }
 
-type ToxClient = Client String Tox.PacketKind TransactionId NodeInfo Msg
+type ToxClient = Client String Tox.PacketKind TransactionId ToxPath Msg
 
 encodePayload :: S.Serialize b => Tox.PacketKind -> TransactionId -> addr -> addr -> b -> Msg
 encodePayload typ (TransactionId nonce8 nonce24) _ _ b = Msg typ nonce24 (S.encode b) nonce8
@@ -645,6 +627,7 @@ trimPackets addr bs = do
                         GetNodesType         -> Just id
                         AnnounceType         -> Just id
                         AnnounceResponseType -> Just id
+                        OnionResponse3Type   -> Just id
                         _                    -> Nothing
 
 newClient :: SockAddr -> IO (ToxClient, Routing)
@@ -767,14 +750,15 @@ newClient addr = do
                     -> ToxClient
         mkclient (tbl,var) handlers = Client
             { clientNet           = net
-            , clientDispatcher    = dispatch tbl var handlers
+            , clientDispatcher    = dispatch tbl var (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers)
             , clientErrorReporter = (printErrors stderr) { reportTimeout = reportTimeout ignoreErrors }
             , clientPending       = var
             , clientAddress       = \maddr -> atomically $ do
-                let var = case flip prefer4or6 Nothing <$> maddr of
+                let var = case flip prefer4or6 Nothing . (\(ToxPath ni _) -> ni) <$> maddr of
                             Just Want_IP6 -> routing6 routing
                             _             -> routing4 routing
-                R.thisNode <$> readTVar var
+                a <- readTVar var
+                return $ ToxPath (R.thisNode a) Tox.emptyReturnPath
             , clientResponseId    = genNonce24 var
             }
 
@@ -847,6 +831,7 @@ addVerbosity2 tr =
             forM_ m $ mapM_ $ \(msg,addr) -> do
                 hPutStrLn stderr ( (show addr)
                                     ++ " -2-> " ++ show (Tox.PacketKind $ B.head msg))
+                -- forM_ (xxd 0 msg) (hPutStrLn stderr)
             kont m
        , sendMessage = \addr msg -> do
             hPutStrLn stderr ( (show addr)
@@ -863,16 +848,19 @@ classify (Msg { msgType     = typ
               , msgNonce    = nonce24 }) = go $ TransactionId nonce8 nonce24
  where
     go = case typ of
-            PingType       -> IsQuery typ
-            GetNodesType   -> IsQuery typ
-            PongType       -> IsResponse
-            SendNodesType  -> IsResponse
-            DHTRequestType -> IsQuery typ
-            OnionRequest0  -> IsQuery typ
-            OnionRequest1  -> IsQuery typ
-            OnionRequest2  -> IsQuery typ
-            AnnounceType   -> IsQuery typ
-            _              -> const $ IsUnknown ("Unknown message type: "++show typ)
+            PingType           -> IsQuery typ
+            GetNodesType       -> IsQuery typ
+            PongType           -> IsResponse
+            SendNodesType      -> IsResponse
+            OnionResponse1Type -> IsResponse
+            OnionResponse2Type -> IsResponse
+            OnionResponse3Type -> IsResponse
+            DHTRequestType     -> IsQuery typ
+            OnionRequest0Type  -> IsQuery typ
+            OnionRequest1Type  -> IsQuery typ
+            OnionRequest2Type  -> IsQuery typ
+            AnnounceType       -> IsQuery typ
+            _                  -> const $ IsUnknown ("Unknown message type: "++show typ)
 
 {-
 encodePayload typ (TransactionId (Tox.Nonce8 tid) nonce) self dest b
@@ -905,13 +893,14 @@ transitionCommittee committee (RoutingTransition ni Stranger) = do
         hPutStrLn stderr $ "delVote "++show (nodeId ni)
 transitionCommittee committee _ = return $ return ()
 
-updateRouting :: ToxClient -> Routing -> NodeInfo -> (Tox.PacketKind, InterediateRep) -> IO ()
-updateRouting client routing naddr (typ,Assym msg) = do
+updateRouting :: ToxClient -> Routing -> ToxPath -> (Tox.PacketKind, InterediateRep) -> IO ()
+updateRouting client routing (ToxPath naddr _) (typ,Assym msg) = do
     hPutStrLn stderr $ "updateRouting "++show typ
     case prefer4or6 naddr Nothing of
         Want_IP4 -> updateTable client naddr (routing4 routing) (committee4 routing) (sched4 routing)
         Want_IP6 -> updateTable client naddr (routing6 routing) (committee6 routing) (sched6 routing)
-updateRouting _ _ _ _ = return ()
+updateRouting _ _ _ (typ,_) = do
+    hPutStrLn stderr $ "updateRouting (ignored) "++show typ
 
 updateTable client naddr tbl committee sched = do
         self <- atomically $ R.thisNode <$> readTVar tbl
@@ -1180,6 +1169,7 @@ announceH routing toks keydb naddr req = do
         _ | Nonce32 bs <- announcePingId req
           , let tok = fromPaddedByteString 32 bs
           -> checkToken toks naddr tok >>= go
+        `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
  where
     go withTok = do
         ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
@@ -1302,7 +1292,7 @@ gen g = let (bs, g')  = randomBytesGenerate 24 g
 
 
 toxSend meth unwrap msg client nid addr = do
-    reply <- sendQuery client serializer (msg nid) addr
+    reply <- sendQuery client serializer (msg nid) (ToxPath addr Tox.emptyReturnPath)
     -- sendQuery will return (Just (Left _)) on a parse error.  We're going to
     -- blow it away with the join-either sequence.
     -- TODO: Do something with parse errors.
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
--}
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 190cc73e..11fe7c32 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -181,6 +181,16 @@ data MethodHandler err tid addr x = forall a b. MethodHandler
     , noreplyAction :: addr -> a -> IO ()
     }
 
+contramapAddr :: (a -> b) -> MethodHandler err tid b x -> MethodHandler err tid a x
+contramapAddr f (MethodHandler p s a)
+    = MethodHandler
+        p
+        (\tid src dst result -> s tid (f src) (f dst) result)
+        (\addr arg -> a (f addr) arg)
+contramapAddr f (NoReply p a)
+    = NoReply p (\addr arg -> a (f addr) arg)
+
+
 -- | Attempt to invoke a 'MethodHandler' upon a given inbound query.  If the
 -- parse is successful, the returned IO action will construct our reply if
 -- there is one.  Otherwise, a parse err is returned.