C2S, S2S: Re-enable createNoteC and personCreateNoteF

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

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
+    -> Actor
-    -> Audience URIMode
+    -> 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
+createNoteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action note muTarget = do
-    error "Temporarily disabled"
 
-    {-
+    -- Check input
-    senderHash <- encodeKeyHashid pidUser
+    verifyNothingE maybeCap "Capability not needed"
-    noteData@(muParent, mparent, uContext, context, source, content) <- checkNote senderHash note
+    Comment maybeParent topic source content <- do
-    verifyNothingE muTarget "Create Note has 'target'"
+        (authorPersonID, comment) <- parseNewLocalComment note
-    ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
+        unless (authorPersonID == senderPersonID) $
-        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) $
             throwE "Note attributed to someone else"
-        verifyNothingE mpublished "Note specifies published"
+        return comment
-        uContext <- fromMaybeE muContext "Note without context"
+    verifyNothingE muTarget "'target' not supported in Create Note"
-        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?"
 
-    checkFederation remoteRecips = do
+    senderHash <- encodeKeyHashid senderPersonID
-        federation <- asksSite $ appFederation . appSettings
+    now <- liftIO getCurrentTime
-        unless (federation || null remoteRecips) $
-            throwE "Federation disabled, but remote recipients found"
 
-    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
+            throwE "Topic is remote but no recipients of that host are listed"
-                "Context is remote but no recipients of that host are listed"
+    verifyTopicAddressed (Left topic) = do
-    verifyContextRecip (Left (NoteTopicTicket deckID _)) localRecips _ = do
+        actorByHash <- hashLocalActor $ commentTopicManagingActor topic
-        deckHash <- encodeKeyHashid deckID
+        unless (actorIsAddressed localRecips actorByHash) $
-        let verify = do
+            throwE "Local topic's managing actor isn't listed as a recipient"
-                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"
 
     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
+        messageHash <- encodeKeyHashid messageID
-        lmkhid <- encodeKeyHashid lmid
+        let luId = encodeRouteLocal $ PersonMessageR senderHash messageHash
-        let luAttrib = encodeRouteLocal $ PersonR senderHash
+            note' = note
-            create = Doc hLocal Activity
+                { AP.noteId        = Just luId
-                { activityId       = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid
+                , AP.notePublished = Just now
-                , activityActor    = luAttrib
+                , AP.noteAudience  = emptyAudience
-                , 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
-                    }
                 }
-        update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
+        return action { AP.actionSpecific = AP.CreateActivity $ AP.Create (AP.CreateNote hLocal note') Nothing }
-        return create
--}
-
-checkFederation remoteRecips = do
-    federation <- asksSite $ appFederation . appSettings
-    unless (federation || null remoteRecips) $
-        throwE "Federation disabled, but remote recipients found"
 
 createPatchTrackerC
     :: Entity Person

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

src/Vervis/Data/Discussion.hs

@@ -0,0 +1,152 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

src/Vervis/Federation/Discussion.hs

@@ -14,9 +14,9 @@
  -}
 
 module Vervis.Federation.Discussion
