C2S, S2S: Re-enable createNoteC and personCreateNoteF
This commit is contained in:
fr33domlover
parent
8424c76de7
commit
71bceec18b
25 changed files with 656 additions and 579 deletions
44
migrations/504_2022-10-16_message_author.model
Normal file
44
migrations/504_2022-10-16_message_author.model
Normal file
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
return comment
|
||||
verifyNothingE muTarget "'target' not supported in Create Note"
|
||||
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
-- 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
|
||||
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
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients found"
|
||||
|
||||
verifyContextRecip (Right (ObjURI h _)) _ remoteRecips =
|
||||
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
|
||||
messageHash <- encodeKeyHashid messageID
|
||||
let luId = encodeRouteLocal $ PersonMessageR senderHash messageHash
|
||||
note' = note
|
||||
{ AP.noteId = Just luId
|
||||
, AP.notePublished = Just now
|
||||
, AP.noteAudience = emptyAudience
|
||||
}
|
||||
, createTarget = Nothing
|
||||
}
|
||||
}
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
152
src/Vervis/Data/Discussion.hs
Normal file
152
src/Vervis/Data/Discussion.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
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
|
||||
|
||||
(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"
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -13,16 +13,13 @@
|
|||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
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
|
||||
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)
|
||||
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"
|
||||
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 msgID
|
||||
|
||||
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
|
||||
-- | 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 "Local parent belongs to a different discussion"
|
||||
throwE "Remote parent belongs to a different discussion"
|
||||
return mid
|
||||
Nothing -> return $ Right p
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -18,13 +18,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
^{actorLinkW author}
|
||||
<span .time>
|
||||
$case author
|
||||
$of MessageTreeNodeLocal lmid pid
|
||||
<a href=@{PersonMessageR (hashPerson pid) (encodeHid lmid)}>
|
||||
$of MessageTreeNodeLocal lmid authorByKey _ _
|
||||
<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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<a href=@{PersonR $ hashPerson pid}>
|
||||
~#{keyHashidText $ hashPerson pid}
|
||||
<span>
|
||||
./people/#{keyHashidText $ hashPerson pid}
|
||||
$of MessageTreeNodeLocal _lmid authorByKey code name
|
||||
<a href=@{renderLocalActor $ hashAuthor authorByKey}>
|
||||
code name
|
||||
$of MessageTreeNodeRemote h _luMsg luAuthor mname
|
||||
<a href="#{renderObjURI $ ObjURI h luAuthor}">
|
||||
$maybe name <- mname
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue