From b8e55c64a68763b0953945476cc75206f5354023 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 17 May 2022 22:06:01 +0200 Subject: Mergeable class with separate component type --- src/Attach.hs | 2 +- src/Contact.hs | 30 +++++++++++++++++++++--------- src/Identity.hs | 9 +++++++-- src/Main.hs | 4 ++-- src/Message.hs | 24 +++++++++++++++++++----- src/State.hs | 32 +++++++++++++++----------------- src/Storage/List.hs | 7 ++----- src/Storage/Merge.hs | 13 +++++++------ src/Test.hs | 13 ++++++------- 9 files changed, 80 insertions(+), 54 deletions(-) diff --git a/src/Attach.hs b/src/Attach.hs index 90c9900..c27b383 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -58,7 +58,7 @@ instance PairingResult AttachIdentity where pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ] mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ] - shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal) + shared <- makeSharedStateUpdate st (Just owner) (lsShared $ fromStored slocal) wrappedStore st (fromStored slocal) { lsIdentity = idData identity , lsShared = [ shared ] diff --git a/src/Contact.hs b/src/Contact.hs index 73a179f..f7cd3d3 100644 --- a/src/Contact.hs +++ b/src/Contact.hs @@ -2,6 +2,9 @@ module Contact ( Contact(..), contactView, + Contacts, + toContactList, + ContactService, contactRequest, contactAccept, @@ -38,6 +41,11 @@ 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 @@ -49,7 +57,12 @@ instance Storable ContactData where <*> loadRefs "identity" <*> loadMbText "name" -instance SharedType ContactData where +instance Mergeable Contacts where + type Component Contacts = ContactData + mergeSorted cdata = Contacts cdata $ contactView cdata + toComponents (Contacts cdata _) = cdata + +instance SharedType Contacts where sharedTypeID _ = mkSharedTypeID "34fbb61e-6022-405f-b1b3-a5a1abecd25e" contactView :: [Stored ContactData] -> [Contact] @@ -91,11 +104,11 @@ instance PairingResult ContactAccepted where pairingFinalizeRequest ContactAccepted = do pid <- asks svcPeerIdentity - updateLocalState_ $ finalizeContact pid + finalizeContact pid pairingFinalizeResponse = do pid <- asks svcPeerIdentity - updateLocalState_ $ finalizeContact pid + finalizeContact pid return ContactAccepted defaultPairingAttributes _ = PairingAttributes @@ -145,13 +158,12 @@ contactAccept = pairingAccept @ContactAccepted Proxy contactReject :: (MonadIO m, MonadError String m) => Peer -> m () contactReject = pairingReject @ContactAccepted Proxy -finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState) -finalizeContact identity slocal = liftIO $ do - let st = storedStorage slocal +finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m () +finalizeContact identity = updateSharedState_ $ \(Contacts prev _) -> do + let st = storedStorage $ idData identity contact <- wrappedStore st ContactData - { cdPrev = lookupSharedValue $ lsShared $ fromStored slocal + { cdPrev = prev , cdIdentity = idDataF $ finalOwner identity , cdName = Nothing } - shared <- makeSharedStateUpdate st [contact] (lsShared $ fromStored slocal) - wrappedStore st (fromStored slocal) { lsShared = [shared] } + return $ Contacts [contact] (contactView [contact]) diff --git a/src/Identity.hs b/src/Identity.hs index b81228f..834e5ee 100644 --- a/src/Identity.hs +++ b/src/Identity.hs @@ -52,8 +52,8 @@ deriving instance Show (m (Stored (Signed IdentityData))) => Show (Identity m) type ComposedIdentity = Identity [] type UnifiedIdentity = Identity I.Identity -instance Eq UnifiedIdentity where - (==) = (==) `on` (idData &&& idUpdates) +instance Eq (m (Stored (Signed IdentityData))) => Eq (Identity m) where + (==) = (==) `on` (idData_ &&& idUpdates_) data IdentityData = IdentityData { iddPrev :: [Stored (Signed IdentityData)] @@ -79,6 +79,11 @@ instance Storable IdentityData where <*> loadRef "key-id" <*> loadMbRef "key-msg" +instance Mergeable (Maybe ComposedIdentity) where + type Component (Maybe ComposedIdentity) = Signed IdentityData + mergeSorted = validateIdentityF + toComponents = maybe [] idDataF + idData :: UnifiedIdentity -> Stored (Signed IdentityData) idData = I.runIdentity . idDataF diff --git a/src/Main.hs b/src/Main.hs index 7fb6ff3..d764fe0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -286,7 +286,7 @@ cmdHistory = void $ do let powner = finalOwner pid case find (sameIdentity powner . msgPeer) $ - messageThreadView $ lookupSharedValue $ lsShared $ headObject ehead of + toThreadList $ lookupSharedValue $ lsShared $ headObject ehead of Just thread -> do tzone <- liftIO $ getCurrentTimeZone liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread @@ -313,7 +313,7 @@ cmdContacts :: Command cmdContacts = do args <- words <$> asks ciLine ehead <- asks ciHead - let contacts = contactView $ lookupSharedValue $ lsShared $ headObject ehead + let contacts = toContactList $ 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) ++ diff --git a/src/Message.hs b/src/Message.hs index 1dadc29..46d75f1 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -2,6 +2,9 @@ module Message ( DirectMessage(..), sendDirectMessage, + DirectMessageThreads, + toThreadList, + DirectMessageThread(..), threadToList, messageThreadView, @@ -56,7 +59,7 @@ instance Service DirectMessage where tzone <- liftIO $ getCurrentTimeZone erb <- svcGetLocal let st = storedStorage erb - prev = lookupSharedValue $ lsShared $ fromStored erb + DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb sent = findMsgProperty powner msSent prev received = findMsgProperty powner msReceived prev if powner `sameIdentity` msgFrom msg || @@ -70,7 +73,8 @@ instance Service DirectMessage where , msReceived = filterAncestors $ smsg : received , msSeen = [] } - shared <- makeSharedStateUpdate st [next] (lsShared $ fromStored erb) + let threads = DirectMessageThreads [next] (messageThreadView [next]) + shared <- makeSharedStateUpdate st threads (lsShared $ fromStored erb) wrappedStore st (fromStored erb) { lsShared = [shared] } svcSetLocal erb' when (powner `sameIdentity` msgFrom msg) $ do @@ -88,6 +92,11 @@ data MessageState = MessageState , msSeen :: [Stored DirectMessage] } +data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread] + +toThreadList :: DirectMessageThreads -> [DirectMessageThread] +toThreadList (DirectMessageThreads _ threads) = threads + instance Storable MessageState where store' ms = storeRec $ do mapM_ (storeRef "PREV") $ msPrev ms @@ -103,7 +112,12 @@ instance Storable MessageState where <*> loadRefs "received" <*> loadRefs "seen" -instance SharedType MessageState where +instance Mergeable DirectMessageThreads where + type Component DirectMessageThreads = MessageState + mergeSorted mss = DirectMessageThreads mss (messageThreadView mss) + toComponents (DirectMessageThreads mss _) = mss + +instance SharedType DirectMessageThreads where sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade" findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] @@ -121,7 +135,7 @@ sendDirectMessage h peer text = do self = headLocalIdentity h powner = finalOwner pid - smsg <- flip runReaderT h $ updateSharedState $ \prev -> do + smsg <- flip runReaderT h $ updateSharedState $ \(DirectMessageThreads prev _) -> do let sent = findMsgProperty powner msSent prev received = findMsgProperty powner msReceived prev @@ -139,7 +153,7 @@ sendDirectMessage h peer text = do , msReceived = [] , msSeen = [] } - return ([next], smsg) + return (DirectMessageThreads [next] (messageThreadView [next]), smsg) sendToPeerStored peer smsg return smsg diff --git a/src/State.hs b/src/State.hs index a715f8a..358d958 100644 --- a/src/State.hs +++ b/src/State.hs @@ -51,7 +51,7 @@ newtype SharedTypeID = SharedTypeID UUID mkSharedTypeID :: String -> SharedTypeID mkSharedTypeID = maybe (error "Invalid shared type ID") SharedTypeID . U.fromString -class Storable a => SharedType a where +class Mergeable a => SharedType a where sharedTypeID :: proxy a -> SharedTypeID instance Storable LocalState where @@ -77,7 +77,7 @@ instance Storable SharedState where <*> loadMbUUID "type" <*> loadRawRefs "value" -instance SharedType (Signed IdentityData) where +instance SharedType (Maybe ComposedIdentity) where sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871" @@ -110,7 +110,7 @@ loadLocalStateHead st = loadHeads st >>= \case shared <- wrappedStore st $ SharedState { ssPrev = [] - , ssType = Just $ sharedTypeID @(Signed IdentityData) Proxy + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy , ssValue = [storedRef $ idData $ fromMaybe identity owner] } storeHead st $ LocalState @@ -122,7 +122,7 @@ headLocalIdentity :: Head LocalState -> UnifiedIdentity headLocalIdentity h = let ls = headObject h in maybe (error "failed to verify local identity") - (updateOwners (lookupSharedValue $ lsShared ls)) + (updateOwners $ maybe [] idDataF $ lookupSharedValue $ lsShared ls) (validateIdentity $ lsIdentity ls) @@ -132,44 +132,42 @@ updateLocalState_ f = updateLocalState (fmap (,()) . f) updateLocalState :: MonadHead LocalState m => (Stored LocalState -> IO (Stored LocalState, a)) -> m a updateLocalState = updateLocalHead -updateSharedState_ :: (SharedType a, MonadHead LocalState m) => ([Stored a] -> IO ([Stored a])) -> m () +updateSharedState_ :: (SharedType a, MonadHead LocalState m) => (a -> IO a) -> m () updateSharedState_ f = updateSharedState (fmap (,()) . f) -updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => ([Stored a] -> IO ([Stored a], b)) -> m b +updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> IO (a, b)) -> m b updateSharedState f = updateLocalHead $ \ls -> do let shared = lsShared $ fromStored ls val = lookupSharedValue shared st = storedStorage ls (val', x) <- f val - (,x) <$> if val' == val + (,x) <$> if toComponents val' == toComponents val then return ls else do shared' <- makeSharedStateUpdate st val' shared wrappedStore st (fromStored ls) { lsShared = [shared'] } -lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> [Stored a] -lookupSharedValue = map wrappedLoad . concatMap (ssValue . fromStored) . filterAncestors . helper +lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> a +lookupSharedValue = mergeSorted . filterAncestors . map wrappedLoad . concatMap (ssValue . fromStored) . filterAncestors . helper where helper (x:xs) | Just sid <- ssType (fromStored x), sid == sharedTypeID @a Proxy = x : helper xs | otherwise = helper $ ssPrev (fromStored x) ++ xs helper [] = [] -makeSharedStateUpdate :: forall a. SharedType a => Storage -> [Stored a] -> [Stored SharedState] -> IO (Stored SharedState) +makeSharedStateUpdate :: forall a. SharedType a => Storage -> a -> [Stored SharedState] -> IO (Stored SharedState) makeSharedStateUpdate st val prev = wrappedStore st SharedState { ssPrev = prev , ssType = Just $ sharedTypeID @a Proxy - , ssValue = storedRef <$> val + , ssValue = storedRef <$> toComponents val } mergeSharedIdentity :: MonadHead LocalState m => m UnifiedIdentity -mergeSharedIdentity = updateSharedState $ \sdata -> do - let Just cidentity = validateIdentityF sdata +mergeSharedIdentity = updateSharedState $ \(Just cidentity) -> do identity <- mergeIdentity cidentity - return ([idData identity], identity) + return (Just $ toComposedIdentity identity, identity) updateSharedIdentity :: MonadHead LocalState m => m () -updateSharedIdentity = updateSharedState_ $ \sdata -> do - let Just identity = validateIdentityF sdata - (:[]) . idData <$> interactiveIdentityUpdate identity +updateSharedIdentity = updateSharedState_ $ \(Just identity) -> do + Just . toComposedIdentity <$> interactiveIdentityUpdate identity interactiveIdentityUpdate :: Foldable m => Identity m -> IO UnifiedIdentity interactiveIdentityUpdate identity = do diff --git a/src/Storage/List.hs b/src/Storage/List.hs index e112b46..2bef401 100644 --- a/src/Storage/List.hs +++ b/src/Storage/List.hs @@ -44,9 +44,6 @@ instance Storable a => Storable (List a) where instance Storable a => ZeroStorable (List a) where fromZero _ = ListNil -instance Storable a => Mergeable (List a) where - mergeSorted xs = ListItem xs Nothing Nothing - emptySList :: Storable a => Storage -> IO (StoredList a) emptySList st = wrappedStore st ListNil @@ -78,10 +75,10 @@ groupsFromSLists = helperSelect S.empty . (:[]) filterRemoved :: S.Set (StoredList a) -> [StoredList a] -> [StoredList a] filterRemoved rs = filter (S.null . S.intersection rs . ancestors . (:[])) -fromSList :: Mergeable a => StoredList a -> [a] +fromSList :: Mergeable a => StoredList (Component a) -> [a] fromSList = map merge . groupsFromSLists -storedFromSList :: Mergeable a => StoredList a -> IO [Stored a] +storedFromSList :: (Mergeable a, Storable a) => StoredList (Component a) -> IO [Stored a] storedFromSList = mapM storeMerge . groupsFromSLists slistAdd :: Storable a => a -> StoredList a -> IO (StoredList a) diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs index a6ed3ba..6353dad 100644 --- a/src/Storage/Merge.hs +++ b/src/Storage/Merge.hs @@ -18,6 +18,7 @@ import Control.Concurrent.MVar import qualified Data.ByteString.Char8 as BC import qualified Data.HashTable.IO as HT +import Data.Kind import Data.List import Data.Maybe import Data.Set (Set) @@ -29,17 +30,17 @@ import Storage import Storage.Internal import Util -class Storable a => Mergeable a where - mergeSorted :: [Stored a] -> a +class Storable (Component a) => Mergeable a where + type Component a :: Type + mergeSorted :: [Stored (Component a)] -> a + toComponents :: a -> [Stored (Component a)] -merge :: Mergeable a => [Stored a] -> a +merge :: Mergeable a => [Stored (Component a)] -> a merge [] = error "merge: empty list" -merge [x] = fromStored x merge xs = mergeSorted $ filterAncestors xs -storeMerge :: Mergeable a => [Stored a] -> IO (Stored a) +storeMerge :: (Mergeable a, Storable a) => [Stored (Component a)] -> IO (Stored a) storeMerge [] = error "merge: empty list" -storeMerge [x] = return x storeMerge xs@(Stored ref _ : _) = wrappedStore (refStorage ref) $ mergeSorted $ filterAncestors xs previous :: Storable a => Stored a -> [Stored a] diff --git a/src/Test.hs b/src/Test.hs index 8155bdb..455eed5 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -181,7 +181,7 @@ cmdCreateIdentity = do else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names shared <- case names of - _:_:_ -> (:[]) <$> makeSharedStateUpdate st (idDataF $ finalOwner identity) [] + _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) [] _ -> return [] storeHead st $ LocalState @@ -239,8 +239,8 @@ cmdWatchSharedIdentity = do Nothing <- gets tsWatchedSharedIdentity out <- asks tiOutput - w <- liftIO $ watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \sdata -> case validateIdentityF sdata of - Just idt -> do + w <- liftIO $ watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \case + Just (idt :: ComposedIdentity) -> do outLine out $ unwords $ "shared-identity" : map (maybe "" T.unpack . idName) (unfoldOwners idt) Nothing -> do outLine out $ "shared-identity-failed" @@ -265,13 +265,12 @@ cmdUpdateLocalIdentity = do cmdUpdateSharedIdentity :: Command cmdUpdateSharedIdentity = do [name] <- asks tiParams - updateSharedState_ $ \sdata -> do - let Just identity = validateIdentityF sdata - st = storedStorage $ head sdata + updateSharedState_ $ \(Just identity) -> do + let st = storedStorage $ head $ idDataF identity public = idKeyIdentity identity Just secret <- loadKey public - maybe (error "created invalid identity") (return . (:[]) . idData) . validateIdentity =<< + maybe (error "created invalid identity") (return . Just . toComposedIdentity) . validateIdentity =<< wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public) { iddPrev = toList $ idDataF identity , iddName = Just name -- cgit v1.2.3