From 97427b2f49daa9d86661ad999d4da17ac7a4acb4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 17 Jul 2022 22:29:22 +0200
Subject: Contacts using Set sructure

---
 src/Contact.hs | 79 +++++++++++++++++++++++++++-------------------------------
 1 file changed, 37 insertions(+), 42 deletions(-)

(limited to 'src/Contact.hs')

diff --git a/src/Contact.hs b/src/Contact.hs
index f7cd3d3..70e79b9 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -1,9 +1,8 @@
 module Contact (
-    Contact(..),
-    contactView,
-
-    Contacts,
-    toContactList,
+    Contact,
+    contactIdentity,
+    contactCustomName,
+    contactName,
 
     ContactService,
     contactRequest,
@@ -11,7 +10,6 @@ module Contact (
     contactReject,
 ) where
 
-import Control.Arrow
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -26,13 +24,15 @@ import Network
 import Pairing
 import PubKey
 import Service
+import Set
 import State
 import Storage
 import Storage.Merge
 
 data Contact = Contact
-    { contactIdentity :: ComposedIdentity
-    , contactName :: Maybe Text
+    { contactData :: [Stored ContactData]
+    , contactIdentity_ :: Maybe ComposedIdentity
+    , contactCustomName_ :: Maybe Text
     }
 
 data ContactData = ContactData
@@ -41,11 +41,6 @@ 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
@@ -57,33 +52,32 @@ instance Storable ContactData where
         <*> loadRefs "identity"
         <*> loadMbText "name"
 
-instance Mergeable Contacts where
-    type Component Contacts = ContactData
-    mergeSorted cdata = Contacts cdata $ contactView cdata
-    toComponents (Contacts cdata _) = cdata
+instance Mergeable Contact where
+    type Component Contact = ContactData
+
+    mergeSorted cdata = Contact
+        { contactData = cdata
+        , contactIdentity_ = validateIdentityF $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . cdIdentity) cdata
+        , contactCustomName_ = findPropertyFirst cdName cdata
+        }
+
+    toComponents = contactData
 
-instance SharedType Contacts where
+instance SharedType (Set Contact) where
     sharedTypeID _ = mkSharedTypeID "34fbb61e-6022-405f-b1b3-a5a1abecd25e"
 
-contactView :: [Stored ContactData] -> [Contact]
-contactView = helper []
-    where helper used = filterAncestors >>> \case
-              x:xs | Just cid <- validateIdentityF (cdIdentity (fromStored x))
-                   , not $ any (sameIdentity cid) used
-                   -> Contact { contactIdentity = cid
-                              , contactName = lookupProperty cid cdName (x:xs)
-                              } : helper (cid:used) (cdPrev (fromStored x) ++ xs)
-                   | otherwise -> helper used (cdPrev (fromStored x) ++ xs)
-              [] -> []
-
-lookupProperty :: forall a. ComposedIdentity -> (ContactData -> Maybe a) -> [Stored ContactData] -> Maybe a
-lookupProperty idt sel = join . fmap (sel . fromStored) . listToMaybe . filterAncestors . helper
-    where helper (x:xs) | Just cid <- validateIdentityF (cdIdentity (fromStored x))
-                        , cid `sameIdentity` idt
-                        , Just _ <- sel $ fromStored x
-                        = x : helper xs
-                        | otherwise = helper $ cdPrev (fromStored x) ++ xs
-          helper [] = []
+contactIdentity :: Contact -> Maybe ComposedIdentity
+contactIdentity = contactIdentity_
+
+contactCustomName :: Contact -> Maybe Text
+contactCustomName = contactCustomName_
+
+contactName :: Contact -> Text
+contactName c = fromJust $ msum
+    [ contactCustomName c
+    , idName =<< contactIdentity c
+    , Just T.empty
+    ]
 
 
 type ContactService = PairingService ContactAccepted
@@ -159,11 +153,12 @@ contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()
 contactReject = pairingReject @ContactAccepted Proxy
 
 finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m ()
-finalizeContact identity = updateSharedState_ $ \(Contacts prev _) -> do
-    let st = storedStorage $ idData identity
-    contact <- wrappedStore st ContactData
-            { cdPrev = prev
+finalizeContact identity = do
+    st <- getStorage
+    updateSharedState_ $ \contacts -> do
+        cdata <- wrappedStore st ContactData
+            { cdPrev = []
             , cdIdentity = idDataF $ finalOwner identity
             , cdName = Nothing
             }
-    return $ Contacts [contact] (contactView [contact])
+        storeSetAdd st (mergeSorted @Contact [cdata]) contacts
-- 
cgit v1.2.3