From b8e55c64a68763b0953945476cc75206f5354023 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Tue, 17 May 2022 22:06:01 +0200
Subject: Mergeable class with separate component type

---
 src/Contact.hs | 30 +++++++++++++++++++++---------
 1 file changed, 21 insertions(+), 9 deletions(-)

(limited to 'src/Contact.hs')

diff --git a/src/Contact.hs b/src/Contact.hs
index 73a179f..f7cd3d3 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -2,6 +2,9 @@ module Contact (
     Contact(..),
     contactView,
 
+    Contacts,
+    toContactList,
+
     ContactService,
     contactRequest,
     contactAccept,
@@ -38,6 +41,11 @@ data ContactData = ContactData
     , cdName :: Maybe Text
     }
 
+data Contacts = Contacts [Stored ContactData] [Contact]
+
+toContactList :: Contacts -> [Contact]
+toContactList (Contacts _ list) = list
+
 instance Storable ContactData where
     store' x = storeRec $ do
         mapM_ (storeRef "PREV") $ cdPrev x
@@ -49,7 +57,12 @@ instance Storable ContactData where
         <*> loadRefs "identity"
         <*> loadMbText "name"
 
-instance SharedType ContactData where
+instance Mergeable Contacts where
+    type Component Contacts = ContactData
+    mergeSorted cdata = Contacts cdata $ contactView cdata
+    toComponents (Contacts cdata _) = cdata
+
+instance SharedType Contacts where
     sharedTypeID _ = mkSharedTypeID "34fbb61e-6022-405f-b1b3-a5a1abecd25e"
 
 contactView :: [Stored ContactData] -> [Contact]
@@ -91,11 +104,11 @@ instance PairingResult ContactAccepted where
 
     pairingFinalizeRequest ContactAccepted = do
         pid <- asks svcPeerIdentity
-        updateLocalState_ $ finalizeContact pid
+        finalizeContact pid
 
     pairingFinalizeResponse = do
         pid <- asks svcPeerIdentity
-        updateLocalState_ $ finalizeContact pid
+        finalizeContact pid
         return ContactAccepted
 
     defaultPairingAttributes _ = PairingAttributes
@@ -145,13 +158,12 @@ contactAccept = pairingAccept @ContactAccepted Proxy
 contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()
 contactReject = pairingReject @ContactAccepted Proxy
 
-finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState)
-finalizeContact identity slocal = liftIO $ do
-    let st = storedStorage slocal
+finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m ()
+finalizeContact identity = updateSharedState_ $ \(Contacts prev _) -> do
+    let st = storedStorage $ idData identity
     contact <- wrappedStore st ContactData
-            { cdPrev = lookupSharedValue $ lsShared $ fromStored slocal
+            { cdPrev = prev
             , cdIdentity = idDataF $ finalOwner identity
             , cdName = Nothing
             }
-    shared <- makeSharedStateUpdate st [contact] (lsShared $ fromStored slocal)
-    wrappedStore st (fromStored slocal) { lsShared = [shared] }
+    return $ Contacts [contact] (contactView [contact])
-- 
cgit v1.2.3