Implemented onion routing.

1 files changed, 169 insertions, 51 deletions

diff --git a/OnionTransport.hs b/OnionTransport.hs
index 7a837a2b..e05e2ca0 100644
--- a/OnionTransport.hs
+++ b/OnionTransport.hs
@@ -4,11 +4,15 @@
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures             #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeFamilyDependencies     #-}
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
 module OnionTransport
@@ -31,6 +35,7 @@ module OnionTransport
     , decrypt
     ) where
 
+import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
 import Network.QueryResponse
 import ToxCrypto hiding (encrypt,decrypt)
 import ToxAddress
@@ -38,18 +43,22 @@ import qualified ToxCrypto
 import DHTTransport (NodeInfo(..),NodeId(..),SendNodes,nodeInfo,DHTPublicKey)
 
 import Control.Arrow
+import Control.Concurrent.STM
 import qualified Data.ByteString as B
          ;import Data.ByteString (ByteString)
 import Data.Coerce
 import Data.Functor.Contravariant
 import Data.Functor.Identity
+import Data.IP
+import Data.Maybe
 import Data.Monoid
 import Data.Serialize            as S
 import Data.Typeable
 import Data.Word
 import GHC.TypeLits
 import Network.Socket
-import GHC.Generics
+import GHC.Generics ()
+import Data.Type.Equality
 
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
@@ -68,7 +77,7 @@ data OnionMessage (f :: * -> *)
     | OnionToRoute PublicKey (Assym (f DataToRoute)) -- destination key, aliased Assym
     | OnionToRouteResponse (Assym (f DataToRoute))
 
-data OnionToOwner = OnionToOwner NodeInfo (ReturnPath 3)
+data OnionToOwner = OnionToOwner NodeInfo (ReturnPath N3)
                   | OnionToMe SockAddr -- SockAddr is immediate peer in route
     deriving Show
 
@@ -83,7 +92,21 @@ instance Sized (OnionMessage Encrypted) where
         OnionToRouteResponse a -> case size of ConstSize n -> n + 1
                                                VarSize f   -> f a + 1
 
-onionToOwner :: Assym a -> ReturnPath 3 -> SockAddr -> Either String OnionToOwner
+instance Serialize (OnionMessage Encrypted) where
+    get = do
+        typ <- get
+        case typ :: Word8 of
+            0x83 -> OnionAnnounce <$> getAliasedAssym
+            0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAssym
+            0x84 -> getOnionReply typ
+            0x86 -> getOnionReply typ
+            t    -> fail $ "Unknown onion payload: " ++ show t
+    put (OnionAnnounce a)                = putWord8 0x83 >> putAliasedAssym a
+    put (OnionToRoute k a)               = putWord8 0x85 >> putPublicKey k >> putAliasedAssym a
+    put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x
+    put (OnionToRouteResponse a)         = putWord8 0x86 >> putAliasedAssym a
+
+onionToOwner :: Assym a -> ReturnPath N3 -> SockAddr -> Either String OnionToOwner
 onionToOwner assym ret3 saddr = do
     ni <- nodeInfo (NodeId $ senderKey assym) saddr
     return $ OnionToOwner ni ret3
@@ -137,12 +160,12 @@ forwardOnions crypto udp = udp { awaitMessage = await' }
     await' :: HandleLo a -> IO a
     await' forThem = awaitMessage udp $ \case
         m@(Just (Right (bs,saddr))) -> case B.head bs of
-            0x80 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 0) crypto saddr (forThem m)
-            0x81 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 1) crypto saddr (forThem m)
-            0x82 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 2) crypto saddr (forThem m)
-            0x8c -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 3) crypto saddr (forThem m)
-            0x8d -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 2) crypto saddr (forThem m)
-            0x8e -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 1) crypto saddr (forThem m)
+            0x80 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy  N0) crypto saddr udp (await' forThem)
+            0x81 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy  N1) crypto saddr udp (await' forThem)
+            0x82 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy  N2) crypto saddr udp (await' forThem)
+            0x8c -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp (await' forThem)
+            0x8d -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp (await' forThem)
+            0x8e -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp (await' forThem)
             _    -> forThem m
         m -> forThem m
 
@@ -150,23 +173,47 @@ forward :: forall c b b1. Serialize b =>
               (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
 forward forMe bs f = either (forMe . Just . Left) f $ decode $ B.tail bs
 
+class SumToThree a b
+
+instance SumToThree N0 N3
+instance SumToThree (S a) b => SumToThree a (S b)
+
+class ( Serialize (ReturnPath n)
+      , Serialize (ReturnPath (S n))
+      , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))
+      , ThreeMinus n ~ S (ThreeMinus (S n))
+      ) => LessThanThree n
+
+instance LessThanThree N0
+instance LessThanThree N1
+instance LessThanThree N2
+
+type family ThreeMinus n = r | r -> n where
+    ThreeMinus N3 = N0
+    ThreeMinus N2 = N1
+    ThreeMinus N1 = N2
+    ThreeMinus N0 = N3
+
 -- n = 0, 1, 2
-data OnionRequest (n :: Nat) = OnionRequest
+data OnionRequest n = OnionRequest
     { onionNonce    :: Nonce24
-    , onionForward  :: Forwarding (3 - n) (OnionMessage Encrypted)
+    , onionForward  :: Forwarding (ThreeMinus n) (OnionMessage Encrypted)
     , pathFromOwner :: ReturnPath n
     }
 
-instance ( Serialize (Forwarding (3 - n) (OnionMessage Encrypted))
+instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
          , Serialize (ReturnPath n)
          ) => Serialize (OnionRequest n) where
     get = OnionRequest <$> get <*> get <*> get
     put (OnionRequest n f p) = put n >> put f >> put p
 
+-- getRequest :: _
+-- getRequest = OnionRequest <$> get <*> get <*> get
+
 -- n = 1, 2, 3
 -- Attributed (Encrypted (
 
-data OnionResponse (n :: Nat) = OnionResponse
+data OnionResponse n = OnionResponse
     { pathToOwner :: ReturnPath n
     , msgToOwner  :: OnionMessage Encrypted
     }
@@ -183,25 +230,67 @@ instance Sized a => Sized (Addressed a) where
             ConstSize n -> ConstSize     $ 1{-family-} + 16{-ip-} + 2{-port-} + n
             VarSize f   -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f x
 
-data ReturnPath (n :: Nat) where
-    NoReturnPath :: ReturnPath 0
-    ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath (n - 1))) -> ReturnPath n
+getForwardAddr :: S.Get SockAddr
+getForwardAddr = do
+    addrfam <- S.get :: S.Get Word8
+    ip <- getIP addrfam
+    case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this.
+               IPv6 _ -> return ()
+    port <- S.get :: S.Get PortNumber
+    return $ setPort port $ toSockAddr ip
+
+
+putForwardAddr :: SockAddr -> S.Put
+putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do
+    port <- sockAddrPort saddr
+    ip <- fromSockAddr $ either id id $ either4or6 saddr
+    return $ do
+        case ip of
+            IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0)
+            IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
+        S.put port
+
+instance Serialize a => Serialize (Addressed a) where
+    get = Addressed <$> getForwardAddr <*> get
+    put (Addressed addr x) = putForwardAddr addr >> put x
+
+data N0
+data S n
+type N1 = S N0
+type N2 = S N1
+type N3 = S N2
+
+type family PeanoNat p where
+    PeanoNat N0    = 0
+    PeanoNat (S n) = 1 + PeanoNat n
+
+data ReturnPath n where
+    NoReturnPath :: ReturnPath N0
+    ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n)
 
 -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
-instance KnownNat n => Sized (ReturnPath n) where
-    size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy n))
+instance Sized (ReturnPath N0) where size = ConstSize 0
+instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where
+    size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n)
+                                            in error "non-constant ReturnPath size")
+                                     (size :: Size (ReturnPath n))
+
+{-
+instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where
+    size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n)))
+-}
 
-instance Serialize (ReturnPath 0) where get              = pure NoReturnPath
-                                        put NoReturnPath = pure ()
+instance Serialize (ReturnPath N0) where get              = pure NoReturnPath
+                                         put NoReturnPath = pure ()
 
-instance Serialize (ReturnPath 1) where get                    = ReturnPath <$> get <*> get
-                                        put (ReturnPath n24 p) = put n24 >> put p
+instance Serialize (ReturnPath N1) where
+    get = ReturnPath <$> get <*> get
+    put (ReturnPath n24 p) = put n24 >> put p
 
-instance Serialize (ReturnPath 2) where get                    = ReturnPath <$> get <*> get
-                                        put (ReturnPath n24 p) = put n24 >> put p
+instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where
+    get = ReturnPath <$> get <*> get
+    put (ReturnPath n24 p) = put n24 >> put p
 
-instance Serialize (ReturnPath 3) where get                    = ReturnPath <$> get <*> get
-                                        put (ReturnPath n24 p) = put n24 >> put p
 
 {-
 -- This doesn't work because it tried to infer it for (0 - 1)
@@ -210,8 +299,8 @@ instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (
     put (ReturnPath n24 p) = put n24 >> put p
 -}
 
-instance KnownNat n => Show (ReturnPath n) where
-    show rpath = "ReturnPath" ++ show (natVal rpath)
+instance KnownNat (PeanoNat n) => Show (ReturnPath n) where
+    show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n)))
 
 
 -- instance KnownNat n => Serialize (ReturnPath n) where
@@ -220,38 +309,67 @@ instance KnownNat n => Show (ReturnPath n) where
 --     put (ReturnPath bs) = putByteString bs
 
 
-data Forwarding (n :: Nat) msg where
-    NotForwarded :: msg -> Forwarding 0 msg
-    Forwarding :: Assym (Encrypted (Addressed (Forwarding (n - 1) msg))) -> Forwarding n msg
+data Forwarding n msg where
+    NotForwarded :: msg -> Forwarding N0 msg
+    Forwarding :: Assym (Encrypted (Addressed (Forwarding n msg))) -> Forwarding (S n) msg
 
-instance Sized msg => Sized (Forwarding 0 msg)
+instance Sized msg => Sized (Forwarding N0 msg)
    where size = case size :: Size msg of
                  ConstSize n -> ConstSize n
                  VarSize f -> VarSize $ \(NotForwarded x) -> f x
-instance Sized msg => Sized (Forwarding 1 msg)
-   where size = case size :: Size (Assym (Encrypted (Addressed (Forwarding 0 msg)))) of
-                 ConstSize n -> ConstSize n
-                 VarSize f -> VarSize $ \(Forwarding a) -> f a
-instance Sized msg => Sized (Forwarding 2 msg)
-   where size = case size :: Size (Assym (Encrypted (Addressed (Forwarding 1 msg)))) of
-                 ConstSize n -> ConstSize n
-                 VarSize f -> VarSize $ \(Forwarding a) -> f a
-instance Sized msg => Sized (Forwarding 3 msg)
-   where size = case size :: Size (Assym (Encrypted (Addressed (Forwarding 2 msg)))) of
+
+instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg)
+   where size = case size :: Size (Assym (Encrypted (Addressed (Forwarding n msg)))) of
                  ConstSize n -> ConstSize n
                  VarSize f -> VarSize $ \(Forwarding a) -> f a
 
+instance Serialize msg => Serialize (Forwarding N0 msg) where
+    get = NotForwarded <$> get
+    put (NotForwarded msg) = put msg
 
-instance (Serialize (Encrypted (Addressed (Forwarding (n - 1) msg)))) => Serialize (Forwarding n msg) where
+instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where
     get = Forwarding <$> getAliasedAssym
     put (Forwarding x) = putAliasedAssym x
 
+handleOnionRequest :: LessThanThree n => proxy n -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionRequest n -> IO a
+handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
+    (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
+                                      <*> transportNewNonce crypto )
+    case peelOnion crypto msg of
+        Left e -> do
+            -- todo report encryption error
+            kont
+        Right (Addressed dst msg') -> do
+            sendMessage udp dst (S.encode $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
+            kont
+
+wrapSymmetric :: Serialize (ReturnPath n) =>
+                 SymmetricKey -> Nonce24 -> SockAddr -> ReturnPath n -> ReturnPath (S n)
+wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ Addressed saddr rpath)
+
+peelSymmetric :: Serialize (Addressed (ReturnPath n))
+                 => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n))
+peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain
+
+
+peelOnion :: Serialize (Addressed (Forwarding n t))
+              => TransportCrypto
+              -> Forwarding (S n) t
+              -> Either String (Addressed (Forwarding n t))
+peelOnion crypto (Forwarding fwd) =
+    fmap runIdentity $ uncomposed $ decryptMessage crypto (assymNonce fwd) (Right fwd)
+
+handleOnionResponse :: Serialize (ReturnPath n) => proxy (S n) -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionResponse (S n) -> IO a
+handleOnionResponse proxy crypto saddr udp kont (OnionResponse path msg) = do
+    sym <- atomically $ transportSymmetric crypto
+    case peelSymmetric sym path of
+        Left e -> do
+            -- todo report encryption error
+            kont
+        Right (Addressed dst path') -> do
+            sendMessage udp dst (S.encode $ OnionResponse path' msg)
+            kont
 
-handleOnionRequest :: KnownNat n => proxy n -> TransportCrypto -> SockAddr -> IO a -> OnionRequest n -> IO a
-handleOnionRequest = _todo
-
-handleOnionResponse :: KnownNat n => proxy n -> TransportCrypto -> SockAddr -> IO a -> OnionResponse n -> IO a
-handleOnionResponse = _todo
 
 data AnnounceRequest = AnnounceRequest
     { announcePingId  :: Nonce32 -- Ping ID
@@ -265,12 +383,12 @@ instance S.Serialize AnnounceRequest where
     get = AnnounceRequest <$> S.get <*> S.get <*> S.get
     put (AnnounceRequest p s k) = S.put (p,s,k)
 
-getOnionRequest :: Sized msg => Get (Assym (Encrypted msg), ReturnPath 3)
+getOnionRequest :: Sized msg => Get (Assym (Encrypted msg), ReturnPath N3)
 getOnionRequest = do
     -- Assumes return path is constant size so that we can isolate
     -- the variable-sized prefix.
     cnt <- remaining
-    a <- isolate (case size :: Size (ReturnPath 3) of ConstSize n -> cnt - n)
+    a <- isolate (case size :: Size (ReturnPath N3) of ConstSize n -> cnt - n)
                  getAliasedAssym
     path <- get
     return (a,path)