From 52b32cc5d67723d4285610f21a240cf4d0b3a2b0 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Fri, 1 Sep 2017 23:32:31 -0400
Subject: Encryption layer for DHT and Onion transports.

---
 DHTTransport.hs | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 63 insertions(+), 1 deletion(-)

(limited to 'DHTTransport.hs')

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) }
-- 
cgit v1.2.3