Partial and memory-backed storage variants

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