Encryption layer for DHT and Onion transports.

4 files changed, 137 insertions, 4 deletions

diff --git a/DHTTransport.hs b/DHTTransport.hs
index 97a8113c..690ee346 100644
--- a/DHTTransport.hs
+++ b/DHTTransport.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeOperators #-}
 module DHTTransport
     ( parseDHTAddr
     , encodeDHTAddr
@@ -16,15 +18,20 @@ module DHTTransport
     , Cookie
     , DHTRequest
     , mapMessage
+    , encrypt
+    , decrypt
     ) where
 
 import ToxAddress
-import ToxCrypto
+import ToxCrypto hiding (encrypt,decrypt)
+import qualified ToxCrypto
 import Network.QueryResponse
 
 import Control.Arrow
+import Control.Monad
 import qualified Data.ByteString as B
          ;import Data.ByteString (ByteString)
+import Data.Tuple
 import Data.Serialize            as S (Get, Serialize, get, put, runGet)
 import Data.Word
 import Network.Socket
@@ -124,6 +131,10 @@ data DHTRequest
     | NATPong Nonce8
     | DHTPK DHTPublicKey
 
+instance Serialize DHTRequest where
+    get = return _todo
+    put _ = return () -- todo
+
 -- | Length      | Contents                            |
 -- |:------------|:------------------------------------|
 -- | `1`         | `uint8_t` (0x9c)                    |
@@ -177,6 +188,10 @@ data Cookie = Cookie Nonce24 (Encrypted CookieData)
 
 instance Sized Cookie where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
 
+instance Serialize Cookie where
+    get = return $ Cookie _todo _todo
+    put _ = return () -- todo
+
 data CookieData = CookieData   --   16 (mac)
     { cookieTime  :: Word64    --    8
     , longTermKey :: PublicKey --   32
@@ -186,6 +201,10 @@ data CookieData = CookieData   --   16 (mac)
 instance Sized CookieRequest where
     size = ConstSize 64 -- 32 byte key + 32 byte padding
 
+instance Serialize CookieRequest where
+    get = CookieRequest <$> return _todo
+    put (CookieRequest _) = return () -- todo
+
 forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
 forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
  where
@@ -198,3 +217,46 @@ forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
                   await' pass
         m -> pass m
 
+encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> (DHTMessage Encrypted8, NodeInfo)
+encrypt crypto msg ni = (transcode (encryptMessage crypto) msg, ni)
+
+encryptMessage :: Serialize a =>
+                  TransportCrypto -> Nonce24 -> Either (Nonce8,a) (Assym (Nonce8,a)) -> Encrypted8 a
+encryptMessage crypto n (Right assym) = E8 $ ToxCrypto.encrypt secret plain
+ where
+    secret = computeSharedSecret (transportSecret crypto) (senderKey assym) n
+    plain  = encodePlain $ swap $ assymData assym
+encryptMessage crypto n (Left plain) = _todo
+
+decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> Either String (DHTMessage ((,) Nonce8), NodeInfo)
+decrypt crypto msg ni = (, ni) <$> (sequenceMessage $ transcode (decryptMessage crypto) msg)
+
+decryptMessage :: Serialize x =>
+                  TransportCrypto
+                  -> Nonce24
+                  -> Either (Encrypted8 x) (Assym (Encrypted8 x))
+                  -> (Either String ∘ ((,) Nonce8)) x
+decryptMessage crypto n (Right assymE) = plain8 $ ToxCrypto.decrypt secret e
+ where
+    secret = computeSharedSecret (transportSecret crypto) (senderKey assymE) n
+    E8 e   = assymData assymE
+    plain8 = Composed . fmap swap . (>>= decodePlain)
+decryptMessage crypto n (Left (E8 e)) = _todo
+
+sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f)
+sequenceMessage (DHTPing asym)              = fmap DHTPing          $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTPong asym)              = fmap DHTPong          $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTGetNodes asym)          = fmap DHTGetNodes      $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTSendNodes asym)         = fmap DHTSendNodes     $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTCookieRequest asym)     = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTCookie n dta)           = fmap (DHTCookie n)    $ uncomposed dta
+sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym
+
+transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Assym (f a)) -> g a) -> DHTMessage f -> DHTMessage g
+transcode f (DHTPing asym)              = DHTPing              $ asym { assymData = f (assymNonce asym) (Right asym) }
+transcode f (DHTPong asym)              = DHTPong              $ asym { assymData = f (assymNonce asym) (Right asym) }
+transcode f (DHTGetNodes asym)          = DHTGetNodes          $ asym { assymData = f (assymNonce asym) (Right asym) }
+transcode f (DHTSendNodes asym)         = DHTSendNodes         $ asym { assymData = f (assymNonce asym) (Right asym) }
+transcode f (DHTCookieRequest asym)     = DHTCookieRequest     $ asym { assymData = f (assymNonce asym) (Right asym) }
+transcode f (DHTCookie n dta)           = DHTCookie n          $ f n  $ Left dta
+transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { assymData = f (assymNonce asym) (Right asym) }
diff --git a/OnionTransport.hs b/OnionTransport.hs
index 804c444e..aa4bae1e 100644
--- a/OnionTransport.hs
+++ b/OnionTransport.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeOperators              #-}
@@ -21,15 +22,20 @@ module OnionTransport
     , OnionResponse(..)
     , Addressed(..)
     , UDPTransport
+    , KeyRecord(..)
+    , encrypt
+    , decrypt
     ) where
 
 import Network.QueryResponse
-import ToxCrypto
+import ToxCrypto hiding (encrypt,decrypt)
+import qualified ToxCrypto
 import DHTTransport (NodeInfo(..),NodeId(..),SendNodes,nodeInfo)
 
 import Control.Arrow
 import qualified Data.ByteString as B
          ;import Data.ByteString (ByteString)
+import Data.Functor.Identity
 import Data.Serialize            as S (Get, Put, Serialize, get, put, runGet)
 import Data.Typeable
 import Data.Word
@@ -52,6 +58,7 @@ data OnionMessage (f :: * -> *)
 
 data OnionToOwner = OnionToOwner NodeInfo (ReturnPath 3)
                   | OnionToMe SockAddr -- SockAddr is immediate peer in route
+    deriving Show
 
 
 onionToOwner assym ret3 saddr = do
@@ -127,6 +134,10 @@ data ReturnPath (n :: Nat) where
     NoReturnPath :: ReturnPath 0
     ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (n + 1)
 
+instance KnownNat n => Show (ReturnPath n) where
+    show rpath = "ReturnPath" ++ show (natVal rpath)
+
+
 -- 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) )
@@ -194,3 +205,49 @@ data DataToRoute = DataToRoute
     , dataToRoute :: Encrypted (Word8,ByteString)
     }
 
+instance Serialize DataToRoute where
+    get = return $ DataToRoute _todo _todo
+    put _ = return () -- todo
+
+encrypt :: TransportCrypto -> OnionMessage Identity -> OnionToOwner -> (OnionMessage Encrypted, OnionToOwner)
+encrypt crypto msg rpath = (transcode (encryptMessage crypto) msg, rpath)
+
+encryptMessage :: Serialize a =>
+                  TransportCrypto -> Nonce24 -> Either (Identity a) (Assym (Identity a)) -> Encrypted a
+encryptMessage crypto n (Right a) = ToxCrypto.encrypt secret plain
+ where
+    secret = computeSharedSecret (transportSecret crypto) (senderKey a) n
+    plain  = encodePlain $ runIdentity $ assymData a
+encryptMessage crypto n (Left x) = ToxCrypto.encrypt secret plain
+ where
+    secret = computeSharedSecret (transportSecret crypto) _todo n
+    plain  = encodePlain $ runIdentity $ x
+
+decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionToOwner -> Either String (OnionMessage Identity, OnionToOwner)
+decrypt crypto msg addr = (, addr) <$> (sequenceMessage $ transcode (decryptMessage crypto) msg)
+
+decryptMessage :: Serialize x =>
+                  TransportCrypto
+                  -> Nonce24
+                  -> Either (Encrypted x) (Assym (Encrypted x))
+                  -> (Either String ∘ Identity) x
+decryptMessage crypto n (Right assymE) = plain $ ToxCrypto.decrypt secret e
+ where
+    secret = computeSharedSecret (transportSecret crypto) (senderKey assymE) n
+    e      = assymData assymE
+    plain  = Composed . fmap Identity . (>>= decodePlain)
+decryptMessage crypto n (Left e) = _todo
+
+
+sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
+sequenceMessage (OnionAnnounce a)        = fmap OnionAnnounce        $ sequenceA $ fmap uncomposed a
+sequenceMessage (OnionToRoute pub a)     = fmap (OnionToRoute pub)   $ sequenceA $ fmap uncomposed a
+sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a
+sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
+
+transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Assym (f a)) -> g a) -> OnionMessage f -> OnionMessage g
+transcode f (OnionAnnounce a)        = OnionAnnounce        $ a { assymData = f (assymNonce a) (Right a) }
+transcode f (OnionToRoute pub a)     = OnionToRoute pub     $ a { assymData = f (assymNonce a) (Right a) }
+transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { assymData = f (assymNonce a) (Right a) }
+transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta
+
diff --git a/ToxAddress.hs b/ToxAddress.hs
index f0d4aba3..ea69f6e3 100644
--- a/ToxAddress.hs
+++ b/ToxAddress.hs
@@ -13,7 +13,7 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeApplications           #-}
-module ToxAddress (NodeInfo(..),NodeId(..),nodeInfo) where
+module ToxAddress (NodeInfo(..),NodeId(..),nodeInfo,zeroID) where
 
 import Control.Applicative
 import Control.Monad
@@ -88,6 +88,9 @@ instance S.Serialize NodeId where
 
 instance Bits NodeId where -- TODO
 
+instance Hashable NodeId where
+    hashWithSalt salt (NodeId key) = hashWithSalt salt (BA.convert key :: ByteString)
+
 instance FiniteBits NodeId where
     finiteBitSize _ = 256
 
diff --git a/ToxCrypto.hs b/ToxCrypto.hs
index 6b5e6f19..c2e2bbeb 100644
--- a/ToxCrypto.hs
+++ b/ToxCrypto.hs
@@ -2,6 +2,10 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE TypeOperators #-}
 module ToxCrypto
     ( PublicKey
     , publicKey
@@ -9,9 +13,12 @@ module ToxCrypto
     , SymmetricKey(..)
     , TransportCrypto(..)
     , Encrypted
-    , Encrypted8
+    , Encrypted8(..)
+    , type (∘)(..)
     , Assym(..)
     , Plain
+    , encodePlain
+    , decodePlain
     , computeSharedSecret
     , encrypt
     , decrypt
@@ -24,6 +31,8 @@ module ToxCrypto
     , Sized(..)
     , Size(..)
     , State(..)
+    , zeros32
+    , zeros24
     ) where
 
 import qualified Crypto.Cipher.Salsa    as Salsa
@@ -56,6 +65,7 @@ newtype Encrypted a = Encrypted ByteString
 newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
  deriving Serialize
 
+newtype (f ∘ g) x = Composed { uncomposed :: f (g x) }
 
 newtype Auth = Auth Poly1305.Auth deriving (Eq, ByteArrayAccess)
 instance Ord Auth where
@@ -229,6 +239,7 @@ data Assym a = Assym
     , assymNonce :: Nonce24
     , assymData :: a
     }
+ deriving (Functor,Foldable,Traversable)
 
 newtype SymmetricKey = SymmetricKey ByteString