From 6c13b1285605020bb3c510dd1862d2d8d9828337 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 17 Jul 2022 22:51:32 +0200 Subject: Generalize head updates to provided MonadIO instances --- src/Attach.hs | 2 +- src/Contact.hs | 15 +++++++-------- src/Message.hs | 2 +- src/Service.hs | 2 +- src/State.hs | 22 +++++++++++----------- src/Storage.hs | 26 +++++++++++++------------- src/Test.hs | 8 ++++---- 7 files changed, 38 insertions(+), 39 deletions(-) (limited to 'src') diff --git a/src/Attach.hs b/src/Attach.hs index c27b383..0e32294 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 -> do + pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \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 70e79b9..1dc926e 100644 --- a/src/Contact.hs +++ b/src/Contact.hs @@ -153,12 +153,11 @@ contactReject :: (MonadIO m, MonadError String m) => Peer -> m () contactReject = pairingReject @ContactAccepted Proxy finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m () -finalizeContact identity = do +finalizeContact identity = updateSharedState_ $ \contacts -> do st <- getStorage - updateSharedState_ $ \contacts -> do - cdata <- wrappedStore st ContactData - { cdPrev = [] - , cdIdentity = idDataF $ finalOwner identity - , cdName = Nothing - } - storeSetAdd st (mergeSorted @Contact [cdata]) contacts + cdata <- wrappedStore st ContactData + { cdPrev = [] + , cdIdentity = idDataF $ finalOwner identity + , cdName = Nothing + } + storeSetAdd st (mergeSorted @Contact [cdata]) contacts diff --git a/src/Message.hs b/src/Message.hs index 46d75f1..06117fe 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -135,7 +135,7 @@ sendDirectMessage h peer text = do self = headLocalIdentity h powner = finalOwner pid - smsg <- flip runReaderT h $ updateSharedState $ \(DirectMessageThreads prev _) -> do + smsg <- flip runReaderT h $ updateSharedState $ \(DirectMessageThreads prev _) -> liftIO $ do let sent = findMsgProperty powner msSent prev received = findMsgProperty powner msReceived prev diff --git a/src/Service.hs b/src/Service.hs index 22c983b..96fa63d 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -116,7 +116,7 @@ instance MonadStorage (ServiceHandler s) where instance MonadHead LocalState (ServiceHandler s) where updateLocalHead f = do - (ls, x) <- liftIO . f =<< gets svcLocal + (ls, x) <- f =<< gets svcLocal modify $ \s -> s { svcLocal = ls } return x diff --git a/src/State.hs b/src/State.hs index e112aca..6790d45 100644 --- a/src/State.hs +++ b/src/State.hs @@ -84,8 +84,8 @@ instance SharedType (Maybe ComposedIdentity) where class Monad m => MonadStorage m where getStorage :: m Storage -class MonadStorage m => MonadHead a m where - updateLocalHead :: (Stored a -> IO (Stored a, b)) -> m b +class (MonadIO m, MonadStorage m) => MonadHead a m where + updateLocalHead :: (Stored a -> m (Stored a, b)) -> m b instance Monad m => MonadStorage (ReaderT (Head a) m) where getStorage = asks $ refStorage . headRef @@ -93,7 +93,7 @@ instance Monad m => MonadStorage (ReaderT (Head a) m) where instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where updateLocalHead f = do h <- ask - liftIO $ snd <$> updateHead h f + snd <$> updateHead h f loadLocalStateHead :: Storage -> IO (Head LocalState) @@ -132,16 +132,16 @@ headLocalIdentity h = (validateIdentity $ lsIdentity ls) -updateLocalState_ :: MonadHead LocalState m => (Stored LocalState -> IO (Stored LocalState)) -> m () +updateLocalState_ :: MonadHead LocalState m => (Stored LocalState -> m (Stored LocalState)) -> m () updateLocalState_ f = updateLocalState (fmap (,()) . f) -updateLocalState :: MonadHead LocalState m => (Stored LocalState -> IO (Stored LocalState, a)) -> m a +updateLocalState :: MonadHead LocalState m => (Stored LocalState -> m (Stored LocalState, a)) -> m a updateLocalState = updateLocalHead -updateSharedState_ :: (SharedType a, MonadHead LocalState m) => (a -> IO a) -> m () +updateSharedState_ :: (SharedType a, MonadHead LocalState m) => (a -> m a) -> m () updateSharedState_ f = updateSharedState (fmap (,()) . f) -updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> IO (a, b)) -> m b +updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> m (a, b)) -> m b updateSharedState f = updateLocalHead $ \ls -> do let shared = lsShared $ fromStored ls val = lookupSharedValue shared @@ -158,8 +158,8 @@ lookupSharedValue = mergeSorted . filterAncestors . map wrappedLoad . concatMap | otherwise = helper $ ssPrev (fromStored x) ++ xs helper [] = [] -makeSharedStateUpdate :: forall a. SharedType a => Storage -> a -> [Stored SharedState] -> IO (Stored SharedState) -makeSharedStateUpdate st val prev = wrappedStore st SharedState +makeSharedStateUpdate :: forall a m. MonadIO m => SharedType a => Storage -> a -> [Stored SharedState] -> m (Stored SharedState) +makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState { ssPrev = prev , ssType = Just $ sharedTypeID @a Proxy , ssValue = storedRef <$> toComponents val @@ -168,12 +168,12 @@ makeSharedStateUpdate st val prev = wrappedStore st SharedState mergeSharedIdentity :: MonadHead LocalState m => m UnifiedIdentity mergeSharedIdentity = updateSharedState $ \(Just cidentity) -> do - identity <- mergeIdentity cidentity + identity <- liftIO $ mergeIdentity cidentity return (Just $ toComposedIdentity identity, identity) updateSharedIdentity :: MonadHead LocalState m => m () updateSharedIdentity = updateSharedState_ $ \(Just identity) -> do - Just . toComposedIdentity <$> interactiveIdentityUpdate identity + Just . toComposedIdentity <$> liftIO (interactiveIdentityUpdate identity) interactiveIdentityUpdate :: Foldable m => Identity m -> IO UnifiedIdentity interactiveIdentityUpdate identity = do diff --git a/src/Storage.hs b/src/Storage.hs index e1bce3c..6dd7cdf 100644 --- a/src/Storage.hs +++ b/src/Storage.hs @@ -379,8 +379,8 @@ headTypePath spath (HeadTypeID tid) = spath "heads" U.toString tid headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath headPath spath tid (HeadID hid) = headTypePath spath tid U.toString hid -loadHeads :: forall a. HeadType a => Storage -> IO [Head a] -loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = do +loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] +loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do let hpath = headTypePath spath $ headTypeID @a Proxy files <- filterM (doesFileExist . (hpath )) =<< @@ -393,25 +393,25 @@ loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = do Just ref <- readRef s h return $ Just $ Head (HeadID hid) $ wrappedLoad ref Nothing -> return Nothing -loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = do +loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref | otherwise = Nothing catMaybes . map toHead <$> readMVar theads -loadHead :: forall a. HeadType a => Storage -> HeadID -> IO (Maybe (Head a)) -loadHead s@(Storage { stBacking = StorageDir { dirPath = spath }}) hid = do +loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a)) +loadHead s@(Storage { stBacking = StorageDir { dirPath = spath }}) hid = liftIO $ do handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do (h:_) <- BC.lines <$> B.readFile (headPath spath (headTypeID @a Proxy) hid) Just ref <- readRef s h return $ Just $ Head hid $ wrappedLoad ref -loadHead Storage { stBacking = StorageMemory { memHeads = theads } } hid = do +loadHead Storage { stBacking = StorageMemory { memHeads = theads } } hid = liftIO $ do fmap (Head hid . wrappedLoad) . lookup (headTypeID @a Proxy, hid) <$> readMVar theads -reloadHead :: HeadType a => Head a -> IO (Maybe (Head a)) +reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid -storeHead :: forall a. HeadType a => Storage -> a -> IO (Head a) -storeHead st obj = do +storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) +storeHead st obj = liftIO $ do let tid = headTypeID @a Proxy hid <- HeadID <$> U.nextRandom stored <- wrappedStore st obj @@ -424,8 +424,8 @@ storeHead st obj = do modifyMVar_ theads $ return . (((tid, hid), storedRef stored) :) return $ Head hid stored -replaceHead :: forall a. HeadType a => Head a -> Stored a -> IO (Either (Maybe (Head a)) (Head a)) -replaceHead prev@(Head hid pobj) stored = do +replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a)) +replaceHead prev@(Head hid pobj) stored = liftIO $ do let st = storedStorage pobj tid = headTypeID @a Proxy case stBacking st of @@ -451,7 +451,7 @@ replaceHead prev@(Head hid pobj) stored = do Right (h, ws) -> mapM_ ($ headRef h) ws >> return (Right h) Left x -> return $ Left x -updateHead :: HeadType a => Head a -> (Stored a -> IO (Stored a, b)) -> IO (Maybe (Head a), b) +updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b) updateHead h f = do (o, x) <- f $ headStoredObject h replaceHead h o >>= \case @@ -459,7 +459,7 @@ updateHead h f = do Left Nothing -> return (Nothing, x) Left (Just h') -> updateHead h' f -updateHead_ :: HeadType a => Head a -> (Stored a -> IO (Stored a)) -> IO (Maybe (Head a)) +updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a)) updateHead_ h = fmap fst . updateHead h . (fmap (,()) .) diff --git a/src/Test.hs b/src/Test.hs index c106285..30aa8c4 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -175,7 +175,7 @@ instance MonadStorage CommandM where instance MonadHead LocalState CommandM where updateLocalHead f = do Just h <- gets tsHead - (Just h', x) <- liftIO $ maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h + (Just h', x) <- maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h modify $ \s -> s { tsHead = Just h' } return x @@ -319,7 +319,7 @@ cmdWatchSharedIdentity = do cmdUpdateLocalIdentity :: Command cmdUpdateLocalIdentity = do [name] <- asks tiParams - updateLocalState_ $ \ls -> do + updateLocalState_ $ \ls -> liftIO $ do let Just identity = validateIdentity $ lsIdentity $ fromStored ls st = storedStorage ls public = idKeyIdentity identity @@ -335,7 +335,7 @@ cmdUpdateLocalIdentity = do cmdUpdateSharedIdentity :: Command cmdUpdateSharedIdentity = do [name] <- asks tiParams - updateSharedState_ $ \(Just identity) -> do + updateSharedState_ $ \(Just identity) -> liftIO $ do let st = storedStorage $ head $ idDataF identity public = idKeyIdentity identity @@ -378,7 +378,7 @@ cmdContactReject = do cmdContactList :: Command cmdContactList = do - h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") (liftIO . reloadHead) =<< gets tsHead + h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") reloadHead =<< gets tsHead let contacts = fromSetBy (comparing contactName) . lookupSharedValue . lsShared . headObject $ h forM_ contacts $ \c -> do cmdOut $ concat -- cgit v1.2.3