Contact custom name setting support and test

2 files changed, 27 insertions, 0 deletions

diff --git a/src/Contact.hs b/src/Contact.hs
index 4e2cb17..6585985 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -4,6 +4,8 @@ module Contact (
     contactCustomName,
     contactName,
 
+    contactSetName,
+
     ContactService,
     contactRequest,
     contactAccept,
@@ -79,6 +81,16 @@ contactName c = fromJust $ msum
     , Just T.empty
     ]
 
+contactSetName :: MonadHead LocalState m => Contact -> Text -> Set Contact -> m (Set Contact)
+contactSetName contact name set = do
+    st <- getStorage
+    cdata <- wrappedStore st ContactData
+        { cdPrev = toComponents contact
+        , cdIdentity = []
+        , cdName = Just name
+        }
+    storeSetAdd st (mergeSorted @Contact [cdata]) set
+
 
 type ContactService = PairingService ContactAccepted
 
diff --git a/src/Test.hs b/src/Test.hs
index 694f16d..8ea8925 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -224,6 +224,7 @@ commands = map (T.pack *** id)
     , ("contact-accept", cmdContactAccept)
     , ("contact-reject", cmdContactReject)
     , ("contact-list", cmdContactList)
+    , ("contact-set-name", cmdContactSetName)
     ]
 
 cmdStore :: Command
@@ -435,9 +436,23 @@ cmdContactList = do
     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
+        r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents c
         cmdOut $ concat
             [ "contact-list-item "
+            , show $ refDigest $ storedRef r
+            , " "
             , T.unpack $ contactName c
             , case contactIdentity c of Nothing -> ""; Just idt -> " " ++ T.unpack (displayIdentity idt)
             ]
     cmdOut "contact-list-done"
+
+cmdContactSetName :: Command
+cmdContactSetName = do
+    [cid, name] <- asks tiParams
+    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
+    [contact] <- flip filterM contacts $ \c -> do
+        r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents c
+        return $ T.pack (show $ refDigest $ storedRef r) == cid
+    updateSharedState_ $ contactSetName contact name
+    cmdOut "contact-set-name-done"