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/Main.hs | 11 ++++++-----
src/Network.hs | 38 ++++++++++++++++++++++++++++++--------
2 files changed, 36 insertions(+), 13 deletions(-)
(limited to 'src')
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 ()
--
cgit v1.2.3