From b3dd410bb4ed093b74fe349d3a51a5767c76f952 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 19 May 2019 22:19:15 +0200
Subject: Direct message service basics

---
 src/Network.hs | 66 +++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 54 insertions(+), 12 deletions(-)

(limited to 'src/Network.hs')

diff --git a/src/Network.hs b/src/Network.hs
index 1056265..827f542 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -1,7 +1,8 @@
 module Network (
     Peer(..),
-    PeerAddress,
-    peerDiscovery,
+    PeerAddress(..),
+    startServer,
+    sendToPeer,
 ) where
 
 import Control.Concurrent
@@ -31,6 +32,7 @@ data Peer = Peer
     { peerAddress :: PeerAddress
     , peerIdentity :: Maybe (Stored Identity)
     , peerChannels :: [Channel]
+    , peerSocket :: Socket
     }
     deriving (Show)
 
@@ -44,6 +46,8 @@ data TransportHeader = AnnouncePacket Ref
                      | TrChannelRequest Ref
                      | TrChannelAccept Ref
 
+data ServiceHeader = ServiceHeader T.Text Ref
+
 transportToObject :: TransportHeader -> Object
 transportToObject = \case
     AnnouncePacket ref -> Rec
@@ -93,10 +97,24 @@ transportFromObject (Rec items)
 
 transportFromObject _ = Nothing
 
+serviceToObject :: ServiceHeader -> Object
+serviceToObject (ServiceHeader svc ref) = Rec
+        [ (BC.pack "SVC", RecText svc)
+        , (BC.pack "ref", RecRef ref)
+        ]
+
+serviceFromObject :: Object -> Maybe ServiceHeader
+serviceFromObject (Rec items)
+    | Just (RecText svc) <- lookup (BC.pack "SVC") items
+    , Just (RecRef ref) <- lookup (BC.pack "ref") items
+    = Just $ ServiceHeader svc ref
+serviceFromObject _ = Nothing
 
-peerDiscovery :: String -> Stored Identity -> IO (Chan Peer)
-peerDiscovery bhost sidentity = do
+
+startServer :: String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
+startServer bhost sidentity = do
     chanPeer <- newChan
+    chanSvc <- newChan
     peers <- newMVar M.empty
 
     let open addr = do
@@ -112,11 +130,20 @@ peerDiscovery bhost sidentity = do
             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"
+                mbpeer <- M.lookup paddr <$> readMVar peers
+                if | Just peer <- mbpeer
+                   , ch:_ <- peerChannels peer
+                   , Just plain <- channelDecrypt ch msg
+                   , Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict plain
+                   , Just (ServiceHeader svc ref) <- serviceFromObject obj
+                   -> do forM_ objs $ store $ storedStorage sidentity
+                         writeChan chanSvc (peer, svc, ref)
+
+                   | Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg
+                   , Just tpack <- transportFromObject obj
+                   -> packet sock paddr tpack objs
+
+                   | otherwise -> putStrLn $ show paddr ++ ": invalid packet"
 
         packet sock paddr (AnnouncePacket ref) _ = do
             putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr
@@ -134,7 +161,7 @@ peerDiscovery bhost sidentity = do
             from' <- store (storedStorage sidentity) obj
             if from == from'
                then do forM_ objs $ store $ storedStorage sidentity
-                       let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) []
+                       let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) [] sock
                        modifyMVar_ peers $ return . M.insert paddr peer
                        writeChan chanPeer peer
                        void $ sendTo sock (BL.toStrict $ BL.concat
@@ -153,7 +180,7 @@ peerDiscovery bhost sidentity = do
             if ref == ref'
                then do forM_ objs $ store $ storedStorage sidentity
                        let pidentity = wrappedLoad ref
-                           peer = Peer (DatagramAddress paddr) (Just pidentity) []
+                           peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock
                        modifyMVar_ peers $ return . M.insert paddr peer
                        writeChan chanPeer peer
                        req <- createChannelRequest sidentity pidentity
@@ -231,4 +258,19 @@ peerDiscovery bhost sidentity = do
         addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
         bracket (open addr) close loop
 
-    return chanPeer
+    return (chanPeer, chanSvc)
+
+
+sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO ()
+sendToPeer self peer@Peer { peerChannels = ch:_ } svc obj = do
+    let st = storedStorage self
+    ref <- store st obj
+    let plain = BL.toStrict $ BL.concat
+            [ serializeObject $ serviceToObject $ ServiceHeader svc ref
+            , lazyLoadBytes ref
+            ]
+    ctext <- channelEncrypt ch plain
+    let DatagramAddress paddr = peerAddress peer
+    void $ sendTo (peerSocket peer) ctext paddr
+
+sendToPeer _ _ _ _ = putStrLn $ "No channel to peer"
-- 
cgit v1.2.3