summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--main/Test.hs9
-rw-r--r--main/Test/Service.hs9
-rw-r--r--src/Erebos/Storage.hs8
-rw-r--r--test/network.test41
-rw-r--r--test/storage.test22
5 files changed, 81 insertions, 8 deletions
diff --git a/main/Test.hs b/main/Test.hs
index 2155e09..741ffe8 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -309,7 +309,8 @@ cmdLoad = do
st <- asks tiStorage
[ tref ] <- asks tiParams
Just ref <- liftIO $ readRef st $ encodeUtf8 tref
- header : content <- return $ BL.lines $ lazyLoadBytes ref
+ let obj = load @Object ref
+ header : content <- return $ BL.lines $ serializeObject obj
cmdOut $ "load-type " <> T.unpack (decodeUtf8 $ BL.toStrict header)
forM_ content $ \line -> do
cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line)
@@ -455,8 +456,10 @@ cmdStartServer = do
, someService @SyncService Proxy
, someService @ChatroomService Proxy
, someServiceAttr $ (defaultServiceAttributes Proxy)
- { testMessageReceived = \otype len sref ->
- liftIO $ outLine out $ unwords ["test-message-received", otype, len, sref]
+ { testMessageReceived = \obj otype len sref -> do
+ liftIO $ do
+ void $ store (headStorage h) obj
+ outLine out $ unwords ["test-message-received", otype, len, sref]
}
]
diff --git a/main/Test/Service.hs b/main/Test/Service.hs
index 1018e0d..3e6eb83 100644
--- a/main/Test/Service.hs
+++ b/main/Test/Service.hs
@@ -14,7 +14,7 @@ import Erebos.Storage
data TestMessage = TestMessage (Stored Object)
data TestMessageAttributes = TestMessageAttributes
- { testMessageReceived :: String -> String -> String -> ServiceHandler TestMessage ()
+ { testMessageReceived :: Object -> String -> String -> String -> ServiceHandler TestMessage ()
}
instance Storable TestMessage where
@@ -25,12 +25,13 @@ instance Service TestMessage where
serviceID _ = mkServiceID "cb46b92c-9203-4694-8370-8742d8ac9dc8"
type ServiceAttributes TestMessage = TestMessageAttributes
- defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ -> return ())
+ defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ _ -> return ())
serviceHandler smsg = do
let TestMessage sobj = fromStored smsg
- case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject $ fromStored sobj of
+ obj = fromStored sobj
+ case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject obj of
[otype, len] -> do
cb <- asks $ testMessageReceived . svcAttributes
- cb otype len (show $ refDigest $ storedRef sobj)
+ cb obj otype len (show $ refDigest $ storedRef sobj)
_ -> return ()
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs
index 2e60f4e..65210f9 100644
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -226,6 +226,7 @@ copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => S
copyObject' _ (Blob bs) = return $ return $ Blob bs
copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs
copyObject' _ ZeroObject = return $ return ZeroObject
+copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content
copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))
copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref'
@@ -247,6 +248,7 @@ data Object' c
= Blob ByteString
| Rec [(ByteString, RecItem' c)]
| ZeroObject
+ | UnknownObject ByteString ByteString
deriving (Show)
type Object = Object' Complete
@@ -271,6 +273,7 @@ serializeObject = \case
Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec
in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt
ZeroObject -> BL.empty
+ UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]
-- |Serializes and stores object data without ony dependencies, so is safe only
-- if all the referenced objects are already stored or reference is partial.
@@ -329,7 +332,7 @@ unsafeDeserializeObject st bytes =
_ | otype == BC.pack "blob" -> return $ Blob content
| otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ")
(return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content
- | otherwise -> throwError $ "Unknown object type"
+ | otherwise -> return $ UnknownObject otype content
_ -> throwError $ "Malformed object"
where splitObjPrefix line = do
[otype, tlen] <- return $ BLC.words line
@@ -610,6 +613,7 @@ class Storable a => ZeroStorable a where
data Store = StoreBlob ByteString
| StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])
| StoreZero
+ | StoreUnknown ByteString ByteString
evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c)
evalStore st = unsafeStoreObject st <=< evalStoreObject st
@@ -618,6 +622,7 @@ evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c
evalStoreObject _ (StoreBlob x) = return $ Blob x
evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s)
evalStoreObject _ StoreZero = return ZeroObject
+evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content
newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)
deriving (Functor, Applicative, Monad)
@@ -652,6 +657,7 @@ instance Storable Object where
Rec xs' <- copyObject st (Rec xs)
return xs'
store' ZeroObject = StoreZero
+ store' (UnknownObject otype content) = StoreUnknown otype content
load' = loadCurrentObject
diff --git a/test/network.test b/test/network.test
index efd508f..6f16f7d 100644
--- a/test/network.test
+++ b/test/network.test
@@ -380,3 +380,44 @@ test Reconnection:
guard (done == "done")
expect /test-message-received blob [0-9]+ $message/
+
+
+test SendUnknownObjectType:
+ let refpat = /blake2#[0-9a-f]*/
+
+ spawn as p1
+ spawn as p2
+
+ with p1:
+ send "create-identity Device1"
+ send "start-server"
+ with p2:
+ send "create-identity Device2"
+ send "start-server"
+
+ expect from p1:
+ /peer 1 addr ${p2.node.ip} 29665/
+ /peer 1 id Device2/
+ expect from p2:
+ /peer 1 addr ${p1.node.ip} 29665/
+ /peer 1 id Device1/
+
+ with p1:
+ send:
+ "store test-unknown"
+ "TEST"
+ ""
+ expect /store-done ($refpat)/ capture r1
+
+ send "test-message-send 1 $r1"
+ expect /test-message-send done/
+
+ with p2:
+ expect /test-message-received test-unknown [0-9]+ $r1/
+
+ send "load $r1"
+ expect /load-type test-unknown 5/
+ expect /load-line TEST/
+ local:
+ expect /load-(.*)/ capture done
+ guard (done == "done")
diff --git a/test/storage.test b/test/storage.test
index 3d898b1..2a53bb8 100644
--- a/test/storage.test
+++ b/test/storage.test
@@ -474,3 +474,25 @@ test LocalStateKeepUnknown:
local:
expect /load-(.*)/ capture done
guard (done == "done")
+
+
+test UnknownObjectType:
+ let refpat = /blake2#[0-9a-f]*/
+
+ spawn as p
+ spawn as p2 on p.node
+
+ with p:
+ send:
+ "store test-unknown"
+ "TEST"
+ ""
+ expect /store-done ($refpat)/ capture r1
+
+ with p2:
+ send "load $r1"
+ expect /load-type test-unknown 5/
+ expect /load-line TEST/
+ local:
+ expect /load-(.*)/ capture done
+ guard (done == "done")
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-08 10:50:39 +0000