1 files changed, 27 insertions, 16 deletions

diff --git a/main/Test.hs b/main/Test.hs
index 0181575..f2adf22 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -26,7 +26,7 @@ import Data.Text qualified as T
 import Data.Text.Encoding
 import Data.Text.IO qualified as T
 import Data.Typeable
-import Data.UUID qualified as U
+import Data.UUID.Types qualified as U
 
 import Network.Socket
 
@@ -36,17 +36,19 @@ import System.IO.Error
 import Erebos.Attach
 import Erebos.Chatroom
 import Erebos.Contact
+import Erebos.DirectMessage
 import Erebos.Discovery
 import Erebos.Identity
-import Erebos.Message
 import Erebos.Network
+import Erebos.Object
 import Erebos.Pairing
 import Erebos.PubKey
 import Erebos.Service
 import Erebos.Set
 import Erebos.State
+import Erebos.Storable
 import Erebos.Storage
-import Erebos.Storage.Internal (unsafeStoreRawBytes)
+import Erebos.Storage.Head
 import Erebos.Storage.Merge
 import Erebos.Sync
 
@@ -101,7 +103,7 @@ runTestTool st = do
             Nothing -> return ()
 
     runExceptT (evalStateT testLoop initTestState) >>= \case
-        Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x
+        Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x)
         Right () -> return ()
 
 getLineMb :: MonadIO m => m (Maybe Text)
@@ -173,7 +175,7 @@ pairingAttributes _ out peers prefix = PairingAttributes
     , pairingHookFailed = \case
         PairingUserRejected -> failed "user"
         PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet
-        PairingFailedOther str -> failed $ "other " ++ str
+        PairingFailedOther err -> failed $ "other " ++ showErebosError err
     , pairingHookVerifyFailed = failed "verify"
     , pairingHookRejected = failed "rejected"
     }
@@ -224,11 +226,11 @@ dmReceivedWatcher out smsg = do
         ]
 
 
-newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a)
-    deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String)
+newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a)
+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError ErebosError)
 
 instance MonadFail CommandM where
-    fail = throwError
+    fail = throwOtherError
 
 instance MonadRandom CommandM where
     getRandomBytes = liftIO . getRandomBytes
@@ -304,12 +306,20 @@ commands = map (T.pack *** id)
 cmdStore :: Command
 cmdStore = do
     st <- asks tiStorage
+    pst <- liftIO $ derivePartialStorage st
     [otype] <- asks tiParams
     ls <- getLines
 
     let cnt = encodeUtf8 $ T.unlines ls
-    ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
-    cmdOut $ "store-done " ++ show (refDigest ref)
+        full = BL.fromChunks
+            [ encodeUtf8 otype
+            , BC.singleton ' '
+            , BC.pack (show $ B.length cnt)
+            , BC.singleton '\n', cnt
+            ]
+    liftIO (copyRef st =<< storeRawBytes pst full) >>= \case
+        Right ref -> cmdOut $ "store-done " ++ show (refDigest ref)
+        Left _ -> cmdOut $ "store-failed"
 
 cmdLoad :: Command
 cmdLoad = do
@@ -444,7 +454,8 @@ cmdCreateIdentity = do
             _ -> return []
 
         storeHead st $ LocalState
-            { lsIdentity = idExtData identity
+            { lsPrev = Nothing
+            , lsIdentity = idExtData identity
             , lsShared = shared
             , lsOther = []
             }
@@ -492,7 +503,7 @@ cmdStartServer = do
                     void $ store (headStorage h) obj
                     outLine out $ unwords ["test-message-received", otype, len, sref]
             }
-        sname -> throwError $ "unknown service `" <> T.unpack sname <> "'"
+        sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
 
     rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services
 
@@ -636,7 +647,7 @@ cmdWatchSharedIdentity = do
 cmdUpdateLocalIdentity :: Command
 cmdUpdateLocalIdentity = do
     [name] <- asks tiParams
-    updateLocalHead_ $ \ls -> do
+    updateLocalState_ $ \ls -> do
         Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls
         let public = idKeyIdentity identity
 
@@ -651,8 +662,8 @@ cmdUpdateLocalIdentity = do
 cmdUpdateSharedIdentity :: Command
 cmdUpdateSharedIdentity = do
     [name] <- asks tiParams
-    updateLocalHead_ $ updateSharedState_ $ \case
-        Nothing -> throwError "no existing shared identity"
+    updateLocalState_ $ updateSharedState_ $ \case
+        Nothing -> throwOtherError "no existing shared identity"
         Just identity -> do
             let public = idKeyIdentity identity
             secret <- loadKey public
@@ -721,7 +732,7 @@ cmdContactSetName :: Command
 cmdContactSetName = do
     [cid, name] <- asks tiParams
     contact <- getContact cid
-    updateLocalHead_ $ updateSharedState_ $ contactSetName contact name
+    updateLocalState_ $ updateSharedState_ $ contactSetName contact name
     cmdOut "contact-set-name-done"
 
 cmdDmSendPeer :: Command