summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-07-02 20:02:11 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-07-02 21:52:57 +0200
commitedafccea465f1f9448a1a7ae555b8615e5b5ac1b (patch)
tree85e7b6b5c4e610c27552ad4a8ecb4c4da764ade7 /src
parent5afb63aced2a6c5ec2fd3604f1b898d803686d8d (diff)
Shared state helpers usable with other local head updates
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs2
-rw-r--r--src/Contact.hs2
-rw-r--r--src/Message.hs2
-rw-r--r--src/State.hs36
-rw-r--r--src/Test.hs6
5 files changed, 24 insertions, 24 deletions
diff --git a/src/Attach.hs b/src/Attach.hs
index a776cad..67828aa 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -52,7 +52,7 @@ instance PairingResult AttachIdentity where
guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid]
return (identity, keys)
- pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \slocal -> liftIO $ do
+ pairingFinalizeRequest (identity, keys) = updateLocalHead_ $ \slocal -> liftIO $ do
let owner = finalOwner identity
st = storedStorage slocal
pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
diff --git a/src/Contact.hs b/src/Contact.hs
index 6585985..2d1e2a9 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -165,7 +165,7 @@ contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()
contactReject = pairingReject @ContactAccepted Proxy
finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m ()
-finalizeContact identity = updateSharedState_ $ \contacts -> do
+finalizeContact identity = updateLocalHead_ $ updateSharedState_ $ \contacts -> do
st <- getStorage
cdata <- wrappedStore st ContactData
{ cdPrev = []
diff --git a/src/Message.hs b/src/Message.hs
index a97e52f..ba45518 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -155,7 +155,7 @@ sendDirectMessage h peer text = do
self = headLocalIdentity h
powner = finalOwner pid
- smsg <- flip runReaderT h $ updateSharedState $ \(DirectMessageThreads prev _) -> liftIO $ do
+ smsg <- flip runReaderT h $ updateLocalHead $ updateSharedState $ \(DirectMessageThreads prev _) -> liftIO $ do
let sent = findMsgProperty powner msSent prev
received = findMsgProperty powner msReceived prev
diff --git a/src/State.hs b/src/State.hs
index 280e505..afdddc8 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -3,13 +3,14 @@ module State (
SharedState, SharedType(..),
SharedTypeID, mkSharedTypeID,
MonadStorage(..), MonadHead(..),
+ updateLocalHead_,
loadLocalStateHead,
- updateLocalState, updateLocalState_,
updateSharedState, updateSharedState_,
lookupSharedValue, makeSharedStateUpdate,
+ localIdentity,
headLocalIdentity,
mergeSharedIdentity,
@@ -88,6 +89,10 @@ class Monad m => MonadStorage m where
class (MonadIO m, MonadStorage m) => MonadHead a m where
updateLocalHead :: (Stored a -> m (Stored a, b)) -> m b
+updateLocalHead_ :: MonadHead a m => (Stored a -> m (Stored a)) -> m ()
+updateLocalHead_ f = updateLocalHead (fmap (,()) . f)
+
+
instance Monad m => MonadStorage (ReaderT (Head a) m) where
getStorage = asks $ refStorage . headRef
@@ -125,25 +130,20 @@ loadLocalStateHead st = loadHeads st >>= \case
, lsShared = [shared]
}
-headLocalIdentity :: Head LocalState -> UnifiedIdentity
-headLocalIdentity h =
- let ls = headObject h
- in maybe (error "failed to verify local identity")
- (updateOwners $ maybe [] idDataF $ lookupSharedValue $ lsShared ls)
- (validateIdentity $ lsIdentity ls)
+localIdentity :: LocalState -> UnifiedIdentity
+localIdentity ls = maybe (error "failed to verify local identity")
+ (updateOwners $ maybe [] idDataF $ lookupSharedValue $ lsShared ls)
+ (validateIdentity $ lsIdentity ls)
+headLocalIdentity :: Head LocalState -> UnifiedIdentity
+headLocalIdentity = localIdentity . headObject
-updateLocalState_ :: MonadHead LocalState m => (Stored LocalState -> m (Stored LocalState)) -> m ()
-updateLocalState_ f = updateLocalState (fmap (,()) . f)
-
-updateLocalState :: MonadHead LocalState m => (Stored LocalState -> m (Stored LocalState, a)) -> m a
-updateLocalState = updateLocalHead
-updateSharedState_ :: (SharedType a, MonadHead LocalState m) => (a -> m a) -> m ()
-updateSharedState_ f = updateSharedState (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)
-updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> m (a, b)) -> m b
-updateSharedState f = updateLocalHead $ \ls -> do
+updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b)
+updateSharedState f = \ls -> do
let shared = lsShared $ fromStored ls
val = lookupSharedValue shared
st = storedStorage ls
@@ -168,14 +168,14 @@ makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState
mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity
-mergeSharedIdentity = updateSharedState $ \case
+mergeSharedIdentity = updateLocalHead $ updateSharedState $ \case
Just cidentity -> do
identity <- liftIO $ mergeIdentity cidentity
return (Just $ toComposedIdentity identity, identity)
Nothing -> throwError "no existing shared identity"
updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m ()
-updateSharedIdentity = updateSharedState_ $ \case
+updateSharedIdentity = updateLocalHead_ $ updateSharedState_ $ \case
Just identity -> do
Just . toComposedIdentity <$> liftIO (interactiveIdentityUpdate identity)
Nothing -> throwError "no existing shared identity"
diff --git a/src/Test.hs b/src/Test.hs
index 04a5c9c..84505c2 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -404,7 +404,7 @@ cmdWatchSharedIdentity = do
cmdUpdateLocalIdentity :: Command
cmdUpdateLocalIdentity = do
[name] <- asks tiParams
- updateLocalState_ $ \ls -> liftIO $ do
+ updateLocalHead_ $ \ls -> liftIO $ do
Just identity <- return $ validateIdentity $ lsIdentity $ fromStored ls
let st = storedStorage ls
public = idKeyIdentity identity
@@ -420,7 +420,7 @@ cmdUpdateLocalIdentity = do
cmdUpdateSharedIdentity :: Command
cmdUpdateSharedIdentity = do
[name] <- asks tiParams
- updateSharedState_ $ \case
+ updateLocalHead_ $ updateSharedState_ $ \case
Nothing -> throwError "no existing shared identity"
Just identity -> liftIO $ do
let st = storedStorage $ head $ idDataF identity
@@ -486,7 +486,7 @@ cmdContactSetName = do
[contact] <- flip filterM contacts $ \c -> do
r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents c
return $ T.pack (show $ refDigest $ storedRef r) == cid
- updateSharedState_ $ contactSetName contact name
+ updateLocalHead_ $ updateSharedState_ $ contactSetName contact name
cmdOut "contact-set-name-done"
cmdDmSendPeer :: Command