From dd4c6aeae1cf30035f3c7c3d52e58082f6b7aa36 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 17 Nov 2019 21:53:00 +0100
Subject: Announce periodically and on local identity changes

---
 src/Network.hs | 38 ++++++++++++++++++++++++++++++--------
 1 file changed, 30 insertions(+), 8 deletions(-)

(limited to 'src/Network.hs')

diff --git a/src/Network.hs b/src/Network.hs
index 7d70d1d..0209853 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -28,12 +28,16 @@ import Channel
 import Identity
 import PubKey
 import Service
+import State
 import Storage
 
 
 discoveryPort :: ServiceName
 discoveryPort = "29665"
 
+announceIntervalSeconds :: Int
+announceIntervalSeconds = 60
+
 
 data Peer = Peer
     { peerAddress :: PeerAddress
@@ -150,13 +154,17 @@ receivedWaitingRef nref wr@(WaitingRef _ _ mvar) = do
     checkWaitingRef wr
 
 
-startServer :: (String -> IO ()) -> String -> UnifiedIdentity -> [(T.Text, SomeService)] -> IO (Chan Peer)
-startServer logd bhost identity services = do
-    let sidentity = idData identity
+startServer :: Head -> (String -> IO ()) -> String -> [(T.Text, SomeService)] -> IO (Chan Peer)
+startServer origHead logd bhost services = do
+    let storage = refStorage $ headRef origHead
     chanPeer <- newChan
     chanSvc <- newChan
     peers <- newMVar M.empty
 
+    Just self <- return $ verifyIdentity $ lsIdentity $
+        fromStored $ wrappedLoad $ headRef origHead
+    midentity <- newMVar $ self
+
     let open addr = do
             sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
             setSocketOption sock ReuseAddr 1
@@ -166,9 +174,21 @@ startServer logd bhost identity services = do
             return sock
 
         loop sock = do
-            st <- derivePartialStorage $ storedStorage sidentity
-            baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
-            void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ TransportHeader [ AnnounceSelf $ partialRef st $ storedRef sidentity ]) (addrAddress baddr)
+            let announce identity = do
+                    st <- derivePartialStorage storage
+                    baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
+                    void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ TransportHeader [ AnnounceSelf $ partialRef st $ storedRef $ idData identity ]) (addrAddress baddr)
+
+            void $ forkIO $ forever $ do
+                announce =<< readMVar midentity
+                threadDelay $ announceIntervalSeconds * 1000 * 1000
+
+            watchHead origHead $ \h -> do
+                idt <- modifyMVar midentity $ \cur -> do
+                    return $ (\x -> (x,x)) $ fromMaybe cur $ verifyIdentity $ lsIdentity $
+                        fromStored $ wrappedLoad $ headRef h
+                announce idt
+
             forever $ do
                 (msg, paddr) <- recvFrom sock 4096
                 mbpeer <- M.lookup paddr <$> readMVar peers
@@ -182,7 +202,7 @@ startServer logd bhost identity services = do
                     -> return (peer, msg, False)
 
                     | otherwise -> do
-                          pst <- deriveEphemeralStorage $ storedStorage sidentity
+                          pst <- deriveEphemeralStorage storage
                           ist <- derivePartialStorage pst
                           svcs <- newMVar M.empty
                           let peer = Peer
@@ -203,6 +223,7 @@ startServer logd bhost identity services = do
                      Right (obj:objs)
                          | Just header <- transportFromObject obj -> do
                                forM_ objs $ storeObject $ peerInStorage peer
+                               identity <- readMVar midentity
                                handlePacket logd identity secure peer chanSvc header >>= \case
                                    Just peer' -> do
                                        modifyMVar_ peers $ return . M.insert paddr peer'
@@ -236,7 +257,8 @@ startServer logd bhost identity services = do
                                     { svcPeer = peerId, svcPeerOwner = peerOwnerId
                                     , svcPrintOp = logd
                                     }
-                            (rsp, s') <- handleServicePacket (storedStorage sidentity) inp s (wrappedLoad ref)
+                            (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref)
+                            identity <- readMVar midentity
                             runExceptT (maybe (return ()) (sendToPeer identity peer svc) rsp) >>= \case
                                 Left err -> logd $ "failed to send response to peer: " ++ show err
                                 Right () -> return ()
-- 
cgit v1.2.3