From 394d35d586fba3db55217e1e9f1e88e8bc8a0719 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 2 Jun 2019 20:29:35 +0200 Subject: Partial and memory-backed storage variants --- src/Network.hs | 213 +++++++++++++++++++++++++++++++-------------------------- 1 file changed, 117 insertions(+), 96 deletions(-) (limited to 'src/Network.hs') 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 -- cgit v1.2.3