From 97427b2f49daa9d86661ad999d4da17ac7a4acb4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 17 Jul 2022 22:29:22 +0200 Subject: Contacts using Set sructure --- src/Contact.hs | 79 ++++++++++++++++++++++++---------------------------- src/Main.hs | 11 ++++++-- src/Storage/Merge.hs | 13 ++++++--- src/Test.hs | 34 ++++++++++++++++++++++ 4 files changed, 88 insertions(+), 49 deletions(-) (limited to 'src') 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" -- cgit v1.2.3