summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Channel.hs9
-rw-r--r--src/Network.hs45
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