summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--main/State.hs5
-rw-r--r--main/Test.hs9
-rw-r--r--src/Erebos/Attach.hs2
-rw-r--r--src/Erebos/Chatroom.hs8
-rw-r--r--src/Erebos/Contact.hs2
-rw-r--r--src/Erebos/DirectMessage.hs4
-rw-r--r--src/Erebos/State.hs19
-rw-r--r--src/Erebos/Sync.hs2
-rw-r--r--test/storage.test1
9 files changed, 35 insertions, 17 deletions
diff --git a/main/State.hs b/main/State.hs
index 76441df..d357844 100644
--- a/main/State.hs
+++ b/main/State.hs
@@ -44,14 +44,15 @@ loadLocalStateHead term st = loadHeads st >>= \case
, ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ]
}
storeHead st $ LocalState
- { lsIdentity = idExtData identity
+ { lsPrev = Nothing
+ , lsIdentity = idExtData identity
, lsShared = [ shared ]
, lsOther = []
}
updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m ()
-updateSharedIdentity term = updateLocalHead_ $ updateSharedState_ $ \case
+updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case
Just identity -> do
Just . toComposedIdentity <$> interactiveIdentityUpdate term identity
Nothing -> throwOtherError "no existing shared identity"
diff --git a/main/Test.hs b/main/Test.hs
index 08ad880..e54285a 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -454,7 +454,8 @@ cmdCreateIdentity = do
_ -> return []
storeHead st $ LocalState
- { lsIdentity = idExtData identity
+ { lsPrev = Nothing
+ , lsIdentity = idExtData identity
, lsShared = shared
, lsOther = []
}
@@ -646,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
@@ -661,7 +662,7 @@ cmdUpdateLocalIdentity = do
cmdUpdateSharedIdentity :: Command
cmdUpdateSharedIdentity = do
[name] <- asks tiParams
- updateLocalHead_ $ updateSharedState_ $ \case
+ updateLocalState_ $ updateSharedState_ $ \case
Nothing -> throwOtherError "no existing shared identity"
Just identity -> do
let public = idKeyIdentity identity
@@ -731,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
diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs
index df61406..fad6197 100644
--- a/src/Erebos/Attach.hs
+++ b/src/Erebos/Attach.hs
@@ -52,7 +52,7 @@ instance PairingResult AttachIdentity where
guard $ iddPrev (fromSigned $ idData identity) == [eiddStoredBase curid]
return (identity, keys)
- pairingFinalizeRequest (identity, keys) = updateLocalHead_ $ \slocal -> do
+ pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \slocal -> do
let owner = finalOwner identity
st <- getStorage
pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index 2d4f272..74456ff 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -293,7 +293,7 @@ createChatroom rdName rdDescription = do
, rsdSubscribe = Just True
}
- updateLocalHead $ updateSharedState $ \rooms -> do
+ updateLocalState $ updateSharedState $ \rooms -> do
st <- getStorage
(, cstate) <$> storeSetAdd st cstate rooms
@@ -302,7 +302,7 @@ findAndUpdateChatroomState
=> (ChatroomState -> Maybe (m ChatroomState))
-> m (Maybe ChatroomState)
findAndUpdateChatroomState f = do
- updateLocalHead $ updateSharedState $ \roomSet -> do
+ updateLocalState $ updateSharedState $ \roomSet -> do
let roomList = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
case catMaybes $ map (\x -> (x,) <$> f x) roomList of
((orig, act) : _) -> do
@@ -523,7 +523,7 @@ instance Service ChatroomService where
}
when (not $ null chatRoomInfo) $ do
- updateLocalHead_ $ updateSharedState_ $ \roomSet -> do
+ updateLocalState_ $ updateSharedState_ $ \roomSet -> do
let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
upd set (roomInfo :: Stored (Signed ChatroomData)) = do
let currentRoots = storedRoots roomInfo
@@ -562,7 +562,7 @@ instance Service ChatroomService where
svcModify $ \ps -> ps { psSubscribedTo = filter (/= leastRoot) (psSubscribedTo ps) }
when (not (null chatRoomMessage)) $ do
- updateLocalHead_ $ updateSharedState_ $ \roomSet -> do
+ updateLocalState_ $ updateSharedState_ $ \roomSet -> do
let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
upd set (msgData :: Stored (Signed ChatMessageData))
| Just msg <- validateSingleMessage msgData = do
diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs
index 25239b9..88e6c44 100644
--- a/src/Erebos/Contact.hs
+++ b/src/Erebos/Contact.hs
@@ -165,7 +165,7 @@ contactReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m ()
contactReject = pairingReject @ContactAccepted Proxy
finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m ()
-finalizeContact identity = updateLocalHead_ $ updateSharedState_ $ \contacts -> do
+finalizeContact identity = updateLocalState_ $ updateSharedState_ $ \contacts -> do
st <- getStorage
cdata <- wrappedStore st ContactData
{ cdPrev = []
diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs
index 28d8085..05da865 100644
--- a/src/Erebos/DirectMessage.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -158,7 +158,7 @@ findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do
sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m)
=> Identity f -> Text -> m (Stored DirectMessage)
-sendDirectMessage pid text = updateLocalHead $ \ls -> do
+sendDirectMessage pid text = updateLocalState $ \ls -> do
let self = localIdentity $ fromStored ls
powner = finalOwner pid
flip updateSharedState ls $ \(DirectMessageThreads prev _) -> do
@@ -188,7 +188,7 @@ syncDirectMessageToPeer (DirectMessageThreads mss _) = do
peer <- asks svcPeer
let thread = messageThreadFor pid mss
mapM_ (sendToPeerStored peer) $ msgHead thread
- updateLocalHead_ $ \ls -> do
+ updateLocalState_ $ \ls -> do
let powner = finalOwner pid
flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do
let ready = findMsgProperty powner msReady prev
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs
index a2ecb9e..5ce9952 100644
--- a/src/Erebos/State.hs
+++ b/src/Erebos/State.hs
@@ -7,6 +7,7 @@ module Erebos.State (
MonadHead(..),
updateLocalHead_,
+ updateLocalState, updateLocalState_,
updateSharedState, updateSharedState_,
lookupSharedValue, makeSharedStateUpdate,
@@ -33,7 +34,8 @@ import Erebos.Storage.Head
import Erebos.Storage.Merge
data LocalState = LocalState
- { lsIdentity :: Stored (Signed ExtendedIdentityData)
+ { lsPrev :: Maybe RefDigest
+ , lsIdentity :: Stored (Signed ExtendedIdentityData)
, lsShared :: [Stored SharedState]
, lsOther :: [ ( ByteString, RecItem ) ]
}
@@ -55,11 +57,13 @@ class Mergeable a => SharedType a where
instance Storable LocalState where
store' LocalState {..} = storeRec $ do
+ mapM_ (storeRawWeak "PREV") lsPrev
storeRef "id" lsIdentity
mapM_ (storeRef "shared") lsShared
storeRecItems lsOther
load' = loadRec $ do
+ lsPrev <- loadMbRawWeak "PREV"
lsIdentity <- loadRef "id"
lsShared <- loadRefs "shared"
lsOther <- filter ((`notElem` [ BC.pack "id", BC.pack "shared" ]) . fst) <$> loadRecItems
@@ -106,6 +110,17 @@ headLocalIdentity :: Head LocalState -> UnifiedIdentity
headLocalIdentity = localIdentity . headObject
+updateLocalState :: forall m b. MonadHead LocalState m => (Stored LocalState -> m ( Stored LocalState, b )) -> m b
+updateLocalState f = updateLocalHead $ \ls -> do
+ ( ls', x ) <- f ls
+ (, x) <$> if ls' == ls
+ then return ls'
+ else mstore (fromStored ls') { lsPrev = Just $ refDigest (storedRef ls) }
+
+updateLocalState_ :: forall m. MonadHead LocalState m => (Stored LocalState -> m (Stored LocalState)) -> m ()
+updateLocalState_ f = updateLocalState (fmap (,()) . f)
+
+
updateSharedState_ :: forall a m. (SharedType a, MonadHead LocalState m) => (a -> m a) -> Stored LocalState -> m (Stored LocalState)
updateSharedState_ f = fmap fst <$> updateSharedState (fmap (,()) . f)
@@ -135,7 +150,7 @@ makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState
mergeSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => m UnifiedIdentity
-mergeSharedIdentity = updateLocalHead $ updateSharedState $ \case
+mergeSharedIdentity = updateLocalState $ updateSharedState $ \case
Just cidentity -> do
identity <- mergeIdentity cidentity
return (Just $ toComposedIdentity identity, identity)
diff --git a/src/Erebos/Sync.hs b/src/Erebos/Sync.hs
index 32e2e22..d837a14 100644
--- a/src/Erebos/Sync.hs
+++ b/src/Erebos/Sync.hs
@@ -23,7 +23,7 @@ instance Service SyncService where
pid <- asks svcPeerIdentity
self <- svcSelf
when (finalOwner pid `sameIdentity` finalOwner self) $ do
- updateLocalHead_ $ \ls -> do
+ updateLocalState_ $ \ls -> do
let current = sort $ lsShared $ fromStored ls
updated = filterAncestors (added : current)
if current /= updated
diff --git a/test/storage.test b/test/storage.test
index a5cca7f..2230eac 100644
--- a/test/storage.test
+++ b/test/storage.test
@@ -470,6 +470,7 @@ test LocalStateKeepUnknown:
send "load $s3"
expect /load-type rec [0-9]*/
+ expect /load-line PREV:w $s2/
expect /load-line id:r ($refpat)/ capture id2
guard (id1 /= id2)
expect /load-line TEST:i 123/
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-19 11:23:13 +0000