-    ( sharerCreateNoteF
+    ( personCreateNoteF
-    , projectCreateNoteF
+    --, deckCreateNoteF
-    , repoCreateNoteF
+    --, 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
+    -> PandocMarkdown
-    -> Text
+    -> 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
+personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
-    error "sharerCreateF temporarily disabled"
 
+    -- 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
+            Right uContext -> do
-    case context of
+                checkContextParent uContext maybeParent
-        Right uContext -> runDBExcept $ do
+                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
-            personRecip <- lift $ do
+
-                sid <- getKeyBy404 $ UniqueSharer shrRecip
+            Left (CommentTopicTicket deckID taskID) -> do
-                getValBy404 $ UniquePersonIdent sid
+                (_, _, Entity _ ticket, _, _) <- do
-            checkContextParent uContext mparent
+                    mticket <- lift $ getTicket deckID taskID
-            mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
+                    fromMaybeE mticket "Context: No such deck-ticket"
-            return $
+                let did = ticketDiscuss ticket
-                case mractid of
+                _ <- traverse (getMessageParent did) maybeParent
-                    Nothing -> "I already have this activity in my inbox, doing nothing"
+                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
-                    Just _ -> "Context is remote, so just inserting to my inbox"
+
-        Left (NoteContextSharerTicket shr talid patch) -> do
+            Left (CommentTopicCloth loomID clothID) -> do
-            mremotesHttp <- runDBExcept $ do
+                (_, _, Entity _ ticket, _, _, _) <- do
-                (sid, pid, ibid) <- lift getRecip404
+                    mticket <- lift $ getCloth loomID clothID
-                (tal, lt, followers) <-
+                    fromMaybeE mticket "Context: No such loom-cloth"
-                    if patch
+                let did = ticketDiscuss ticket
-                        then do
+                _ <- traverse (getMessageParent did) maybeParent
-                            (Entity _ tal, Entity _ lt, _, _, _, _) <- do
+                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
-                                mticket <- lift $ getSharerProposal shr talid
+
-                                fromMaybeE mticket "Context: No such sharer-patch"
+    return $
-                            return (tal, lt, LocalPersonCollectionSharerProposalFollowers)
+        case mractid of
-                        else do
+            Nothing -> "I already have this activity in my inbox, doing nothing"
-                            (Entity _ tal, Entity _ lt, _, _, _) <- do
+            Just _ -> "Inserted Create{Note} to my inbox"
-                                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"
     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

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)

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

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

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
 

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

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 ->
+                    AP.CreateNote _ note ->
-                        (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note
+                        (,Nothing) <$> personCreateNoteF now recipPersonHash author body mfwd luActivity note
-                    CreateTicket _ ticket ->
+                    _ -> return ("Unsupported create object type for people", Nothing)
-                        (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget
+            {-
-                    _ -> return ("Unsupported create object type for sharers", 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
-                    {-
+                    AP.CreateNote _ note ->
-                    CreateNote _ note ->
+                        run createNoteC note mtarget
-                        createNoteC eperson sharer summary audience 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
+getPersonMessageR personHash localMessageHash =
-    personID <- decodeKeyHashid404 personHash
+    serveMessage personHash localMessageHash
-    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
 
 postPersonFollowR :: KeyHashid Person -> Handler ()
 postPersonFollowR _ = error "Temporarily disabled"

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

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)

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

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")

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

src/Vervis/Persist/Discussion.hs

@@ -13,16 +13,13 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-module Vervis.Discussion
+module Vervis.Persist.Discussion
     ( MessageTreeNodeAuthor (..)
     , MessageTreeNode (..)
     , getDiscussionTree
-    , getRepliesCollection
+    --, getRepliesCollection
-    , NoteTopic (..)
-    , NoteParent (..)
-    , parseNoteContext
-    , parseNoteParent
     , 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
+    l <- select $ from $ \ (lm `InnerJoin` m `InnerJoin` a) -> do
-        on $ lm ^. LocalMessageRest ==. m ^. MessageId
+            on $ lm ^. LocalMessageAuthor ==. a ^. ActorId
-        where_ $ m ^. MessageRoot ==. val did
+            on $ lm ^. LocalMessageRest ==. m ^. MessageId
-        return (m, lm ^. LocalMessageId, lm ^. LocalMessageAuthor)
+            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) =
+    mklocal (Entity mid m, Value lmid, Value aid, Value name) = do
-        MessageTreeNode mid m $ MessageTreeNodeLocal lmid pid
+        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
+getMessage
-    = NoteTopicTicket DeckId TicketDeckId
+    :: LocalActorBy Key
-    | NoteTopicCloth LoomId TicketLoomId
+    -> LocalMessageId
-    deriving Eq
+    -> 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) =
+getLocalParentMessageId
-    NoteTopicTicket
+    :: DiscussionId
-        <$> decodeKeyHashidE dkhid "Note context invalid dkhid"
+    -> (LocalActorBy Key, LocalMessageId)
-        <*> decodeKeyHashidE ltkhid "Note context invalid ltkhid"
+    -> ExceptT Text AppDB MessageId
-parseNoteTopic (ClothR lkhid ltkhid) =
+getLocalParentMessageId discussionID (authorByKey, localMsgID) = do
-    NoteTopicCloth
+    (_, _, _, Entity msgID msg) <- getMessage authorByKey localMsgID
-        <$> decodeKeyHashidE lkhid "Note context invalid lkhid"
+    unless (messageRoot msg == discussionID) $
-        <*> 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) $
         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

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

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

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
+    , noteSource    :: PandocMarkdown
-    , noteContent   :: Text
+    , 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)

templates/discussion/widget/message.hamlet

@@ -18,13 +18,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       ^{actorLinkW author}
     <span .time>
       $case author
-        $of MessageTreeNodeLocal lmid pid
+        $of MessageTreeNodeLocal lmid authorByKey _ _
-          <a href=@{PersonMessageR (hashPerson pid) (encodeHid lmid)}>
+          <a href=@{messageRoute (hashAuthor authorByKey) (encodeHid lmid)}>
             #{showTime $ messageCreated msg}
         $of MessageTreeNodeRemote h luMsg _luAuthor _mname
           <a href="#{renderObjURI $ ObjURI h luMsg}"}>
             #{showTime $ messageCreated msg}
     <span .content>
-      ^{showContent $ messageContent msg}
+      ^{markupHTML $ messageContent msg}
     <span .reply>
       <a href=@{reply msgid}>reply

templates/widget/actor-link.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -13,11 +13,9 @@ $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 $case actor
-  $of MessageTreeNodeLocal _lmid pid
+  $of MessageTreeNodeLocal _lmid authorByKey code name
-    <a href=@{PersonR $ hashPerson pid}>
+    <a href=@{renderLocalActor $ hashAuthor authorByKey}>
-      ~#{keyHashidText $ hashPerson pid}
+      code name
-    <span>
-      ./people/#{keyHashidText $ hashPerson pid}
   $of MessageTreeNodeRemote h _luMsg luAuthor mname
     <a href="#{renderObjURI $ ObjURI h luAuthor}">
       $maybe name <- mname

th/models

@@ -554,13 +554,13 @@ RemoteDiscussion
 
 Message
     created UTCTime
-    source  Text               -- Pandoc Markdown
+    source  PandocMarkdown
-    content Text               -- HTML
+    content HTML
     parent  MessageId    Maybe
     root    DiscussionId
 
 LocalMessage
-    author         PersonId
+    author         ActorId
     rest           MessageId
     create         OutboxItemId
     unlinkedParent FedURI    Maybe

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

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