Announce periodically and on local identity changes

2 files changed, 36 insertions, 13 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 6bd0967..5ce9f86 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -75,16 +75,15 @@ main = do
 interactiveLoop :: Storage -> String -> IO ()
 interactiveLoop st bhost = runInputT defaultSettings $ do
     erebosHead <- liftIO $ loadLocalState st
-    let serebos = wrappedLoad (headRef erebosHead) :: Stored LocalState
-        Just self = verifyIdentity $ lsIdentity $ fromStored serebos
-    outputStrLn $ T.unpack $ displayIdentity self
+    outputStrLn $ T.unpack $ maybe (error "failed to verify local identity") displayIdentity $
+        verifyIdentity $ lsIdentity $ fromStored $ wrappedLoad $ headRef erebosHead
 
     haveTerminalUI >>= \case True -> return ()
                              False -> error "Requires terminal"
     extPrint <- getExternalPrint
     let extPrintLn str = extPrint $ str ++ "\n";
     chanPeer <- liftIO $
-        startServer extPrintLn bhost self
+        startServer erebosHead extPrintLn bhost
             [ (T.pack "attach", SomeService (emptyServiceState :: AttachService))
             , (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService))
             ]
@@ -123,8 +122,10 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
                                        then (cmdSetPeer $ read scmd, args)
                                        else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
                     _        -> (cmdSend, input)
+            curHead <- liftIO $ loadLocalState st
             res <- liftIO $ runExceptT $ flip execStateT cstate $ runReaderT cmd CommandInput
-                { ciSelf = self
+                { ciSelf = fromMaybe (error "failed to verify local identity") $
+                    verifyIdentity $ lsIdentity $ fromStored $ wrappedLoad $ headRef curHead
                 , ciLine = line
                 , ciPrint = extPrintLn
                 , ciPeers = liftIO $ readMVar peers
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 ()