Encrypted channels negotiated with DH

1 files changed, 154 insertions, 59 deletions

diff --git a/src/Network.hs b/src/Network.hs
index f294835..1056265 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -11,12 +11,15 @@ import Control.Monad.Except
 
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as M
 import qualified Data.Text as T
 
 import Network.Socket
 import Network.Socket.ByteString (recvFrom, sendTo)
 
+import Channel
 import Identity
+import PubKey
 import Storage
 
 
@@ -25,8 +28,9 @@ discoveryPort = "29665"
 
 
 data Peer = Peer
-    { peerIdentity :: Stored Identity
-    , peerAddress :: PeerAddress
+    { peerAddress :: PeerAddress
+    , peerIdentity :: Maybe (Stored Identity)
+    , peerChannels :: [Channel]
     }
     deriving (Show)
 
@@ -37,6 +41,8 @@ data PeerAddress = DatagramAddress SockAddr
 data TransportHeader = AnnouncePacket Ref
                      | IdentityRequest Ref Ref
                      | IdentityResponse Ref
+                     | TrChannelRequest Ref
+                     | TrChannelAccept Ref
 
 transportToObject :: TransportHeader -> Object
 transportToObject = \case
@@ -53,6 +59,14 @@ transportToObject = \case
         [ (BC.pack "TRANS", RecText $ T.pack "idresp")
         , (BC.pack "identity", RecRef ref)
         ]
+    TrChannelRequest ref -> Rec
+        [ (BC.pack "TRANS", RecText $ T.pack "chreq")
+        , (BC.pack "req", RecRef ref)
+        ]
+    TrChannelAccept ref -> Rec
+        [ (BC.pack "TRANS", RecText $ T.pack "chacc")
+        , (BC.pack "acc", RecRef ref)
+        ]
 
 transportFromObject :: Object -> Maybe TransportHeader
 transportFromObject (Rec items)
@@ -69,71 +83,152 @@ transportFromObject (Rec items)
     , Just (RecRef ref) <- lookup (BC.pack "identity") items
     = Just $ IdentityResponse ref
 
+    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chreq"
+    , Just (RecRef ref) <- lookup (BC.pack "req") items
+    = Just $ TrChannelRequest ref
+
+    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chacc"
+    , Just (RecRef ref) <- lookup (BC.pack "acc") items
+    = Just $ TrChannelAccept ref
+
 transportFromObject _ = Nothing
 
 
 peerDiscovery :: String -> Stored Identity -> IO (Chan Peer)
 peerDiscovery bhost sidentity = do
-    chan <- newChan
+    chanPeer <- newChan
+    peers <- newMVar M.empty
+
+    let open addr = do
+            sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+            setSocketOption sock ReuseAddr 1
+            setSocketOption sock Broadcast 1
+            setCloseOnExecIfNeeded =<< fdSocket sock
+            bind sock (addrAddress addr)
+            return sock
+
+        loop sock = do
+            baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
+            void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
+            forever $ do
+                (msg, paddr) <- recvFrom sock 4096
+                let packet' = packet sock paddr
+                case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of
+                     Left err -> putStrLn $ show paddr ++ ": " ++ err
+                     Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs
+                     _ -> putStrLn $ show paddr ++ ": invalid transport packet"
+
+        packet sock paddr (AnnouncePacket ref) _ = do
+            putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr
+            when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
+                [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
+                , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
+                ]) paddr
+
+        packet _ paddr (IdentityRequest ref from) [] = do
+            putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"
+
+        packet sock paddr (IdentityRequest ref from) (obj:objs) = do
+            putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
+            print (obj:objs)
+            from' <- store (storedStorage sidentity) obj
+            if from == from'
+               then do forM_ objs $ store $ storedStorage sidentity
+                       let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) []
+                       modifyMVar_ peers $ return . M.insert paddr peer
+                       writeChan chanPeer peer
+                       void $ sendTo sock (BL.toStrict $ BL.concat
+                           [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
+                           , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
+                           ]) paddr
+               else putStrLn $ "Mismatched content"
+
+        packet _ paddr (IdentityResponse ref) [] = do
+            putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"
+
+        packet sock paddr (IdentityResponse ref) (obj:objs) = do
+            putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
+            print (obj:objs)
+            ref' <- store (storedStorage sidentity) obj
+            if ref == ref'
+               then do forM_ objs $ store $ storedStorage sidentity
+                       let pidentity = wrappedLoad ref
+                           peer = Peer (DatagramAddress paddr) (Just pidentity) []
+                       modifyMVar_ peers $ return . M.insert paddr peer
+                       writeChan chanPeer peer
+                       req <- createChannelRequest sidentity pidentity
+                       void $ sendTo sock (BL.toStrict $ BL.concat
+                           [ serializeObject $ transportToObject $ TrChannelRequest (storedRef req)
+                           , lazyLoadBytes $ storedRef req
+                           , lazyLoadBytes $ storedRef $ signedData $ fromStored req
+                           , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
+                           , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
+                           ]) paddr
+               else putStrLn $ "Mismatched content"
+
+        packet _ paddr (TrChannelRequest _) [] = do
+            putStrLn $ "Got channel request: from " ++ show paddr ++ " without content"
+
+        packet sock paddr (TrChannelRequest ref) (obj:objs) = do
+            putStrLn $ "Got channel request: from " ++ show paddr
+            print (obj:objs)
+            ref' <- store (storedStorage sidentity) obj
+            if ref == ref'
+               then do forM_ objs $ store $ storedStorage sidentity
+                       let request = wrappedLoad ref :: Stored ChannelRequest
+                       modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+                           Just peer | Just pid <- peerIdentity peer ->
+                               runExceptT (acceptChannelRequest sidentity pid request) >>= \case
+                                   Left errs -> do mapM_ putStrLn ("Invalid channel request" : errs)
+                                                   return pval
+                                   Right (acc, channel) -> do
+                                       putStrLn $ "Got channel: " ++ show (storedRef channel)
+                                       let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+                                       writeChan chanPeer peer'
+                                       void $ sendTo sock (BL.toStrict $ BL.concat
+                                           [ serializeObject $ transportToObject $ TrChannelAccept (storedRef acc)
+                                           , lazyLoadBytes $ storedRef acc
+                                           , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
+                                           , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
+                                           , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
+                                           ]) paddr
+                                       return $ M.insert paddr peer' pval
+
+                           _ -> do putStrLn $ "Invalid channel request - no peer identity"
+                                   return pval
+               else putStrLn $ "Mismatched content"
+
+        packet _ paddr (TrChannelAccept _) [] = do
+            putStrLn $ "Got channel accept: from " ++ show paddr ++ " without content"
+
+        packet _ paddr (TrChannelAccept ref) (obj:objs) = do
+            putStrLn $ "Got channel accept: from " ++ show paddr
+            print (obj:objs)
+            ref' <- store (storedStorage sidentity) obj
+            if ref == ref'
+               then do forM_ objs $ store $ storedStorage sidentity
+                       let accepted = wrappedLoad ref :: Stored ChannelAccept
+                       modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+                           Just peer | Just pid <- peerIdentity peer ->
+                               runExceptT (acceptedChannel sidentity pid accepted) >>= \case
+                                   Left errs -> do mapM_ putStrLn ("Invalid channel accept" : errs)
+                                                   return pval
+                                   Right channel -> do
+                                       putStrLn $ "Got channel: " ++ show (storedRef channel)
+                                       let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+                                       writeChan chanPeer peer'
+                                       return $ M.insert paddr peer' pval
+                           _ -> do putStrLn $ "Invalid channel accept - no peer identity"
+                                   return pval
+
+               else putStrLn $ "Mismatched content"
+
     void $ forkIO $ withSocketsDo $ do
         let hints = defaultHints
               { addrFlags = [AI_PASSIVE]
               , addrSocketType = Datagram
               }
         addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
