diff options
| -rw-r--r-- | src/Channel.hs | 9 | ||||
| -rw-r--r-- | src/Network.hs | 45 |
2 files changed, 28 insertions, 26 deletions
diff --git a/src/Channel.hs b/src/Channel.hs index ee10e89..9be4405 100644 --- a/src/Channel.hs +++ b/src/Channel.hs @@ -89,9 +89,8 @@ instance Storable ChannelAcceptData where <*> loadRef "key" -createChannelRequest :: Stored Identity -> Stored Identity -> IO (Stored ChannelRequest) -createChannelRequest self peer = do - let st = storedStorage self +createChannelRequest :: Storage -> Stored Identity -> Stored Identity -> IO (Stored ChannelRequest) +createChannelRequest st self peer = do (_, xpublic) <- generateKeys st Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self wrappedStore st =<< sign skey =<< wrappedStore st ChannelRequest { crPeers = sort [self, peer], crKey = xpublic } @@ -101,7 +100,7 @@ acceptChannelRequest self peer req = do guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer] guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req) - let st = storedStorage self + let st = storedStorage req KeySizeFixed ksize = cipherKeySize (undefined :: AES128) liftIO $ do (xsecret, xpublic) <- generateKeys st @@ -116,7 +115,7 @@ acceptChannelRequest self peer req = do acceptedChannel :: Stored Identity -> Stored Identity -> Stored ChannelAccept -> ExceptT [String] IO (Stored Channel) acceptedChannel self peer acc = do - let st = storedStorage self + let st = storedStorage acc req = caRequest $ fromStored $ signedData $ fromStored acc KeySizeFixed ksize = cipherKeySize (undefined :: AES128) diff --git a/src/Network.hs b/src/Network.hs index c5ce8cb..eb72ed2 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -33,6 +33,7 @@ data Peer = Peer , peerIdentity :: Maybe (Stored Identity) , peerChannels :: [Channel] , peerSocket :: Socket + , peerStorage :: Storage , peerInStorage :: PartialStorage } deriving (Show) @@ -139,40 +140,42 @@ startServer logd bhost sidentity = do , Right (obj:objs) <- runExcept $ deserializeObjects (peerInStorage peer) $ BL.fromStrict plain , Just (ServiceHeader svc ref) <- serviceFromObject obj -> do forM_ objs $ storeObject $ peerInStorage peer - copyRef (storedStorage sidentity) ref >>= \case + copyRef (peerStorage peer) 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 + (pst, ist) <- case mbpeer of + Just peer -> return (peerStorage peer, peerInStorage peer) + Nothing -> do pst <- deriveEphemeralStorage $ storedStorage sidentity + ist <- derivePartialStorage pst + return (pst, ist) if | Right (obj:objs) <- runExcept $ deserializeObjects ist $ BL.fromStrict msg , Just tpack <- transportFromObject obj - -> packet sock paddr tpack objs ist + -> packet sock paddr tpack objs pst ist | otherwise -> logd $ show paddr ++ ": invalid packet" - packet sock paddr (AnnouncePacket ref) _ ist = do + packet sock paddr (AnnouncePacket ref) _ _ ist = do logd $ "Got announce: " ++ show ref ++ " from " ++ show paddr 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) ist = do + packet sock paddr (IdentityRequest ref from) (obj:objs) pst ist = do logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr logd $ show (obj:objs) from' <- storeObject ist obj if from == from' then do forM_ objs $ storeObject ist - copyRef (storedStorage sidentity) from >>= \case + copyRef pst from >>= \case Nothing -> logd $ "Incomplete peer identity" Just sfrom -> do - let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad sfrom) [] sock ist + let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad sfrom) [] sock pst ist modifyMVar_ peers $ return . M.insert paddr peer writeChan chanPeer peer void $ sendTo sock (BL.toStrict $ BL.concat @@ -181,23 +184,23 @@ startServer logd bhost sidentity = do ]) 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) ist = do + packet sock paddr (IdentityResponse ref) (obj:objs) pst ist = do logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr logd $ show (obj:objs) ref' <- storeObject ist obj if ref == ref' then do forM_ objs $ storeObject ist - copyRef (storedStorage sidentity) ref >>= \case + copyRef pst ref >>= \case Nothing -> logd $ "Incomplete peer identity" Just sref -> do let pidentity = wrappedLoad sref - peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock ist + peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock pst ist modifyMVar_ peers $ return . M.insert paddr peer writeChan chanPeer peer - req <- createChannelRequest sidentity pidentity + req <- createChannelRequest pst sidentity pidentity void $ sendTo sock (BL.toStrict $ BL.concat [ serializeObject $ transportToObject $ TrChannelRequest (partialRef ist $ storedRef req) , lazyLoadBytes $ storedRef req @@ -207,16 +210,16 @@ startServer logd bhost sidentity = do ]) 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) ist = do + packet sock paddr (TrChannelRequest ref) (obj:objs) pst ist = do logd $ "Got channel request: from " ++ show paddr logd $ show (obj:objs) ref' <- storeObject ist obj if ref == ref' then do forM_ objs $ storeObject ist - copyRef (storedStorage sidentity) ref >>= \case + copyRef pst ref >>= \case Nothing -> logd $ "Incomplete channel request" Just sref -> do let request = wrappedLoad sref :: Stored ChannelRequest @@ -242,16 +245,16 @@ startServer logd bhost sidentity = do 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) ist = do + packet _ paddr (TrChannelAccept ref) (obj:objs) pst ist = do logd $ "Got channel accept: from " ++ show paddr logd $ show (obj:objs) ref' <- storeObject ist obj if ref == ref' then do forM_ objs $ storeObject ist - copyRef (storedStorage sidentity) ref >>= \case + copyRef pst ref >>= \case Nothing -> logd $ "Incomplete channel accept" Just sref -> do let accepted = wrappedLoad sref :: Stored ChannelAccept |