summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Contact.hs79
-rw-r--r--src/Main.hs11
-rw-r--r--src/Storage/Merge.hs13
-rw-r--r--src/Test.hs34
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 21:05:28 +0000