-        bracket (open addr) close (loop chan)
-    return chan
-  where
-    open addr = do
-        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-        setSocketOption sock ReuseAddr 1
-        setSocketOption sock Broadcast 1
-        setCloseOnExecIfNeeded =<< fdSocket sock
-        bind sock (addrAddress addr)
-        return sock
-
-    loop chan sock = do
-        baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
-        void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
-        forever $ do
-            (msg, peer) <- recvFrom sock 4096
-            let packet' = packet chan sock peer
-            case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of
-                 Left err -> putStrLn $ show peer ++ ": " ++ err
-                 Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs
-                 _ -> putStrLn $ show peer ++ ": invalid transport packet"
-
-    packet _ sock peer (AnnouncePacket ref) _ = do
-        putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show peer
-        when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
-            [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
-            , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
-            ]) peer
-
-    packet _ _ peer (IdentityRequest ref from) [] = do
-        putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer ++ " without content"
-
-    packet chan sock peer (IdentityRequest ref from) (obj:objs) = do
-        putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer
-        print (obj:objs)
-        from' <- store (storedStorage sidentity) obj
-        if from == from'
-           then do forM_ objs $ store $ storedStorage sidentity
-                   writeChan chan $ Peer (wrappedLoad from) (DatagramAddress peer)
-                   void $ sendTo sock (BL.toStrict $ BL.concat
-                       [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
-                       , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
-                       ]) peer
-           else putStrLn $ "Mismatched content"
-
-    packet _ _ peer (IdentityResponse ref) [] = do
-        putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer ++ " without content"
-
-    packet chan _ peer (IdentityResponse ref) (obj:objs) = do
-        putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer
-        print (obj:objs)
-        ref' <- store (storedStorage sidentity) obj
-        if ref == ref'
-           then do forM_ objs $ store $ storedStorage sidentity
-                   writeChan chan $ Peer (wrappedLoad ref) (DatagramAddress peer)
-           else putStrLn $ "Mismatched content"
+        bracket (open addr) close loop
+
+    return chanPeer