From 71bceec18ba9fae376f7b5b72c5b82b21e52aa06 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 16 Oct 2022 11:26:24 +0000 Subject: [PATCH] C2S, S2S: Re-enable createNoteC and personCreateNoteF --- .../504_2022-10-16_message_author.model | 44 +++ src/Vervis/API.hs | 242 ++++++-------- src/Vervis/Data/Actor.hs | 8 + src/Vervis/Data/Discussion.hs | 152 +++++++++ src/Vervis/Federation/Discussion.hs | 299 ++++-------------- src/Vervis/Foundation.hs | 8 + src/Vervis/Handler/Cloth.hs | 2 +- src/Vervis/Handler/Deck.hs | 5 + src/Vervis/Handler/Group.hs | 6 + src/Vervis/Handler/Loom.hs | 6 + src/Vervis/Handler/Person.hs | 84 +---- src/Vervis/Handler/Repo.hs | 6 + src/Vervis/Handler/Ticket.hs | 2 +- src/Vervis/Migration.hs | 25 ++ src/Vervis/Migration/Model.hs | 3 + src/Vervis/Persist/Actor.hs | 16 + src/Vervis/{ => Persist}/Discussion.hs | 192 ++++++----- src/Vervis/Web/Discussion.hs | 78 ++++- src/Vervis/Widget/Discussion.hs | 15 +- src/Web/ActivityPub.hs | 7 +- templates/discussion/widget/message.hamlet | 6 +- templates/widget/actor-link.hamlet | 10 +- th/models | 6 +- th/routes | 8 + vervis.cabal | 5 +- 25 files changed, 656 insertions(+), 579 deletions(-) create mode 100644 migrations/504_2022-10-16_message_author.model create mode 100644 src/Vervis/Data/Discussion.hs rename src/Vervis/{ => Persist}/Discussion.hs (59%) diff --git a/migrations/504_2022-10-16_message_author.model b/migrations/504_2022-10-16_message_author.model new file mode 100644 index 0000000..cea8562 --- /dev/null +++ b/migrations/504_2022-10-16_message_author.model @@ -0,0 +1,44 @@ +Message +OutboxItem +Inbox +Outbox +FollowerSet + +LocalMessage + author PersonId + authorNew ActorId + rest MessageId + create OutboxItemId + unlinkedParent FedURI Maybe + + UniqueLocalMessage rest + UniqueLocalMessageCreate create + +Person + username Username + login Text + passphraseHash ByteString + email EmailAddress + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + actor ActorId + + UniquePersonUsername username + UniquePersonLogin login + UniquePersonEmail email + UniquePersonActor actor + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 7665ed6..bebe6ea 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -21,7 +21,7 @@ module Vervis.API --, addBundleC , applyC --, noteC - --, createNoteC + , createNoteC , createPatchTrackerC , createRepositoryC , createTicketTrackerC @@ -101,8 +101,8 @@ import Vervis.Cloth import Vervis.Darcs import Vervis.Data.Actor import Vervis.Data.Collab +import Vervis.Data.Discussion import Vervis.Data.Ticket -import Vervis.Web.Delivery import Vervis.FedURI import Vervis.Fetch import Vervis.Foundation @@ -115,6 +115,7 @@ import Vervis.Model.Ticket import Vervis.Path import Vervis.Persist.Actor import Vervis.Persist.Collab +import Vervis.Persist.Discussion import Vervis.Persist.Ticket import Vervis.Recipient import Vervis.RemoteActorStore @@ -122,6 +123,7 @@ import Vervis.Settings import Vervis.Query import Vervis.Ticket import Vervis.WorkItem +import Vervis.Web.Delivery import Vervis.Web.Repo verifyResourceAddressed @@ -736,6 +738,7 @@ parseComment luParent = do <*> decodeKeyHashidE messageHash "Invalid local message hashid" _ -> throwE "Not a local message route" +{- noteC :: Entity Person -> Note URIMode @@ -756,140 +759,112 @@ noteC eperson@(Entity personID person) note = do \ commented. |] createNoteC eperson (Just summary) (noteAudience note) note Nothing +-} --- | Handle a Note submitted by a local user to their outbox. It can be either --- a comment on a local ticket, or a comment on some remote context. Return an --- error message if the Note is rejected, otherwise the new 'LocalMessageId'. createNoteC :: Entity Person - -> Maybe HTML - -> Audience URIMode + -> Actor + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode -> Note URIMode -> Maybe FedURI -> ExceptT Text Handler OutboxItemId -createNoteC (Entity pidUser personUser) summary audience note muTarget = do - error "Temporarily disabled" +createNoteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action note muTarget = do - {- - senderHash <- encodeKeyHashid pidUser - noteData@(muParent, mparent, uContext, context, source, content) <- checkNote senderHash note - verifyNothingE muTarget "Create Note has 'target'" - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Create Note with no recipients" - checkFederation remoteRecips - verifyContextRecip context localRecips remoteRecips - now <- liftIO getCurrentTime - (obiid, doc, remotesHttp) <- runDBExcept $ do - obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now - (discussionID, meparent) <- getTopicAndParent context mparent - lmid <- lift $ insertMessage now content source obiidCreate discussionID meparent - docCreate <- lift $ insertCreateToOutbox now senderHash blinded noteData obiidCreate lmid - remoteRecipsHttpCreate <- do - sieve <- do - hashDeck <- getEncodeHashid - hashTicket <- getEncodeHashid - hashLoom <- getEncodeHashid - hashCloth <- getEncodeHashid - let actors = - case context of - Right _ -> [] - Left (NoteTopicTicket did _) -> [LocalActorDeck $ hashDeck did] - Left (NoteTopicCloth lid _) -> [LocalActorLoom $ hashLoom lid] - stages = - let topic = - case context of - Right _ -> [] - Left (NoteTopicTicket did tdid) -> - let deckHash = hashDeck did - in [ LocalStageDeckFollowers deckHash - , LocalStageTicketFollowers deckHash (hashTicket tdid) - ] - Left (NoteTopicCloth lid dlid) -> - let loomHash = hashDeck lid - in [ LocalStageLoomFollowers loomHash - , LocalStageClothFollowers loomHash (hashCloth tlid) - ] - commenter = [LocalStagePersonFollowers senderHash] - in topic ++ commenter - return $ makeRecipientSet actors stages - moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personInbox personUser) obiidCreate $ - localRecipSieve' sieve True False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB fwdHosts obiidCreate remoteRecips moreRemoteRecips - return (obiidCreate, docCreate, remoteRecipsHttpCreate) - lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp - return obiid - where - checkNote authorHash (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do - verifyNothingE mluNote "Note specifies an id" - encodeRouteLocal <- getEncodeRouteLocal - unless (encodeRouteLocal (PersonR authorHash) == luAttrib) $ + -- Check input + verifyNothingE maybeCap "Capability not needed" + Comment maybeParent topic source content <- do + (authorPersonID, comment) <- parseNewLocalComment note + unless (authorPersonID == senderPersonID) $ throwE "Note attributed to someone else" - verifyNothingE mpublished "Note specifies published" - uContext <- fromMaybeE muContext "Note without context" - context <- parseNoteContext uContext - mparent <- checkParent context =<< traverse parseParent muParent - return (muParent, mparent, uContext, context, source, content) - where - checkParent _ Nothing = return Nothing - checkParent (Left topic) (Just (Left (NoteParentTopic topic'))) = - if topic == topic' - then return Nothing - else throwE "Note context and parent are different local topics" - checkParent _ (Just (Left (NoteParentMessage person message))) = return $ Just $ Left (person, message) - checkParent (Left _) (Just (Right u)) = return $ Just $ Right u - checkParent (Right u) (Just (Right u')) = - return $ - if u == u' - then Nothing - else Just $ Right u' - checkParent _ _ = - error "A situation I missed in pattern matching, fix it?" + return comment + verifyNothingE muTarget "'target' not supported in Create Note" - checkFederation remoteRecips = do - federation <- asksSite $ appFederation . appSettings - unless (federation || null remoteRecips) $ - throwE "Federation disabled, but remote recipients found" + senderHash <- encodeKeyHashid senderPersonID + now <- liftIO getCurrentTime - verifyContextRecip (Right (ObjURI h _)) _ remoteRecips = + -- If topic is local, verify that its managing actor is addressed + -- If topic is remote, verify recipient(s) of the same host exist + verifyTopicAddressed topic + + (createID, deliverHttpCreate) <- runDBExcept $ do + + -- If topic is local, find in DB; if remote, find or insert + -- If parent is local, find in DB; if remote, find or insert + (discussionID, meparent) <- getTopicAndParent topic maybeParent + + -- Insert comment to DB and nsert the Create activity to author's + -- outbox + createID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now + lmid <- lift $ insertMessage now content source createID discussionID meparent + actionCreate <- lift . lift $ prepareCreate now senderHash lmid + _luCreate <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) createID actionCreate + + -- Deliver the Create activity to local recipients, and schedule + -- delivery for unavailable remote recipients + deliverHttpCreate <- do + sieve <- do + maybeTopicAudience <- + case topic of + Left t -> + Just <$> + bitraverse hashLocalActor hashLocalStage + (commentTopicAudience t) + Right _ -> pure Nothing + let actors = maybeToList $ fst <$> maybeTopicAudience + stages = + LocalStagePersonFollowers senderHash : + case maybeTopicAudience of + Nothing -> [] + Just (actor, followers) -> + [localActorFollowers actor, followers] + return $ makeRecipientSet actors stages + let localRecipsFinal = + localRecipSieve' sieve True False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor senderPerson) + localRecipsFinal remoteRecips fwdHosts createID actionCreate + + -- Return instructions for HTTP delivery to remote recipients + return (createID, deliverHttpCreate) + + -- Launch asynchronous HTTP delivery + lift $ forkWorker "createNoteC: async HTTP delivery" deliverHttpCreate + return createID + + where + + verifyTopicAddressed (Right (ObjURI h _)) = unless (any ((== h) . fst) remoteRecips) $ - throwE - "Context is remote but no recipients of that host are listed" - verifyContextRecip (Left (NoteTopicTicket deckID _)) localRecips _ = do - deckHash <- encodeKeyHashid deckID - let verify = do - deckFamily <- lookup deckHash $ recipDecks localRecips - guard $ leafDeck $ familyDeck deckFamily - fromMaybeE - verify - "Local context ticket's hosting project isn't listed as a recipient" - verifyContextRecip (Left (NoteTopicCloth loomID _)) localRecips _ = do - loomHash <- encodeKeyHashid loomID - let verify = do - loomFamily <- lookup loomHash $ recipLooms localRecips - guard $ leafLoom $ familyLoom loomFamily - fromMaybeE - verify - "Local context patch's hosting loom isn't listed as a recipient" + throwE "Topic is remote but no recipients of that host are listed" + verifyTopicAddressed (Left topic) = do + actorByHash <- hashLocalActor $ commentTopicManagingActor topic + unless (actorIsAddressed localRecips actorByHash) $ + throwE "Local topic's managing actor isn't listed as a recipient" getTopicAndParent (Left context) mparent = do discussionID <- case context of - NoteTopicTicket deckID ticketID -> do + CommentTopicTicket deckID ticketID -> do (_, _, Entity _ t, _, _) <- do mticket <- lift $ getTicket deckID ticketID fromMaybeE mticket "Note context no such local deck-hosted ticket" return $ ticketDiscuss t - NoteTopicCloth loomID clothID -> do + CommentTopicCloth loomID clothID -> do (_, _, Entity _ t, _, _, _) <- do mcloth <- lift $ getCloth loomID clothID fromMaybeE mcloth "Note context no such local loom-hosted ticket" return $ ticketDiscuss t mmidParent <- for mparent $ \ parent -> case parent of - Left (personID, messageID) -> getLocalParentMessageId discussionID personID messageID + Left msg -> getLocalParentMessageId discussionID msg Right (ObjURI hParent luParent) -> do mrm <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hParent @@ -918,9 +893,9 @@ createNoteC (Entity pidUser personUser) summary audience note muTarget = do let discussionID = remoteDiscussionDiscuss rd meparent <- for mparent $ \ parent -> case parent of - Left (personID, messageID) -> do + Left msg -> do when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new" - Left <$> getLocalParentMessageId discussionID personID messageID + Left <$> getLocalParentMessageId discussionID msg Right uParent@(ObjURI hParent luParent) -> do mrm <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hParent @@ -948,7 +923,7 @@ createNoteC (Entity pidUser personUser) summary audience note muTarget = do , messageRoot = did } insert LocalMessage - { localMessageAuthor = pidUser + { localMessageAuthor = personActor senderPerson , localMessageRest = mid , localMessageCreate = obiidCreate , localMessageUnlinkedParent = @@ -957,40 +932,17 @@ createNoteC (Entity pidUser personUser) summary audience note muTarget = do _ -> Nothing } - insertCreateToOutbox now senderHash blinded (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do + prepareCreate now senderHash messageID = do encodeRouteLocal <- getEncodeRouteLocal hLocal <- asksSite siteInstanceHost - obikhid <- encodeKeyHashid obiidCreate - lmkhid <- encodeKeyHashid lmid - let luAttrib = encodeRouteLocal $ PersonR senderHash - create = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid - , activityActor = luAttrib - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activitySpecific = CreateActivity Create - { createObject = CreateNote hLocal Note - { noteId = Just $ encodeRouteLocal $ MessageR senderHash lmkhid - , noteAttrib = luAttrib - , noteAudience = emptyAudience - , noteReplyTo = Just $ fromMaybe uContext muParent - , noteContext = Just uContext - , notePublished = Just now - , noteSource = source - , noteContent = content - } - , createTarget = Nothing - } + messageHash <- encodeKeyHashid messageID + let luId = encodeRouteLocal $ PersonMessageR senderHash messageHash + note' = note + { AP.noteId = Just luId + , AP.notePublished = Just now + , AP.noteAudience = emptyAudience } - update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] - return create --} - -checkFederation remoteRecips = do - federation <- asksSite $ appFederation . appSettings - unless (federation || null remoteRecips) $ - throwE "Federation disabled, but remote recipients found" + return action { AP.actionSpecific = AP.CreateActivity $ AP.Create (AP.CreateNote hLocal note') Nothing } createPatchTrackerC :: Entity Person diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index 826cd54..095daa4 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -19,11 +19,13 @@ module Vervis.Data.Actor , activityRoute , stampRoute , parseStampRoute + , localActorID ) where import Control.Monad.Trans.Except import Data.Text (Text) +import Database.Persist.Types import Network.FedURI import Yesod.ActivityPub @@ -96,3 +98,9 @@ parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i) parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i) parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i) parseStampRoute _ = Nothing + +localActorID (LocalActorPerson (Entity _ p)) = personActor p +localActorID (LocalActorGroup (Entity _ g)) = groupActor g +localActorID (LocalActorRepo (Entity _ r)) = repoActor r +localActorID (LocalActorDeck (Entity _ d)) = deckActor d +localActorID (LocalActorLoom (Entity _ l)) = loomActor l diff --git a/src/Vervis/Data/Discussion.hs b/src/Vervis/Data/Discussion.hs new file mode 100644 index 0000000..23b686b --- /dev/null +++ b/src/Vervis/Data/Discussion.hs @@ -0,0 +1,152 @@ +{- This file is part of Vervis. + - + - Written in 2016, 2019, 2020, 2022 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Data.Discussion + ( CommentTopic (..) + , commentTopicAudience + , commentTopicManagingActor + , Comment (..) + , parseNewLocalComment + , parseRemoteComment + , messageRoute + ) +where + +import Control.Monad.Trans.Except +import Data.Bitraversable +import Data.Text (Text) +import Data.Time.Clock + +import Network.FedURI +import Web.Text +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local + +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Recipient + +parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App) +parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route" + +parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI) +parseFedURI u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> parseLocalURI lu + else pure $ Right u + +parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key) +parseLocalActorE route = do + actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route" + unhashLocalActorE actorByHash "Invalid actor keyhashid" + +parseCommentId + :: Route App -> ExceptT Text Handler (LocalActorBy Key, LocalMessageId) +parseCommentId (PersonMessageR p m) = + (,) <$> (LocalActorPerson <$> decodeKeyHashidE p "Invalid actor keyhashid") + <*> decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentId (GroupMessageR g m) = + (,) <$> (LocalActorGroup <$> decodeKeyHashidE g "Invalid actor keyhashid") + <*> decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentId (RepoMessageR r m) = + (,) <$> (LocalActorRepo <$> decodeKeyHashidE r "Invalid actor keyhashid") + <*> decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentId (DeckMessageR d m) = + (,) <$> (LocalActorDeck <$> decodeKeyHashidE d "Invalid actor keyhashid") + <*> decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentId (LoomMessageR l m) = + (,) <$> (LocalActorLoom <$> decodeKeyHashidE l "Invalid actor keyhashid") + <*> decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentId _ = throwE "Not a message route" + +data CommentTopic + = CommentTopicTicket DeckId TicketDeckId + | CommentTopicCloth LoomId TicketLoomId + +commentTopicAudience :: CommentTopic -> (LocalActorBy Key, LocalStageBy Key) +commentTopicAudience (CommentTopicTicket deckID taskID) = + (LocalActorDeck deckID, LocalStageTicketFollowers deckID taskID) +commentTopicAudience (CommentTopicCloth loomID clothID) = + (LocalActorLoom loomID, LocalStageClothFollowers loomID clothID) + +commentTopicManagingActor :: CommentTopic -> LocalActorBy Key +commentTopicManagingActor = fst . commentTopicAudience + +parseCommentTopic :: Route App -> ExceptT Text Handler CommentTopic +parseCommentTopic (TicketR dkhid ltkhid) = + CommentTopicTicket + <$> decodeKeyHashidE dkhid "Invalid dkhid" + <*> decodeKeyHashidE ltkhid "Invalid ltkhid" +parseCommentTopic (ClothR lkhid ltkhid) = + CommentTopicCloth + <$> decodeKeyHashidE lkhid "Invalid lkhid" + <*> decodeKeyHashidE ltkhid "Invalid ltkhid" +parseCommentTopic _ = throwE "Not a ticket/cloth route" + +data Comment = Comment + { commentParent :: Maybe (Either (LocalActorBy Key, LocalMessageId) FedURI) + , commentTopic :: Either CommentTopic FedURI + , commentSource :: PandocMarkdown + , commentContent :: HTML + } + +parseComment :: AP.Note URIMode -> ExceptT Text Handler (Maybe LocalURI, LocalURI, Maybe UTCTime, Comment) +parseComment (AP.Note mluNote luAttrib _aud muParent muContext mpublished source content) = do + uContext <- fromMaybeE muContext "Note without context" + topic <- bitraverse parseCommentTopic pure =<< parseFedURI uContext + maybeParent <- do + uParent <- fromMaybeE muParent "Note doesn't specify inReplyTo" + if uParent == uContext + then pure Nothing + else fmap Just . bitraverse parseCommentId pure =<< parseFedURI uParent + return (mluNote, luAttrib, mpublished, Comment maybeParent topic source content) + +parseNewLocalComment + :: AP.Note URIMode -> ExceptT Text Handler (PersonId, Comment) +parseNewLocalComment note = do + (mluId, luAuthor, maybePublished, comment) <- parseComment note + verifyNothingE mluId "Note specifies an id" + authorPersonID <- do + authorByKey <- + nameExceptT "Note author" $ + parseLocalActorE =<< parseLocalURI luAuthor + case authorByKey of + LocalActorPerson p -> pure p + _ -> throwE "Author isn't a Person actor" + verifyNothingE maybePublished "Note specifies published" + return (authorPersonID, comment) + +parseRemoteComment + :: AP.Note URIMode + -> ExceptT Text Handler (LocalURI, LocalURI, UTCTime, Comment) +parseRemoteComment note = do + (mluId, luAuthor, maybePublished, comment) <- parseComment note + luId <- fromMaybeE mluId "Note doesn't specify id" + published <- fromMaybeE maybePublished "Note doesn't specify published" + return (luId, luAuthor, published, comment) + +messageRoute :: LocalActorBy KeyHashid -> KeyHashid LocalMessage -> Route App +messageRoute (LocalActorPerson p) = PersonMessageR p +messageRoute (LocalActorGroup g) = GroupMessageR g +messageRoute (LocalActorRepo r) = RepoMessageR r +messageRoute (LocalActorDeck d) = DeckMessageR d +messageRoute (LocalActorLoom l) = LoomMessageR l diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 38b7f5d..ad99df8 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -14,9 +14,9 @@ -} module Vervis.Federation.Discussion - ( sharerCreateNoteF - , projectCreateNoteF - , repoCreateNoteF + ( personCreateNoteF + --, deckCreateNoteF + --, loomCreateNoteF ) where @@ -54,6 +54,7 @@ import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest import Web.ActivityPub hiding (ActorLocal (..)) +import Web.Text import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -65,63 +66,18 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub +import Vervis.Cloth +import Vervis.Data.Discussion import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Persist.Discussion import Vervis.Recipient import Vervis.Settings import Vervis.Ticket -import Vervis.Patch - --- | Check the note in the remote Create Note activity delivered to us. -checkNote - :: Note URIMode - -> ExceptT Text Handler - ( LocalURI - , UTCTime - , Either NoteContext FedURI - , Maybe (Either (ShrIdent, LocalMessageId) FedURI) - , Text - , Text - ) -checkNote (Note mluNote _ _ muParent muCtx mpub source content) = do - luNote <- fromMaybeE mluNote "Note without note id" - published <- fromMaybeE mpub "Note without 'published' field" - uContext <- fromMaybeE muCtx "Note without context" - context <- parseContext uContext - mparent <- - case muParent of - Nothing -> return Nothing - Just uParent -> - if uParent == uContext - then return Nothing - else Just <$> parseParent uParent - return (luNote, published, context, mparent, source, content) - --- | Given the parent specified by the Note we received, check if we already --- know and have this parent note in the DB, and whether the child and parent --- belong to the same discussion root. -getParent - :: DiscussionId - -> Either (ShrIdent, LocalMessageId) FedURI - -> ExceptT Text AppDB (Either MessageId FedURI) -getParent did (Left (shr, lmid)) = Left <$> getLocalParentMessageId did shr lmid -getParent did (Right p@(ObjURI hParent luParent)) = do - mrm <- lift $ runMaybeT $ do - iid <- MaybeT $ getKeyBy $ UniqueInstance hParent - roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent - MaybeT $ getValBy $ UniqueRemoteMessageIdent roid - case mrm of - Just rm -> Left <$> do - let mid = remoteMessageRest rm - m <- lift $ getJust mid - unless (messageRoot m == did) $ - throwE "Remote parent belongs to a different discussion" - return mid - Nothing -> return $ Right p -- | Insert the new remote comment into the discussion tree. If we didn't have -- this comment before, return the database ID of the newly created cached @@ -130,8 +86,8 @@ insertToDiscussion :: RemoteAuthor -> LocalURI -> UTCTime - -> Text - -> Text + -> PandocMarkdown + -> HTML -> DiscussionId -> Maybe (Either MessageId FedURI) -> RemoteActivityId @@ -207,121 +163,58 @@ updateOrphans author luNote did mid = do m E.^. MessageRoot `op` E.val did return (rm E.^. RemoteMessageId, m E.^. MessageId) -sharerCreateNoteF +personCreateNoteF :: UTCTime - -> PersonId + -> KeyHashid Person -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> Note URIMode -> ExceptT Text Handler Text -sharerCreateNoteF now pidRecip author body mfwd luCreate note = do - error "sharerCreateF temporarily disabled" +personCreateNoteF now recipPersonHash author body mfwd luCreate note = do + -- Check input + recipPersonID <- decodeKeyHashid404 recipPersonHash + (luNote, published, Comment maybeParent topic source content) <- do + (luId, luAuthor, published, comment) <- parseRemoteComment note + unless (luAuthor == objUriLocal (remoteAuthorURI author)) $ + throwE "Create author != note author" + return (luId, published, comment) -{- + mractid <- runDBExcept $ do + Entity recipActorID recipActor <- lift $ do + person <- get404 recipPersonID + let actorID = personActor person + Entity actorID <$> getJust actorID + case topic of - (luNote, published, context, mparent, source, content) <- checkNote note - case context of - Right uContext -> runDBExcept $ do - personRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getValBy404 $ UniquePersonIdent sid - checkContextParent uContext mparent - mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True - return $ - case mractid of - Nothing -> "I already have this activity in my inbox, doing nothing" - Just _ -> "Context is remote, so just inserting to my inbox" - Left (NoteContextSharerTicket shr talid patch) -> do - mremotesHttp <- runDBExcept $ do - (sid, pid, ibid) <- lift getRecip404 - (tal, lt, followers) <- - if patch - then do - (Entity _ tal, Entity _ lt, _, _, _, _) <- do - mticket <- lift $ getSharerProposal shr talid - fromMaybeE mticket "Context: No such sharer-patch" - return (tal, lt, LocalPersonCollectionSharerProposalFollowers) - else do - (Entity _ tal, Entity _ lt, _, _, _) <- do - mticket <- lift $ getSharerTicket shr talid - fromMaybeE mticket "Context: No such sharer-ticket" - return (tal, lt, LocalPersonCollectionSharerTicketFollowers) - if ticketAuthorLocalAuthor tal == pid - then do - mractid <- lift $ insertToInbox now author body ibid luCreate True - case mractid of - Nothing -> return $ Left "Activity already in my inbox" - Just ractid -> do - let did = localTicketDiscuss lt - meparent <- traverse (getParent did) mparent - mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid - case mmid of - Nothing -> return $ Left "I already have this comment, just storing in inbox" - Just mid -> lift $ do - updateOrphans author luNote did mid - case mfwd of - Nothing -> - return $ Left "Storing in inbox, caching comment, no inbox forwarding header" - Just (localRecips, sig) -> Right <$> do - talkhid <- encodeKeyHashid talid - let sieve = - makeRecipientSet - [] - [ followers shrRecip talkhid - --, LocalPersonCollectionSharerTicketTeam shrRecip talkhid - ] - remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips - (sig,) <$> deliverRemoteDB_S (actbBL body) ractid sid sig remoteRecips - else do - let did = localTicketDiscuss lt - _ <- traverse (getParent did) mparent - mractid <- lift $ insertToInbox now author body ibid luCreate True - return $ Left $ - case mractid of - Nothing -> "Context is a sharer-ticket of another sharer, and I already have this activity in my inbox, doing nothing" - Just _ -> "Context is a sharer-ticket of another sharer, just storing in my inbox" - case mremotesHttp of - Left msg -> return msg - Right (sig, remotesHttp) -> do - forkWorker "sharerCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotesHttp - return "Stored to inbox, cached comment, and did inbox forwarding" - Left (NoteContextProjectTicket shr prj ltid) -> runDBExcept $ do - personRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getValBy404 $ UniquePersonIdent sid - (_, _, _, Entity _ lt, _, _, _, _) <- do - mticket <- lift $ getProjectTicket shr prj ltid - fromMaybeE mticket "Context: No such project-ticket" - let did = localTicketDiscuss lt - _ <- traverse (getParent did) mparent - mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True - return $ - case mractid of - Nothing -> "I already have this activity in my inbox, doing nothing" - Just _ -> "Context is a project-ticket, so just inserting to my inbox" - Left (NoteContextRepoProposal shr rp ltid) -> runDBExcept $ do - personRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getValBy404 $ UniquePersonIdent sid - (_, _, _, Entity _ lt, _, _, _, _, _) <- do - mticket <- lift $ getRepoProposal shr rp ltid - fromMaybeE mticket "Context: No such repo-patch" - let did = localTicketDiscuss lt - _ <- traverse (getParent did) mparent - mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True - return $ - case mractid of - Nothing -> "I already have this activity in my inbox, doing nothing" - Just _ -> "Context is a repo-patch, so just inserting to my inbox" + Right uContext -> do + checkContextParent uContext maybeParent + lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + + Left (CommentTopicTicket deckID taskID) -> do + (_, _, Entity _ ticket, _, _) <- do + mticket <- lift $ getTicket deckID taskID + fromMaybeE mticket "Context: No such deck-ticket" + let did = ticketDiscuss ticket + _ <- traverse (getMessageParent did) maybeParent + lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + + Left (CommentTopicCloth loomID clothID) -> do + (_, _, Entity _ ticket, _, _, _) <- do + mticket <- lift $ getCloth loomID clothID + fromMaybeE mticket "Context: No such loom-cloth" + let did = ticketDiscuss ticket + _ <- traverse (getMessageParent did) maybeParent + lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + + return $ + case mractid of + Nothing -> "I already have this activity in my inbox, doing nothing" + Just _ -> "Inserted Create{Note} to my inbox" where - getRecip404 = do - sid <- getKeyBy404 $ UniqueSharer shrRecip - Entity pid p <- getBy404 $ UniquePersonIdent sid - return (sid, pid, personInbox p) checkContextParent (ObjURI hContext luContext) mparent = do mdid <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hContext @@ -330,9 +223,9 @@ sharerCreateNoteF now pidRecip author body mfwd luCreate note = do return $ remoteDiscussionDiscuss rd for_ mparent $ \ parent -> case parent of - Left (shrP, lmidP) -> do + Left msg -> do did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion" - void $ getLocalParentMessageId did shrP lmidP + void $ getLocalParentMessageId did msg Right (ObjURI hParent luParent) -> do mrm <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hParent @@ -344,8 +237,8 @@ sharerCreateNoteF now pidRecip author body mfwd luCreate note = do did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion" unless (messageRoot m == did) $ throwE "Remote parent belongs to a different discussion" --} +{- projectCreateNoteF :: UTCTime -> KeyHashid Project @@ -356,51 +249,9 @@ projectCreateNoteF -> Note URIMode -> ExceptT Text Handler Text projectCreateNoteF now deckRecip author body mfwd luCreate note = do - error "projectCreateNoteF temporarily disabled" - - -{- - - (luNote, published, context, mparent, source, content) <- checkNote note case context of Right _ -> return "Not using; context isn't local" - Left (NoteContextSharerTicket shr talid False) -> do - mremotesHttp <- runDBExcept $ do - (jid, ibid) <- lift getProjectRecip404 - (_, _, _, project, _) <- do - mticket <- lift $ getSharerTicket shr talid - fromMaybeE mticket "Context: No such sharer-ticket" - case project of - Left (_, Entity _ tpl) - | ticketProjectLocalProject tpl == jid -> do - mractid <- lift $ insertToInbox now author body ibid luCreate False - case mractid of - Nothing -> return $ Left "Activity already in my inbox" - Just ractid -> - case mfwd of - Nothing -> - return $ Left - "Context is a sharer-ticket, \ - \but no inbox forwarding \ - \header for me, so doing \ - \nothing, just storing in inbox" - Just (localRecips, sig) -> lift $ Right <$> do - let sieve = - makeRecipientSet - [] - [ LocalPersonCollectionProjectFollowers shrRecip prjRecip - , LocalPersonCollectionProjectTeam shrRecip prjRecip - ] - remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips - (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips - _ -> return $ Left "Context is a sharer-ticket of another project" - case mremotesHttp of - Left msg -> return msg - Right (sig, remotesHttp) -> do - forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp - return "Stored to inbox and did inbox forwarding" - Left (NoteContextSharerTicket _ _ True) -> return "Context is a sharer-patch, ignoring activity" Left (NoteContextProjectTicket shr prj ltid) -> do mremotesHttp <- runDBExcept $ do (jid, ibid) <- lift getProjectRecip404 @@ -450,6 +301,7 @@ projectCreateNoteF now deckRecip author body mfwd luCreate note = do return (jid, actorInbox a) -} +{- repoCreateNoteF :: UTCTime -> KeyHashid Repo @@ -460,52 +312,9 @@ repoCreateNoteF -> Note URIMode -> ExceptT Text Handler Text repoCreateNoteF now repoRecip author body mfwd luCreate note = do - error "repoCreateNoteF temporarily disabled" - - -{- - - (luNote, published, context, mparent, source, content) <- checkNote note case context of Right _ -> return "Not using; context isn't local" - Left (NoteContextSharerTicket _ _ False) -> - return "Context is a sharer-ticket, ignoring activity" - Left (NoteContextSharerTicket shr talid True) -> do - mremotesHttp <- runDBExcept $ do - (rid, ibid) <- lift getRepoRecip404 - (_, _, _, repo, _, _) <- do - mticket <- lift $ getSharerProposal shr talid - fromMaybeE mticket "Context: No such sharer-ticket" - case repo of - Left (_, Entity _ trl) - | ticketRepoLocalRepo trl == rid -> do - mractid <- lift $ insertToInbox now author body ibid luCreate False - case mractid of - Nothing -> return $ Left "Activity already in my inbox" - Just ractid -> - case mfwd of - Nothing -> - return $ Left - "Context is a sharer-patch, \ - \but no inbox forwarding \ - \header for me, so doing \ - \nothing, just storing in inbox" - Just (localRecips, sig) -> lift $ Right <$> do - let sieve = - makeRecipientSet - [] - [ LocalPersonCollectionRepoFollowers shrRecip rpRecip - , LocalPersonCollectionRepoTeam shrRecip rpRecip - ] - remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips - (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips - _ -> return $ Left "Context is a sharer-patch of another repo" - case mremotesHttp of - Left msg -> return msg - Right (sig, remotesHttp) -> do - forkWorker "repoCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotesHttp - return "Stored to inbox and did inbox forwarding" Left (NoteContextProjectTicket _ _ _) -> return "Context is a project-ticket, ignoring activity" Left (NoteContextRepoProposal shr rp ltid) -> do diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 65746b6..7253d1c 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -848,6 +848,8 @@ instance YesodBreadcrumbs App where GroupOutboxItemR g i -> (keyHashidText i, Just $ GroupOutboxR g) GroupFollowersR g -> ("Followers", Just $ GroupR g) + GroupMessageR g m -> ("Message #" <> keyHashidText m, Just $ GroupR g) + GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g) RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR) @@ -868,6 +870,8 @@ instance YesodBreadcrumbs App where RepoBranchCommitsR r b -> ("Branch " <> b <> " Commits", Just $ RepoR r) RepoCommitR r c -> (c, Just $ RepoCommitsR r) + RepoMessageR r m -> ("Message #" <> keyHashidText m, Just $ RepoR r) + RepoNewR -> ("New Repo", Just HomeR) RepoDeleteR r -> ("", Nothing) RepoEditR r -> ("Edit", Just $ RepoR r) @@ -889,6 +893,8 @@ instance YesodBreadcrumbs App where DeckTreeR d -> ("Tree", Just $ DeckTicketsR d) + DeckMessageR d m -> ("Message #" <> keyHashidText m, Just $ DeckR d) + DeckNewR -> ("New Ticket Tracker", Just HomeR) DeckDeleteR _ -> ("", Nothing) DeckEditR d -> ("Edit", Just $ DeckR d) @@ -917,6 +923,8 @@ instance YesodBreadcrumbs App where LoomFollowersR l -> ("Followers", Just $ LoomR l) LoomClothsR l -> ("Merge Requests", Just $ LoomR l) + LoomMessageR l m -> ("Message #" <> keyHashidText m, Just $ LoomR l) + LoomNewR -> ("New Patch Tracker", Just HomeR) LoomFollowR _ -> ("", Nothing) LoomUnfollowR _ -> ("", Nothing) diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index bfe99cf..afce458 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -106,7 +106,7 @@ import Vervis.ActivityPub import Vervis.API import Vervis.Cloth import Vervis.Data.Actor -import Vervis.Discussion +import Vervis.Persist.Discussion import Vervis.FedURI import Vervis.Foundation import Vervis.Model diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 6e6c2cd..ef8c96e 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -24,6 +24,8 @@ module Vervis.Handler.Deck , getDeckTreeR + , getDeckMessageR + , getDeckNewR , postDeckNewR , postDeckDeleteR @@ -313,6 +315,9 @@ getDeckTreeR _ = error "Temporarily disabled" defaultLayout $ ticketTreeDW shr prj summaries deps -} +getDeckMessageR :: KeyHashid Deck -> KeyHashid LocalMessage -> Handler Html +getDeckMessageR _ _ = notFound + getDeckNewR :: Handler Html getDeckNewR = do ((_result, widget), enctype) <- runFormPost newProjectForm diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 39e90be..ebfa2ae 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -20,6 +20,7 @@ module Vervis.Handler.Group , getGroupOutboxR , getGroupOutboxItemR , getGroupFollowersR + , getGroupMessageR , getGroupStampR @@ -49,6 +50,7 @@ import Data.Text (Text) import Data.Time.Clock import Database.Persist import Data.ByteString (ByteString) +import Yesod.Core import Yesod.Core.Content (TypedContent) import Yesod.Persist.Core @@ -138,6 +140,10 @@ getGroupOutboxItemR = getOutboxItem GroupOutboxItemR groupActor getGroupFollowersR :: KeyHashid Group -> Handler TypedContent getGroupFollowersR = getActorFollowersCollection GroupFollowersR groupActor +getGroupMessageR + :: KeyHashid Group -> KeyHashid LocalMessage -> Handler TypedContent +getGroupMessageR _ _ = notFound + getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent getGroupStampR = servePerActorKey groupActor LocalActorGroup diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index ce8bde2..aace0ad 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -22,6 +22,8 @@ module Vervis.Handler.Loom , getLoomFollowersR , getLoomClothsR + , getLoomMessageR + , getLoomNewR , postLoomNewR , postLoomFollowR @@ -248,6 +250,10 @@ getLoomClothsR loomHash = selectRep $ do here = LoomClothsR loomHash encodeStrict = BL.toStrict . encode +getLoomMessageR + :: KeyHashid Loom -> KeyHashid LocalMessage -> Handler TypedContent +getLoomMessageR _ _ = notFound + getLoomNewR :: Handler Html getLoomNewR = do ((_result, widget), enctype) <- runFormPost newLoomForm diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 3985046..6864fd4 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -74,6 +74,7 @@ import Vervis.API import Vervis.Data.Actor import Vervis.Federation.Auth import Vervis.Federation.Collab +import Vervis.Federation.Discussion import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -84,6 +85,7 @@ import Vervis.Secure import Vervis.Settings import Vervis.Ticket import Vervis.Web.Actor +import Vervis.Web.Discussion import Vervis.Widget import Vervis.Widget.Person @@ -204,13 +206,13 @@ postPersonInboxR recipPersonHash = postInbox handle Right (AddBundle patches) -> sharerAddBundleF now shrRecip author body mfwd luActivity patches target _ -> return ("Unsupported add object type for sharers", Nothing) - CreateActivity (Create obj mtarget) -> + -} + AP.CreateActivity (AP.Create obj mtarget) -> case obj of - CreateNote _ note -> - (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note - CreateTicket _ ticket -> - (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget - _ -> return ("Unsupported create object type for sharers", Nothing) + AP.CreateNote _ note -> + (,Nothing) <$> personCreateNoteF now recipPersonHash author body mfwd luActivity note + _ -> return ("Unsupported create object type for people", Nothing) + {- FollowActivity follow -> (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow -} @@ -318,10 +320,8 @@ postPersonOutboxR personHash = do AP.ApplyActivity apply -> run applyC apply AP.CreateActivity (AP.Create obj mtarget) -> case obj of - {- - CreateNote _ note -> - createNoteC eperson sharer summary audience note mtarget - -} + AP.CreateNote _ note -> + run createNoteC note mtarget AP.CreateTicketTracker detail mlocal -> run createTicketTrackerC detail mlocal mtarget AP.CreateRepository detail vcs mlocal -> @@ -393,68 +393,8 @@ getSshKeyR personHash keyHash = do getPersonMessageR :: KeyHashid Person -> KeyHashid LocalMessage -> Handler TypedContent -getPersonMessageR personHash localMessageHash = do - personID <- decodeKeyHashid404 personHash - localMessageID <- decodeKeyHashid404 localMessageHash - - encodeRouteHome <- getEncodeRouteHome - workItemRoute <- askWorkItemRoute - note <- runDB $ do - _ <- get404 personID - localMessage <- get404 localMessageID - unless (localMessageAuthor localMessage == personID) notFound - message <- getJust $ localMessageRest localMessage - - uContext <- do - let discussionID = messageRoot message - topic <- - requireEitherAlt - (getKeyBy $ UniqueTicketDiscuss discussionID) - (getValBy $ UniqueRemoteDiscussion discussionID) - "Neither T nor RD found" - "Both T and RD found" - case topic of - Left ticketID -> - encodeRouteHome . workItemRoute <$> getWorkItem ticketID - Right rd -> do - ro <- getJust $ remoteDiscussionIdent rd - i <- getJust $ remoteObjectInstance ro - return $ ObjURI (instanceHost i) (remoteObjectIdent ro) - - muParent <- for (messageParent message) $ \ parentID -> do - parent <- - requireEitherAlt - (getBy $ UniqueLocalMessage parentID) - (getValBy $ UniqueRemoteMessage parentID) - "Message with no author" - "Message used as both local and remote" - case parent of - Left (Entity localParentID localParent) -> do - authorHash <- - encodeKeyHashid $ localMessageAuthor localParent - localParentHash <- encodeKeyHashid localParentID - return $ encodeRouteHome $ - PersonMessageR authorHash localParentHash - Right remoteParent -> do - rs <- getJust $ remoteMessageAuthor remoteParent - ro <- getJust $ remoteActorIdent rs - i <- getJust $ remoteObjectInstance ro - return $ ObjURI (instanceHost i) (remoteObjectIdent ro) - - encodeRouteLocal <- getEncodeRouteLocal - return AP.Note - { AP.noteId = Just $ encodeRouteLocal here - , AP.noteAttrib = encodeRouteLocal $ PersonR personHash - , AP.noteAudience = AP.Audience [] [] [] [] [] [] - , AP.noteReplyTo = Just $ fromMaybe uContext muParent - , AP.noteContext = Just uContext - , AP.notePublished = Just $ messageCreated message - , AP.noteSource = messageSource message - , AP.noteContent = messageContent message - } - provideHtmlAndAP note $ redirectToPrettyJSON here - where - here = PersonMessageR personHash localMessageHash +getPersonMessageR personHash localMessageHash = + serveMessage personHash localMessageHash postPersonFollowR :: KeyHashid Person -> Handler () postPersonFollowR _ = error "Temporarily disabled" diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 1d2d79f..901dfa2 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -32,6 +32,8 @@ module Vervis.Handler.Repo , getRepoBranchCommitsR , getRepoCommitR + , getRepoMessageR + , getRepoNewR , postRepoNewR , postRepoDeleteR @@ -427,6 +429,10 @@ getRepoCommitR repoHash ref = do VCSDarcs -> getDarcsPatch repoHash ref VCSGit -> getGitPatch repoHash ref +getRepoMessageR + :: KeyHashid Repo -> KeyHashid LocalMessage -> Handler TypedContent +getRepoMessageR _ _ = notFound + getRepoNewR :: Handler Html getRepoNewR = do ((_result, widget), enctype) <- runFormPost newRepoForm diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 4bc4a3e..41c7085 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -139,7 +139,7 @@ import Yesod.Persist.Local import Vervis.ActivityPub import Vervis.API import Vervis.Data.Actor -import Vervis.Discussion +import Vervis.Persist.Discussion import Vervis.FedURI import Vervis.Foundation --import Vervis.GraphProxy (ticketDepGraph) diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index fb8a5f3..5b17e5b 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -2773,6 +2773,31 @@ changes hLocal ctx = , removeEntity "ForwarderDeck" -- 503 , removeEntity "ForwarderLoom" + -- 504 + , addFieldRefRequired'' + "LocalMessage" + (do ibid <- insert Inbox504 + obid <- insert Outbox504 + fsid <- insert FollowerSet504 + insertEntity $ Actor504 "" "" defaultTime ibid obid fsid + ) + (Just $ \ (Entity aidTemp aTemp) -> do + ms <- selectList ([] :: [Filter LocalMessage504]) [] + for_ ms $ \ (Entity lmid lm) -> do + person <- getJust $ localMessage504Author lm + update lmid [LocalMessage504AuthorNew =. person504Actor person] + + delete aidTemp + delete $ actor504Inbox aTemp + delete $ actor504Outbox aTemp + delete $ actor504Followers aTemp + ) + "authorNew" + "Actor" + -- 505 + , removeField "LocalMessage" "author" + -- 506 + , renameField "LocalMessage" "authorNew" "author" ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 81e9c2c..7cf5319 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -676,3 +676,6 @@ model_497_sigkey = $(schema "497_2022-09-29_sigkey") makeEntitiesMigration "498" $(modelFile "migrations/498_2022-10-03_forwarder.model") + +makeEntitiesMigration "504" + $(modelFile "migrations/504_2022-10-16_message_author.model") diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 83f5407..39ddda5 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -15,6 +15,7 @@ module Vervis.Persist.Actor ( getLocalActor + , getLocalActorEntity , verifyLocalActivityExistsInDB , getRemoteActorURI , insertActor @@ -75,6 +76,21 @@ getLocalActor actorID = do (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l _ -> error "Multi-usage of an ActorId" +getLocalActorEntity + :: MonadIO m + => LocalActorBy Key + -> ReaderT SqlBackend m (Maybe (LocalActorBy Entity)) +getLocalActorEntity (LocalActorPerson p) = + fmap (LocalActorPerson . Entity p) <$> get p +getLocalActorEntity (LocalActorGroup g) = + fmap (LocalActorGroup . Entity g) <$> get g +getLocalActorEntity (LocalActorRepo r) = + fmap (LocalActorRepo . Entity r) <$> get r +getLocalActorEntity (LocalActorDeck d) = + fmap (LocalActorDeck . Entity d) <$> get d +getLocalActorEntity (LocalActorLoom l) = + fmap (LocalActorLoom . Entity l) <$> get l + verifyLocalActivityExistsInDB :: MonadIO m => LocalActorBy Key diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Persist/Discussion.hs similarity index 59% rename from src/Vervis/Discussion.hs rename to src/Vervis/Persist/Discussion.hs index 5dcebb7..c0e51e6 100644 --- a/src/Vervis/Discussion.hs +++ b/src/Vervis/Persist/Discussion.hs @@ -13,16 +13,13 @@ - . -} -module Vervis.Discussion +module Vervis.Persist.Discussion ( MessageTreeNodeAuthor (..) , MessageTreeNode (..) , getDiscussionTree - , getRepliesCollection - , NoteTopic (..) - , NoteParent (..) - , parseNoteContext - , parseNoteParent + --, getRepliesCollection , getLocalParentMessageId + , getMessageParent ) where @@ -30,6 +27,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import Data.Graph.Inductive.Graph (mkGraph, lab') import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Graph.Inductive.Query.DFS (dffWith) @@ -44,21 +42,27 @@ import qualified Data.HashMap.Lazy as M (fromList, lookup) import qualified Database.Esqueleto as E import Network.FedURI -import Web.ActivityPub import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite +import qualified Web.ActivityPub as AP + import Control.Monad.Trans.Except.Local import Data.Tree.Local (sortForestOn) +import Database.Persist.Local +import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model +import Vervis.Model.Ident +import Vervis.Persist.Actor +import Vervis.Recipient data MessageTreeNodeAuthor - = MessageTreeNodeLocal LocalMessageId PersonId + = MessageTreeNodeLocal LocalMessageId (LocalActorBy Key) Text Text | MessageTreeNodeRemote Host LocalURI LocalURI (Maybe Text) data MessageTreeNode = MessageTreeNode @@ -70,10 +74,16 @@ data MessageTreeNode = MessageTreeNode getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode] getMessages getdid = runDB $ do did <- getdid - l <- select $ from $ \ (lm `InnerJoin` m) -> do - on $ lm ^. LocalMessageRest ==. m ^. MessageId - where_ $ m ^. MessageRoot ==. val did - return (m, lm ^. LocalMessageId, lm ^. LocalMessageAuthor) + l <- select $ from $ \ (lm `InnerJoin` m `InnerJoin` a) -> do + on $ lm ^. LocalMessageAuthor ==. a ^. ActorId + on $ lm ^. LocalMessageRest ==. m ^. MessageId + where_ $ m ^. MessageRoot ==. val did + return + ( m + , lm ^. LocalMessageId + , lm ^. LocalMessageAuthor + , a ^. ActorName + ) r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` ra `InnerJoin` ro `InnerJoin` i `InnerJoin` ro2) -> do on $ rm ^. RemoteMessageIdent ==. ro2 ^. RemoteObjectId on $ ro ^. RemoteObjectInstance ==. i ^. InstanceId @@ -88,10 +98,30 @@ getMessages getdid = runDB $ do , ro ^. RemoteObjectIdent , ra ^. RemoteActorName ) - return $ map mklocal l ++ map mkremote r + locals <- traverse mklocal l + let remotes = map mkremote r + return $ locals ++ remotes where - mklocal (Entity mid m, Value lmid, Value pid) = - MessageTreeNode mid m $ MessageTreeNodeLocal lmid pid + mklocal (Entity mid m, Value lmid, Value aid, Value name) = do + authorByKey <- getLocalActor aid + code <- + case authorByKey of + LocalActorPerson personID -> do + person <- getJust personID + return $ "~" <> username2text (personUsername person) + LocalActorGroup groupID -> do + groupHash <- encodeKeyHashid groupID + return $ "&" <> keyHashidText groupHash + LocalActorRepo repoID -> do + repoHash <- encodeKeyHashid repoID + return $ "^" <> keyHashidText repoHash + LocalActorDeck deckID -> do + deckHash <- encodeKeyHashid deckID + return $ "=" <> keyHashidText deckHash + LocalActorLoom loomID -> do + loomHash <- encodeKeyHashid loomID + return $ "+" <> keyHashidText loomHash + return $ MessageTreeNode mid m $ MessageTreeNodeLocal lmid authorByKey code name mkremote (Entity mid m, Value h, Value luMsg, Value luAuthor, Value name) = MessageTreeNode mid m $ MessageTreeNodeRemote h luMsg luAuthor name @@ -121,6 +151,7 @@ sortByTime = sortForestOn $ messageCreated . mtnMessage getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode) getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid +{- getRepliesCollection :: Route App -> AppDB DiscussionId -> Handler TypedContent getRepliesCollection here getDiscussionId404 = do (locals, remotes) <- runDB $ do @@ -166,78 +197,65 @@ getRepliesCollection here getDiscussionId404 = do localUri hashPerson encR encH (E.Value pid, E.Value lmid) = encR $ PersonMessageR (hashPerson pid) (encH lmid) remoteUri (E.Value h, E.Value lu) = ObjURI h lu +-} -data NoteTopic - = NoteTopicTicket DeckId TicketDeckId - | NoteTopicCloth LoomId TicketLoomId - deriving Eq +getMessage + :: LocalActorBy Key + -> LocalMessageId + -> ExceptT Text AppDB + ( LocalActorBy Entity + , Entity Actor + , Entity LocalMessage + , Entity Message + ) +getMessage authorByKey localMsgID = do + authorByEntity <- do + maybeActor <- lift $ getLocalActorEntity authorByKey + fromMaybeE maybeActor "No such author in DB" + let actorID = localActorID authorByEntity + actor <- lift $ getJust actorID + localMsg <- do + mlm <- lift $ get localMsgID + fromMaybeE mlm "No such lmid in DB" + unless (localMessageAuthor localMsg == actorID) $ + throwE "No such message, lmid mismatches author" + let msgID = localMessageRest localMsg + msg <- lift $ getJust msgID + return + ( authorByEntity + , Entity actorID actor + , Entity localMsgID localMsg + , Entity msgID msg + ) -parseNoteTopic (TicketR dkhid ltkhid) = - NoteTopicTicket - <$> decodeKeyHashidE dkhid "Note context invalid dkhid" - <*> decodeKeyHashidE ltkhid "Note context invalid ltkhid" -parseNoteTopic (ClothR lkhid ltkhid) = - NoteTopicCloth - <$> decodeKeyHashidE lkhid "Note context invalid lkhid" - <*> decodeKeyHashidE ltkhid "Note context invalid ltkhid" -parseNoteTopic _ = throwE "Local context isn't a ticket/cloth route" - -parseNoteContext - :: (MonadSite m, SiteEnv m ~ App) - => FedURI - -> ExceptT Text m (Either NoteTopic FedURI) -parseNoteContext uContext = do - let ObjURI hContext luContext = uContext - local <- hostIsLocal hContext - if local - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal luContext) - "Local context isn't a valid route" - parseNoteTopic route - else return $ Right uContext - -data NoteParent - = NoteParentMessage PersonId LocalMessageId - | NoteParentTopic NoteTopic - deriving Eq - -parseNoteParent - :: (MonadSite m, SiteEnv m ~ App) - => FedURI - -> ExceptT Text m (Either NoteParent FedURI) -parseNoteParent uParent = do - let ObjURI hParent luParent = uParent - local <- hostIsLocal hParent - if local - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal luParent) - "Local parent isn't a valid route" - (<|>) - (uncurry NoteParentMessage <$> parseNoteID route) - (NoteParentTopic <$> parseNoteTopic route) - else return $ Right uParent - where - parseNoteID (PersonMessageR pkhid lmkhid) = - (,) <$> decodeKeyHashidE pkhid - "Local parent has non-existent person hashid" - <*> decodeKeyHashidE lmkhid - "Local parent has non-existent message hashid" - parseNoteID _ = throwE "Local parent isn't a message route" - -getLocalParentMessageId :: DiscussionId -> PersonId -> LocalMessageId -> ExceptT Text AppDB MessageId -getLocalParentMessageId did pid lmid = do - mp <- lift $ get pid - _ <- fromMaybeE mp "Local parent: no such pid" - mlm <- lift $ get lmid - lm <- fromMaybeE mlm "Local parent: no such lmid" - unless (localMessageAuthor lm == pid) $ throwE "Local parent: No such message, lmid mismatches pid" - - let mid = localMessageRest lm - m <- lift $ getJust mid - unless (messageRoot m == did) $ +getLocalParentMessageId + :: DiscussionId + -> (LocalActorBy Key, LocalMessageId) + -> ExceptT Text AppDB MessageId +getLocalParentMessageId discussionID (authorByKey, localMsgID) = do + (_, _, _, Entity msgID msg) <- getMessage authorByKey localMsgID + unless (messageRoot msg == discussionID) $ throwE "Local parent belongs to a different discussion" - return mid + return msgID + +-- | Given the parent specified by the Note we received, check if we already +-- know and have this parent note in the DB, and whether the child and parent +-- belong to the same discussion root. +getMessageParent + :: DiscussionId + -> Either (LocalActorBy Key, LocalMessageId) FedURI + -> ExceptT Text AppDB (Either MessageId FedURI) +getMessageParent did (Left msg) = Left <$> getLocalParentMessageId did msg +getMessageParent did (Right p@(ObjURI hParent luParent)) = do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent roid + case mrm of + Just rm -> Left <$> do + let mid = remoteMessageRest rm + m <- lift $ getJust mid + unless (messageRoot m == did) $ + throwE "Remote parent belongs to a different discussion" + return mid + Nothing -> return $ Right p diff --git a/src/Vervis/Web/Discussion.hs b/src/Vervis/Web/Discussion.hs index e18848f..132e4f1 100644 --- a/src/Vervis/Web/Discussion.hs +++ b/src/Vervis/Web/Discussion.hs @@ -19,6 +19,7 @@ module Vervis.Web.Discussion --, postTopReply --, getReply --, postReply + , serveMessage ) where @@ -45,25 +46,31 @@ import qualified Data.Text as T import Data.Aeson.Encode.Pretty.ToEncoding import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite +import Yesod.RenderSource +import qualified Web.ActivityPub as AP + +import Data.Either.Local import Database.Persist.Local import Yesod.Persist.Local import Vervis.API -import Vervis.Discussion +import Vervis.Data.Discussion import Vervis.FedURI import Vervis.Form.Discussion import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident -import Yesod.RenderSource +import Vervis.Persist.Actor +import Vervis.Persist.Discussion +import Vervis.Recipient import Vervis.Settings +import Vervis.Ticket import Vervis.Widget.Discussion getDiscussion @@ -225,3 +232,68 @@ postReply hDest recipsA recipsC context recipF replyG replyP after getdid midPar Nothing -> error "noteC succeeded but no lmid found for obiid" Just lmid -> redirect $ after lmid -} + +serveMessage authorHash localMessageHash = do + authorID <- decodeKeyHashid404 authorHash + localMessageID <- decodeKeyHashid404 localMessageHash + + encodeRouteHome <- getEncodeRouteHome + workItemRoute <- askWorkItemRoute + noteAP <- runDB $ do + author <- get404 authorID + localMessage <- get404 localMessageID + unless (localMessageAuthor localMessage == personActor author) notFound + message <- getJust $ localMessageRest localMessage + + uContext <- do + let discussionID = messageRoot message + topic <- + requireEitherAlt + (getKeyBy $ UniqueTicketDiscuss discussionID) + (getValBy $ UniqueRemoteDiscussion discussionID) + "Neither T nor RD found" + "Both T and RD found" + case topic of + Left ticketID -> + encodeRouteHome . workItemRoute <$> getWorkItem ticketID + Right rd -> do + ro <- getJust $ remoteDiscussionIdent rd + i <- getJust $ remoteObjectInstance ro + return $ ObjURI (instanceHost i) (remoteObjectIdent ro) + + muParent <- for (messageParent message) $ \ parentID -> do + parent <- + requireEitherAlt + (getBy $ UniqueLocalMessage parentID) + (getValBy $ UniqueRemoteMessage parentID) + "Message with no author" + "Message used as both local and remote" + case parent of + Left (Entity localParentID localParent) -> do + authorByKey <- + getLocalActor $ localMessageAuthor localParent + authorByHash <- hashLocalActor authorByKey + localParentHash <- encodeKeyHashid localParentID + return $ + encodeRouteHome $ + messageRoute authorByHash localParentHash + Right remoteParent -> do + rs <- getJust $ remoteMessageAuthor remoteParent + ro <- getJust $ remoteActorIdent rs + i <- getJust $ remoteObjectInstance ro + return $ ObjURI (instanceHost i) (remoteObjectIdent ro) + + encodeRouteLocal <- getEncodeRouteLocal + return AP.Note + { AP.noteId = Just $ encodeRouteLocal here + , AP.noteAttrib = encodeRouteLocal $ PersonR authorHash + , AP.noteAudience = AP.Audience [] [] [] [] [] [] + , AP.noteReplyTo = Just $ fromMaybe uContext muParent + , AP.noteContext = Just uContext + , AP.notePublished = Just $ messageCreated message + , AP.noteSource = messageSource message + , AP.noteContent = messageContent message + } + provideHtmlAndAP noteAP $ redirectToPrettyJSON here + where + here = PersonMessageR authorHash localMessageHash diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs index aeb3d9f..a845dee 100644 --- a/src/Vervis/Widget/Discussion.hs +++ b/src/Vervis/Widget/Discussion.hs @@ -30,24 +30,27 @@ import Yesod.Core.Widget import qualified Data.Text as T (filter) +import Data.MediaType import Network.FedURI +import Web.Text import Yesod.Hashids +import Yesod.RenderSource import Data.EventTime.Local import Data.Time.Clock.Local () -import Vervis.Discussion +import Vervis.Data.Discussion import Vervis.Foundation -import Data.MediaType import Vervis.Model import Vervis.Model.Ident -import Yesod.RenderSource +import Vervis.Persist.Discussion +import Vervis.Recipient import Vervis.Settings (widgetFile) import Vervis.Widget.Person actorLinkW :: MessageTreeNodeAuthor -> Widget actorLinkW actor = do - hashPerson <- getEncodeKeyHashid + hashAuthor <- getHashLocalActor $(widgetFile "widget/actor-link") where shortURI h (LocalURI p) = renderAuthority h <> p @@ -55,15 +58,13 @@ actorLinkW actor = do messageW :: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget messageW now (MessageTreeNode msgid msg author) reply = do - hashPerson <- getEncodeKeyHashid + hashAuthor <- getHashLocalActor encodeHid <- getEncodeKeyHashid let showTime = showEventTime . intervalToEventTime . FriendlyConvert . diffUTCTime now - showContent :: Text -> Widget - showContent = toWidget . preEscapedToMarkup $(widgetFile "discussion/widget/message") messageTreeW diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index dc74a6c..915fd3e 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -147,7 +147,6 @@ import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Simple (JSONException) import Network.HTTP.Types.Header (HeaderName, hContentType) import Text.Email.Parser (EmailAddress) -import Text.HTML.SanitizeXSS import Yesod.Core.Content (ContentType) import Yesod.Core.Handler (ProvidedRep, provideRepType) @@ -710,8 +709,8 @@ data Note u = Note , noteReplyTo :: Maybe (ObjURI u) , noteContext :: Maybe (ObjURI u) , notePublished :: Maybe UTCTime - , noteSource :: Text - , noteContent :: Text + , noteSource :: PandocMarkdown + , noteContent :: HTML } withAuthorityT a m = do @@ -798,7 +797,7 @@ instance ActivityPub Note where <*> o .:? "context" <*> o .:? "published" <*> source .: "content" - <*> (sanitizeBalance <$> o .: "content") + <*> o .: "content" toSeries authority (Note mid attrib aud mreply mcontext mpublished src content) = "type" .= ("Note" :: Text) <> "id" .=? (ObjURI authority <$> mid) diff --git a/templates/discussion/widget/message.hamlet b/templates/discussion/widget/message.hamlet index ae02b9e..89b989f 100644 --- a/templates/discussion/widget/message.hamlet +++ b/templates/discussion/widget/message.hamlet @@ -18,13 +18,13 @@ $# . ^{actorLinkW author} $case author - $of MessageTreeNodeLocal lmid pid - + $of MessageTreeNodeLocal lmid authorByKey _ _ + #{showTime $ messageCreated msg} $of MessageTreeNodeRemote h luMsg _luAuthor _mname #{showTime $ messageCreated msg} - ^{showContent $ messageContent msg} + ^{markupHTML $ messageContent msg} reply diff --git a/templates/widget/actor-link.hamlet b/templates/widget/actor-link.hamlet index c767c14..2251db4 100644 --- a/templates/widget/actor-link.hamlet +++ b/templates/widget/actor-link.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2019 by fr33domlover . +$# Written in 2016, 2019, 2022 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -13,11 +13,9 @@ $# with this software. If not, see $# . $case actor - $of MessageTreeNodeLocal _lmid pid - - ~#{keyHashidText $ hashPerson pid} - - ./people/#{keyHashidText $ hashPerson pid} + $of MessageTreeNodeLocal _lmid authorByKey code name + + code name $of MessageTreeNodeRemote h _luMsg luAuthor mname $maybe name <- mname diff --git a/th/models b/th/models index 046b5ce..c78cfe6 100644 --- a/th/models +++ b/th/models @@ -554,13 +554,13 @@ RemoteDiscussion Message created UTCTime - source Text -- Pandoc Markdown - content Text -- HTML + source PandocMarkdown + content HTML parent MessageId Maybe root DiscussionId LocalMessage - author PersonId + author ActorId rest MessageId create OutboxItemId unlinkedParent FedURI Maybe diff --git a/th/routes b/th/routes index 89d89da..94835a4 100644 --- a/th/routes +++ b/th/routes @@ -160,6 +160,8 @@ /groups/#GroupKeyHashid/outbox/#OutboxItemKeyHashid GroupOutboxItemR GET /groups/#GroupKeyHashid/followers GroupFollowersR GET +/groups/#GroupKeyHashid/messages/#LocalMessageKeyHashid GroupMessageR GET + /groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid GroupStampR GET ---- Repo -------------------------------------------------------------------- @@ -180,6 +182,8 @@ /repos/#RepoKeyHashid/commits-by/#Text RepoBranchCommitsR GET /repos/#RepoKeyHashid/commits/#Text RepoCommitR GET +/repos/#RepoKeyHashid/messages/#LocalMessageKeyHashid RepoMessageR GET + /new-repo RepoNewR GET POST /repos/#RepoKeyHashid/delete RepoDeleteR POST /repos/#RepoKeyHashid/edit RepoEditR GET POST @@ -203,6 +207,8 @@ /decks/#DeckKeyHashid/tree DeckTreeR GET +/decks/#DeckKeyHashid/messages/#LocalMessageKeyHashid DeckMessageR GET + /new-deck DeckNewR GET POST /decks/#DeckKeyHashid/delete DeckDeleteR POST /decks/#DeckKeyHashid/edit DeckEditR GET POST @@ -250,6 +256,8 @@ /looms/#LoomKeyHashid/followers LoomFollowersR GET /looms/#LoomKeyHashid/cloths LoomClothsR GET +/looms/#LoomKeyHashid/messages/#LocalMessageKeyHashid LoomMessageR GET + /new-loom LoomNewR GET POST -- /looms/#LoomKeyHashid/delete LoomDeleteR POST -- /looms/#LoomKeyHashid/edit LoomEditR GET POST diff --git a/vervis.cabal b/vervis.cabal index 6f5b0ae..c04f880 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -142,13 +142,13 @@ library Vervis.Data.Actor Vervis.Data.Collab + Vervis.Data.Discussion Vervis.Data.Ticket - Vervis.Discussion --Vervis.Federation Vervis.Federation.Auth Vervis.Federation.Collab - --Vervis.Federation.Discussion + Vervis.Federation.Discussion --Vervis.Federation.Offer --Vervis.Federation.Push Vervis.Federation.Ticket @@ -209,6 +209,7 @@ library Vervis.Persist.Actor Vervis.Persist.Collab + Vervis.Persist.Discussion Vervis.Persist.Ticket Vervis.Query