Generalize head updates to provided MonadIO instances

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