diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Attach.hs | 2 | ||||
| -rw-r--r-- | src/Contact.hs | 2 | ||||
| -rw-r--r-- | src/Message.hs | 2 | ||||
| -rw-r--r-- | src/State.hs | 36 | ||||
| -rw-r--r-- | src/Test.hs | 6 |
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 |