summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-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
6 files changed, 26 insertions, 11 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-21 04:04:43 +0000