summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Attach.hs2
-rw-r--r--src/Contact.hs15
-rw-r--r--src/Message.hs2
-rw-r--r--src/Service.hs2
-rw-r--r--src/State.hs22
-rw-r--r--src/Storage.hs26
-rw-r--r--src/Test.hs8
7 files changed, 38 insertions, 39 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 21:20:25 +0000