Contacts using Set sructure

4 files changed, 88 insertions, 49 deletions

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
diff --git a/src/Main.hs b/src/Main.hs
index d764fe0..295a486 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,6 +15,7 @@ import qualified Data.ByteString.Lazy as BL
 import Data.Char
 import Data.List
 import Data.Maybe
+import Data.Ord
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Time.LocalTime
@@ -35,6 +36,7 @@ import Message
 import Network
 import PubKey
 import Service
+import Set
 import State
 import Storage
 import Storage.Merge
@@ -313,11 +315,14 @@ cmdContacts :: Command
 cmdContacts = do
     args <- words <$> asks ciLine
     ehead <- asks ciHead
-    let contacts = toContactList $ lookupSharedValue $ lsShared $ headObject ehead
+    let contacts = fromSetBy (comparing contactName) $ lookupSharedValue $ lsShared $ headObject ehead
         verbose = "-v" `elem` args
     forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do
-        liftIO $ putStrLn $ show i ++ ": " ++ T.unpack (displayIdentity $ contactIdentity c) ++
-            (if verbose then " " ++ (unwords $ map (BC.unpack . showRef . storedRef) $ idDataF $ contactIdentity c) else "")
+        liftIO $ putStrLn $ concat
+            [ show i, ": ", T.unpack $ contactName c
+            , case contactIdentity c of Nothing -> ""; Just idt -> " (" ++ T.unpack (displayIdentity idt) ++ ")"
+            , if verbose then " " ++ (unwords $ map (BC.unpack . showRef . storedRef) $ maybe [] idDataF $ contactIdentity c) else ""
+            ]
 
 cmdContactAdd :: Command
 cmdContactAdd = join $ contactRequest
diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs
index 82737ef..c28d290 100644
--- a/src/Storage/Merge.hs
+++ b/src/Storage/Merge.hs
@@ -14,6 +14,7 @@ module Storage.Merge (
     walkAncestors,
 
     findProperty,
+    findPropertyFirst,
 ) where
 
 import Control.Concurrent.MVar
@@ -141,7 +142,11 @@ walkAncestors f = helper . sortBy cmp
                    _ -> compare x y
 
 findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b]
-findProperty sel = map (fromJust . sel . fromStored) . filterAncestors . (findPropHeads =<<)
-    where findPropHeads :: Stored a -> [Stored a]
-          findPropHeads sobj | Just _ <- sel $ fromStored sobj = [sobj]
-                             | otherwise = findPropHeads =<< previous sobj
+findProperty sel = map (fromJust . sel . fromStored) . filterAncestors . (findPropHeads sel =<<)
+
+findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> Maybe b
+findPropertyFirst sel = fmap (fromJust . sel . fromStored) . listToMaybe . filterAncestors . (findPropHeads sel =<<)
+
+findPropHeads :: forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
+findPropHeads sel sobj | Just _ <- sel $ fromStored sobj = [sobj]
+                       | otherwise = findPropHeads sel =<< previous sobj
diff --git a/src/Test.hs b/src/Test.hs
index 8bd34ea..c106285 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -15,6 +15,7 @@ import Data.ByteString.Char8 qualified as BC
 import Data.ByteString.Lazy qualified as BL
 import Data.Foldable
 import Data.IP (fromSockAddr)
+import Data.Ord
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Encoding
@@ -25,6 +26,7 @@ import System.IO
 import System.IO.Error
 
 import Attach
+import Contact
 import Identity
 import Network
 import Pairing
@@ -194,6 +196,10 @@ commands = map (T.pack *** id)
     , ("attach-to", cmdAttachTo)
     , ("attach-accept", cmdAttachAccept)
     , ("attach-reject", cmdAttachReject)
+    , ("contact-request", cmdContactRequest)
+    , ("contact-accept", cmdContactAccept)
+    , ("contact-reject", cmdContactReject)
+    , ("contact-list", cmdContactList)
     ]
 
 cmdStore :: Command
@@ -262,6 +268,7 @@ cmdStartServer = do
     peers <- liftIO $ newMVar (1, [])
     server <- liftIO $ startServer defaultServerOptions h (hPutStrLn stderr)
         [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out peers "attach"
+        , someServiceAttr $ pairingAttributes (Proxy @ContactService) out peers "contact"
         , someService @SyncService Proxy
         ]
 
@@ -353,3 +360,30 @@ cmdAttachReject :: Command
 cmdAttachReject = do
     [spidx] <- asks tiParams
     attachReject =<< getPeer spidx
+
+cmdContactRequest :: Command
+cmdContactRequest = do
+    [spidx] <- asks tiParams
+    contactRequest =<< getPeer spidx
+
+cmdContactAccept :: Command
+cmdContactAccept = do
+    [spidx] <- asks tiParams
+    contactAccept =<< getPeer spidx
+
+cmdContactReject :: Command
+cmdContactReject = do
+    [spidx] <- asks tiParams
+    contactReject =<< getPeer spidx
+
+cmdContactList :: Command
+cmdContactList = do
+    h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") (liftIO . reloadHead) =<< gets tsHead
+    let contacts = fromSetBy (comparing contactName) . lookupSharedValue . lsShared . headObject $ h
+    forM_ contacts $ \c -> do
+        cmdOut $ concat
+            [ "contact-list-item "
+            , T.unpack $ contactName c
+            , case contactIdentity c of Nothing -> ""; Just idt -> " " ++ T.unpack (displayIdentity idt)
+            ]
+    cmdOut "contact-list-done"