Shared state helpers usable with other local head updates

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