From 5736b214b44bf34b3d2c0d6921c5044a6ad4378b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 29 Oct 2024 20:19:46 +0100 Subject: Chatroom-specific identity Changelog: Chatroom-specific identity --- src/Erebos/Chatroom.hs | 37 +++++++++++++++++++++++++++++++------ src/Erebos/Identity.hs | 8 +++++++- 2 files changed, 38 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index 5ba137f..8833450 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -13,6 +13,7 @@ module Erebos.Chatroom ( chatroomSetSubscribe, chatroomMembers, joinChatroom, joinChatroomByStateData, + joinChatroomAs, joinChatroomAsByStateData, leaveChatroom, leaveChatroomByStateData, getMessagesSinceState, @@ -185,15 +186,18 @@ sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStat sendChatroomMessageByStateData :: (MonadStorage m, MonadHead LocalState m, MonadError String m) => Stored ChatroomStateData -> Text -> m () -sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing (Just msg) False +sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False sendRawChatroomMessageByStateData :: (MonadStorage m, MonadHead LocalState m, MonadError String m) - => Stored ChatroomStateData -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m () -sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do + => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m () +sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate Just $ do - mdFrom <- finalOwner . localIdentity . fromStored <$> getLocalHead + mdFrom <- finalOwner <$> if + | Just identity <- mbIdentity -> return identity + | Just identity <- roomStateIdentity cstate -> return identity + | otherwise -> localIdentity . fromStored <$> getLocalHead secret <- loadKey $ idKeyMessage mdFrom mdTime <- liftIO getZonedTime let mdPrev = roomStateMessageData cstate @@ -206,6 +210,7 @@ sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ f { rsdPrev = roomStateData cstate , rsdRoom = [] , rsdSubscribe = Just (not mdLeave) + , rsdIdentity = mbIdentity , rsdMessages = [ mdata ] } @@ -214,6 +219,7 @@ data ChatroomStateData = ChatroomStateData { rsdPrev :: [Stored ChatroomStateData] , rsdRoom :: [Stored (Signed ChatroomData)] , rsdSubscribe :: Maybe Bool + , rsdIdentity :: Maybe UnifiedIdentity , rsdMessages :: [Stored (Signed ChatMessageData)] } @@ -222,6 +228,7 @@ data ChatroomState = ChatroomState , roomStateRoom :: Maybe Chatroom , roomStateMessageData :: [Stored (Signed ChatMessageData)] , roomStateSubscribe :: Bool + , roomStateIdentity :: Maybe UnifiedIdentity , roomStateMessages :: [ChatMessage] } @@ -230,12 +237,14 @@ instance Storable ChatroomStateData where forM_ rsdPrev $ storeRef "PREV" forM_ rsdRoom $ storeRef "room" forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1 + forM_ rsdIdentity $ storeRef "id" . idExtData forM_ rsdMessages $ storeRef "msg" load' = loadRec $ do rsdPrev <- loadRefs "PREV" rsdRoom <- loadRefs "room" rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe" + rsdIdentity <- loadMbUnifiedIdentity "id" rsdMessages <- loadRefs "msg" return ChatroomStateData {..} @@ -249,6 +258,7 @@ instance Mergeable ChatroomState where ChatroomStateData {..} | null rsdMessages -> Nothing | otherwise -> Just rsdMessages roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData + roomStateIdentity = findPropertyFirst rsdIdentity roomStateData roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData in ChatroomState {..} @@ -266,6 +276,7 @@ createChatroom rdName rdDescription = do { rsdPrev = [] , rsdRoom = [ rdata ] , rsdSubscribe = Just True + , rsdIdentity = Nothing , rsdMessages = [] } @@ -313,6 +324,7 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat { rsdPrev = roomStateData cstate , rsdRoom = [ rdata ] , rsdSubscribe = Just True + , rsdIdentity = Nothing , rsdMessages = [] } @@ -343,6 +355,7 @@ chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ { rsdPrev = roomStateData cstate , rsdRoom = [] , rsdSubscribe = Just subscribe + , rsdIdentity = Nothing , rsdMessages = [] } @@ -364,7 +377,17 @@ joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate) joinChatroomByStateData :: (MonadStorage m, MonadHead LocalState m, MonadError String m) => Stored ChatroomStateData -> m () -joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing False +joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False + +joinChatroomAs + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => UnifiedIdentity -> ChatroomState -> m () +joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate) + +joinChatroomAsByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => UnifiedIdentity -> Stored ChatroomStateData -> m () +joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False leaveChatroom :: (MonadStorage m, MonadHead LocalState m, MonadError String m) @@ -374,7 +397,7 @@ leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate) leaveChatroomByStateData :: (MonadStorage m, MonadHead LocalState m, MonadError String m) => Stored ChatroomStateData -> m () -leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing True +leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur) @@ -498,6 +521,7 @@ instance Service ChatroomService where { rsdPrev = prev , rsdRoom = room , rsdSubscribe = Nothing + , rsdIdentity = Nothing , rsdMessages = [] } storeSetAddComponent sdata set @@ -542,6 +566,7 @@ instance Service ChatroomService where { rsdPrev = prevData , rsdRoom = [] , rsdSubscribe = Nothing + , rsdIdentity = Nothing , rsdMessages = messages } storeSetAddComponent sdata set diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs index f2094f6..577e5ac 100644 --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -13,7 +13,7 @@ module Erebos.Identity ( createIdentity, validateIdentity, validateIdentityF, validateIdentityFE, validateExtendedIdentity, validateExtendedIdentityF, validateExtendedIdentityFE, - loadIdentity, loadUnifiedIdentity, + loadIdentity, loadMbIdentity, loadUnifiedIdentity, loadMbUnifiedIdentity, mergeIdentity, toUnifiedIdentity, toComposedIdentity, updateIdentity, updateOwners, @@ -282,9 +282,15 @@ validateExtendedIdentityFE mdata = do loadIdentity :: String -> LoadRec ComposedIdentity loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name +loadMbIdentity :: String -> LoadRec (Maybe ComposedIdentity) +loadMbIdentity name = return . validateExtendedIdentityF =<< loadRefs name + loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name +loadMbUnifiedIdentity :: String -> LoadRec (Maybe UnifiedIdentity) +loadMbUnifiedIdentity name = return . (validateExtendedIdentity =<<) =<< loadMbRef name + gatherPrevious :: Set (Stored (Signed ExtendedIdentityData)) -> [Stored (Signed ExtendedIdentityData)] -> Set (Stored (Signed ExtendedIdentityData)) gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns -- cgit v1.2.3