summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Identity.hs3
-rw-r--r--src/Network.hs35
2 files changed, 31 insertions, 7 deletions
diff --git a/src/Identity.hs b/src/Identity.hs
index ce987b2..dcf0ca4 100644
--- a/src/Identity.hs
+++ b/src/Identity.hs
@@ -16,6 +16,7 @@ module Identity (
displayIdentity,
) where
+import Control.Arrow
import Control.Monad
import Control.Monad.Except
import qualified Control.Monad.Identity as I
@@ -49,7 +50,7 @@ type ComposedIdentity = Identity []
type UnifiedIdentity = Identity I.Identity
instance Eq UnifiedIdentity where
- (==) = (==) `on` idData
+ (==) = (==) `on` (idData &&& idUpdates)
data IdentityData = IdentityData
{ iddPrev :: [Stored (Signed IdentityData)]
diff --git a/src/Network.hs b/src/Network.hs
index 89034da..09cbea1 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -172,10 +172,29 @@ startServer origHead logd bhost services = do
return sock
loop sock = do
- let announce identity = do
+ void $ forkIO $ forever $ do
+ readMVar midentity >>= \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)
+ threadDelay $ announceIntervalSeconds * 1000 * 1000
+
+ let announceUpdate identity = do
+ st <- derivePartialStorage storage
+ let plaintext = BL.toStrict $ serializeObject $ transportToObject $ TransportHeader $
+ (AnnounceSelf $ partialRef st $ storedRef $ idData identity) :
+ map (AnnounceUpdate . partialRef st . storedRef) (idUpdates identity)
+
+ ps <- readMVar peers
+ forM_ ps $ \case
+ peer
+ | PeerIdentityFull _ <- peerIdentity peer
+ , ChannelEstablished ch <- peerChannel peer
+ , DatagramAddress paddr <- peerAddress peer
+ -> runExceptT (channelEncrypt ch plaintext) >>= \case
+ Right ctext -> void $ sendTo (peerSocket peer) ctext paddr
+ Left err -> logd $ "Failed to encrypt data: " ++ err
+ | otherwise -> return ()
let shareState self shared peer
| PeerIdentityFull pid <- peerIdentity peer
@@ -185,15 +204,11 @@ startServer origHead logd bhost services = do
Right () -> return ()
| otherwise = return ()
- void $ forkIO $ forever $ do
- announce =<< readMVar midentity
- threadDelay $ announceIntervalSeconds * 1000 * 1000
-
watchHead origHead $ \h -> do
let idt = headLocalIdentity h
changedId <- modifyMVar midentity $ \cur ->
return (idt, cur /= idt)
- when changedId $ announce idt
+ when changedId $ announceUpdate idt
let shared = lsShared $ load $ headRef h
changedShared <- modifyMVar mshared $ \cur ->
@@ -520,6 +535,7 @@ handleChannelAccept identity accref = do
sendIdentityUpdate :: UnifiedIdentity -> PacketHandler ()
sendIdentityUpdate self = do
ist <- gets $ peerInStorage . phPeer
+ addHeader $ AnnounceSelf $ partialRef ist $ storedRef $ idData $ self
mapM_ addHeader . map (AnnounceUpdate . partialRef ist . storedRef) . idUpdates $ self
@@ -539,6 +555,12 @@ handleIdentityUpdate :: PacketHandler ()
handleIdentityUpdate = do
peer <- gets phPeer
case (peerIdentity peer, peerIdentityUpdate peer) of
+ (PeerIdentityRef wref, _) -> checkWaitingRef wref >>= \case
+ Just ref | Just pid <- validateIdentity $ wrappedLoad ref -> do
+ updatePeer $ \p -> p { peerIdentity = PeerIdentityFull pid }
+ handleIdentityUpdate
+ _ -> return ()
+
(PeerIdentityFull pid, wrefs@(_:_)) -> do
(wrefs', upds) <- fmap partitionEithers $ forM wrefs $ \wref -> checkWaitingRef wref >>= \case
Just upd -> return $ Right $ wrappedLoad upd
@@ -547,6 +569,7 @@ handleIdentityUpdate = do
{ peerIdentity = PeerIdentityFull $ updateOwners upds pid
, peerIdentityUpdate = wrefs'
}
+
_ -> return ()