From 26c03fae3e49057ac18462c5d1f48b9b221e1dcc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 8 Jan 2023 23:05:43 +0100 Subject: Contact custom name setting support and test --- src/Test.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) (limited to 'src/Test.hs') 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" -- cgit v1.2.3