summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Contact.hs12
-rw-r--r--src/Test.hs15
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"