summaryrefslogtreecommitdiff
path: root/src/Network.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network.hs')
-rw-r--r--src/Network.hs213
1 files changed, 117 insertions, 96 deletions
diff --git a/src/Network.hs b/src/Network.hs
index 391e236..c5ce8cb 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -33,6 +33,7 @@ data Peer = Peer
, peerIdentity :: Maybe (Stored Identity)
, peerChannels :: [Channel]
, peerSocket :: Socket
+ , peerInStorage :: PartialStorage
}
deriving (Show)
@@ -40,15 +41,15 @@ data PeerAddress = DatagramAddress SockAddr
deriving (Show)
-data TransportHeader = AnnouncePacket Ref
- | IdentityRequest Ref Ref
- | IdentityResponse Ref
- | TrChannelRequest Ref
- | TrChannelAccept Ref
+data TransportHeader = AnnouncePacket PartialRef
+ | IdentityRequest PartialRef PartialRef
+ | IdentityResponse PartialRef
+ | TrChannelRequest PartialRef
+ | TrChannelAccept PartialRef
-data ServiceHeader = ServiceHeader T.Text Ref
+data ServiceHeader = ServiceHeader T.Text PartialRef
-transportToObject :: TransportHeader -> Object
+transportToObject :: TransportHeader -> PartialObject
transportToObject = \case
AnnouncePacket ref -> Rec
[ (BC.pack "TRANS", RecText $ T.pack "announce")
@@ -72,7 +73,7 @@ transportToObject = \case
, (BC.pack "acc", RecRef ref)
]
-transportFromObject :: Object -> Maybe TransportHeader
+transportFromObject :: PartialObject -> Maybe TransportHeader
transportFromObject (Rec items)
| Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "announce"
, Just (RecRef ref) <- lookup (BC.pack "identity") items
@@ -97,13 +98,13 @@ transportFromObject (Rec items)
transportFromObject _ = Nothing
-serviceToObject :: ServiceHeader -> Object
+serviceToObject :: ServiceHeader -> PartialObject
serviceToObject (ServiceHeader svc ref) = Rec
[ (BC.pack "SVC", RecText svc)
, (BC.pack "ref", RecRef ref)
]
-serviceFromObject :: Object -> Maybe ServiceHeader
+serviceFromObject :: PartialObject -> Maybe ServiceHeader
serviceFromObject (Rec items)
| Just (RecText svc) <- lookup (BC.pack "SVC") items
, Just (RecRef ref) <- lookup (BC.pack "ref") items
@@ -126,127 +127,146 @@ startServer logd bhost sidentity = 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 $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
+ void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ partialRef st $ storedRef sidentity) (addrAddress baddr)
forever $ do
(msg, paddr) <- recvFrom sock 4096
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
+ , Right (obj:objs) <- runExcept $ deserializeObjects (peerInStorage peer) $ 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 -> logd $ show paddr ++ ": invalid packet"
-
- packet sock paddr (AnnouncePacket ref) _ = do
+ -> do forM_ objs $ storeObject $ peerInStorage peer
+ copyRef (storedStorage sidentity) ref >>= \case
+ Just pref -> writeChan chanSvc (peer, svc, pref)
+ Nothing -> logd $ show paddr ++ ": incomplete service packet"
+
+ | otherwise -> do
+ ist <- case mbpeer of
+ Just peer -> return $ peerInStorage peer
+ Nothing -> derivePartialStorage $ storedStorage sidentity
+ if | Right (obj:objs) <- runExcept $ deserializeObjects ist $ BL.fromStrict msg
+ , Just tpack <- transportFromObject obj
+ -> packet sock paddr tpack objs ist
+
+ | otherwise -> logd $ show paddr ++ ": invalid packet"
+
+ packet sock paddr (AnnouncePacket ref) _ ist = do
logd $ "Got announce: " ++ show ref ++ " from " ++ show paddr
- when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
- [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
+ when (refDigest ref /= refDigest (storedRef sidentity)) $ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ IdentityRequest ref (partialRef ist $ storedRef sidentity)
, BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
]) paddr
- packet _ paddr (IdentityRequest ref from) [] = do
+ packet _ paddr (IdentityRequest ref from) [] _ = do
logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"
- packet sock paddr (IdentityRequest ref from) (obj:objs) = do
+ packet sock paddr (IdentityRequest ref from) (obj:objs) ist = do
logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
logd $ show (obj:objs)
- from' <- store (storedStorage sidentity) obj
+ from' <- storeObject ist obj
if from == from'
- then do forM_ objs $ store $ storedStorage sidentity
- 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
- [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
- , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
- ]) paddr
+ then do forM_ objs $ storeObject ist
+ copyRef (storedStorage sidentity) from >>= \case
+ Nothing -> logd $ "Incomplete peer identity"
+ Just sfrom -> do
+ let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad sfrom) [] sock ist
+ modifyMVar_ peers $ return . M.insert paddr peer
+ writeChan chanPeer peer
+ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ IdentityResponse (partialRef ist $ storedRef sidentity)
+ , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
+ ]) paddr
else logd $ "Mismatched content"
- packet _ paddr (IdentityResponse ref) [] = do
+ packet _ paddr (IdentityResponse ref) [] _ = do
logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"
- packet sock paddr (IdentityResponse ref) (obj:objs) = do
+ packet sock paddr (IdentityResponse ref) (obj:objs) ist = do
logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
logd $ show (obj:objs)
- ref' <- store (storedStorage sidentity) obj
+ ref' <- storeObject ist obj
if ref == ref'
- then do forM_ objs $ store $ storedStorage sidentity
- let pidentity = wrappedLoad ref
- peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock
- modifyMVar_ peers $ return . M.insert paddr peer
- writeChan chanPeer peer
- req <- createChannelRequest sidentity pidentity
- void $ sendTo sock (BL.toStrict $ BL.concat
- [ serializeObject $ transportToObject $ TrChannelRequest (storedRef req)
- , lazyLoadBytes $ storedRef req
- , lazyLoadBytes $ storedRef $ signedData $ fromStored req
- , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
- , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
- ]) paddr
+ then do forM_ objs $ storeObject ist
+ copyRef (storedStorage sidentity) ref >>= \case
+ Nothing -> logd $ "Incomplete peer identity"
+ Just sref -> do
+ let pidentity = wrappedLoad sref
+ peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock ist
+ modifyMVar_ peers $ return . M.insert paddr peer
+ writeChan chanPeer peer
+ req <- createChannelRequest sidentity pidentity
+ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ TrChannelRequest (partialRef ist $ storedRef req)
+ , lazyLoadBytes $ storedRef req
+ , lazyLoadBytes $ storedRef $ signedData $ fromStored req
+ , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
+ , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
+ ]) paddr
else logd $ "Mismatched content"
- packet _ paddr (TrChannelRequest _) [] = do
+ packet _ paddr (TrChannelRequest _) [] _ = do
logd $ "Got channel request: from " ++ show paddr ++ " without content"
- packet sock paddr (TrChannelRequest ref) (obj:objs) = do
+ packet sock paddr (TrChannelRequest ref) (obj:objs) ist = do
logd $ "Got channel request: from " ++ show paddr
logd $ show (obj:objs)
- ref' <- store (storedStorage sidentity) obj
+ ref' <- storeObject ist obj
if ref == ref'
- then do forM_ objs $ store $ storedStorage sidentity
- let request = wrappedLoad ref :: Stored ChannelRequest
- modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
- Just peer | Just pid <- peerIdentity peer ->
- runExceptT (acceptChannelRequest sidentity pid request) >>= \case
- Left errs -> do mapM_ logd ("Invalid channel request" : errs)
- return pval
- Right (acc, channel) -> do
- logd $ "Got channel: " ++ show (storedRef channel)
- let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
- writeChan chanPeer peer'
- void $ sendTo sock (BL.toStrict $ BL.concat
- [ serializeObject $ transportToObject $ TrChannelAccept (storedRef acc)
- , lazyLoadBytes $ storedRef acc
- , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
- , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
- , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
- ]) paddr
- return $ M.insert paddr peer' pval
-
- _ -> do logd $ "Invalid channel request - no peer identity"
- return pval
+ then do forM_ objs $ storeObject ist
+ copyRef (storedStorage sidentity) ref >>= \case
+ Nothing -> logd $ "Incomplete channel request"
+ Just sref -> do
+ let request = wrappedLoad sref :: Stored ChannelRequest
+ modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+ Just peer | Just pid <- peerIdentity peer ->
+ runExceptT (acceptChannelRequest sidentity pid request) >>= \case
+ Left errs -> do mapM_ logd ("Invalid channel request" : errs)
+ return pval
+ Right (acc, channel) -> do
+ logd $ "Got channel: " ++ show (storedRef channel)
+ let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+ writeChan chanPeer peer'
+ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ TrChannelAccept (partialRef ist $ storedRef acc)
+ , lazyLoadBytes $ storedRef acc
+ , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
+ , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
+ , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
+ ]) paddr
+ return $ M.insert paddr peer' pval
+
+ _ -> do logd $ "Invalid channel request - no peer identity"
+ return pval
else logd $ "Mismatched content"
- packet _ paddr (TrChannelAccept _) [] = do
+ packet _ paddr (TrChannelAccept _) [] _ = do
logd $ "Got channel accept: from " ++ show paddr ++ " without content"
- packet _ paddr (TrChannelAccept ref) (obj:objs) = do
+ packet _ paddr (TrChannelAccept ref) (obj:objs) ist = do
logd $ "Got channel accept: from " ++ show paddr
logd $ show (obj:objs)
- ref' <- store (storedStorage sidentity) obj
+ ref' <- storeObject ist obj
if ref == ref'
- then do forM_ objs $ store $ storedStorage sidentity
- let accepted = wrappedLoad ref :: Stored ChannelAccept
- modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
- Just peer | Just pid <- peerIdentity peer ->
- runExceptT (acceptedChannel sidentity pid accepted) >>= \case
- Left errs -> do mapM_ logd ("Invalid channel accept" : errs)
- return pval
- Right channel -> do
- logd $ "Got channel: " ++ show (storedRef channel)
- let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
- writeChan chanPeer peer'
- return $ M.insert paddr peer' pval
- _ -> do logd $ "Invalid channel accept - no peer identity"
- return pval
+ then do forM_ objs $ storeObject ist
+ copyRef (storedStorage sidentity) ref >>= \case
+ Nothing -> logd $ "Incomplete channel accept"
+ Just sref -> do
+ let accepted = wrappedLoad sref :: Stored ChannelAccept
+ modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+ Just peer | Just pid <- peerIdentity peer ->
+ runExceptT (acceptedChannel sidentity pid accepted) >>= \case
+ Left errs -> do mapM_ logd ("Invalid channel accept" : errs)
+ return pval
+ Right channel -> do
+ logd $ "Got channel: " ++ show (storedRef channel)
+ let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+ writeChan chanPeer peer'
+ return $ M.insert paddr peer' pval
+ _ -> do logd $ "Invalid channel accept - no peer identity"
+ return pval
else logd $ "Mismatched content"
@@ -262,12 +282,13 @@ startServer logd bhost sidentity = do
sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO ()
-sendToPeer self peer@Peer { peerChannels = ch:_ } svc obj = do
- let st = storedStorage self
+sendToPeer _ peer@Peer { peerChannels = ch:_ } svc obj = do
+ let st = peerInStorage peer
ref <- store st obj
+ Just bytes <- return $ lazyLoadBytes ref
let plain = BL.toStrict $ BL.concat
[ serializeObject $ serviceToObject $ ServiceHeader svc ref
- , lazyLoadBytes ref
+ , bytes
]
ctext <- channelEncrypt ch plain
let DatagramAddress paddr = peerAddress peer
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 21:18:01 +0000