C2S, S2S: Re-enable createNoteC and personCreateNoteF
This commit is contained in:
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
|
--, addBundleC
|
||||||
, applyC
|
, applyC
|
||||||
--, noteC
|
--, noteC
|
||||||
--, createNoteC
|
, createNoteC
|
||||||
, createPatchTrackerC
|
, createPatchTrackerC
|
||||||
, createRepositoryC
|
, createRepositoryC
|
||||||
, createTicketTrackerC
|
, createTicketTrackerC
|
||||||
|
@ -101,8 +101,8 @@ import Vervis.Cloth
|
||||||
import Vervis.Darcs
|
import Vervis.Darcs
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.Data.Collab
|
import Vervis.Data.Collab
|
||||||
|
import Vervis.Data.Discussion
|
||||||
import Vervis.Data.Ticket
|
import Vervis.Data.Ticket
|
||||||
import Vervis.Web.Delivery
|
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Fetch
|
import Vervis.Fetch
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
|
@ -115,6 +115,7 @@ import Vervis.Model.Ticket
|
||||||
import Vervis.Path
|
import Vervis.Path
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
import Vervis.Persist.Collab
|
import Vervis.Persist.Collab
|
||||||
|
import Vervis.Persist.Discussion
|
||||||
import Vervis.Persist.Ticket
|
import Vervis.Persist.Ticket
|
||||||
import Vervis.Recipient
|
import Vervis.Recipient
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
|
@ -122,6 +123,7 @@ import Vervis.Settings
|
||||||
import Vervis.Query
|
import Vervis.Query
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
import Vervis.WorkItem
|
import Vervis.WorkItem
|
||||||
|
import Vervis.Web.Delivery
|
||||||
import Vervis.Web.Repo
|
import Vervis.Web.Repo
|
||||||
|
|
||||||
verifyResourceAddressed
|
verifyResourceAddressed
|
||||||
|
@ -736,6 +738,7 @@ parseComment luParent = do
|
||||||
<*> decodeKeyHashidE messageHash "Invalid local message hashid"
|
<*> decodeKeyHashidE messageHash "Invalid local message hashid"
|
||||||
_ -> throwE "Not a local message route"
|
_ -> throwE "Not a local message route"
|
||||||
|
|
||||||
|
{-
|
||||||
noteC
|
noteC
|
||||||
:: Entity Person
|
:: Entity Person
|
||||||
-> Note URIMode
|
-> Note URIMode
|
||||||
|
@ -756,140 +759,112 @@ noteC eperson@(Entity personID person) note = do
|
||||||
\ commented.
|
\ commented.
|
||||||
|]
|
|]
|
||||||
createNoteC eperson (Just summary) (noteAudience note) note Nothing
|
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
|
createNoteC
|
||||||
:: Entity Person
|
:: 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
|
-> Note URIMode
|
||||||
-> Maybe FedURI
|
-> Maybe FedURI
|
||||||
-> ExceptT Text Handler OutboxItemId
|
-> 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"
|
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
|
senderHash <- encodeKeyHashid senderPersonID
|
||||||
return (muParent, mparent, uContext, context, source, content)
|
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
|
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
|
verifyTopicAddressed (Right (ObjURI h _)) =
|
||||||
federation <- asksSite $ appFederation . appSettings
|
|
||||||
unless (federation || null remoteRecips) $
|
|
||||||
throwE "Federation disabled, but remote recipients found"
|
|
||||||
|
|
||||||
verifyContextRecip (Right (ObjURI h _)) _ remoteRecips =
|
|
||||||
unless (any ((== h) . fst) remoteRecips) $
|
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
|
getTopicAndParent (Left context) mparent = do
|
||||||
discussionID <-
|
discussionID <-
|
||||||
case context of
|
case context of
|
||||||
NoteTopicTicket deckID ticketID -> do
|
CommentTopicTicket deckID ticketID -> do
|
||||||
(_, _, Entity _ t, _, _) <- do
|
(_, _, Entity _ t, _, _) <- do
|
||||||
mticket <- lift $ getTicket deckID ticketID
|
mticket <- lift $ getTicket deckID ticketID
|
||||||
fromMaybeE mticket "Note context no such local deck-hosted ticket"
|
fromMaybeE mticket "Note context no such local deck-hosted ticket"
|
||||||
return $ ticketDiscuss t
|
return $ ticketDiscuss t
|
||||||
NoteTopicCloth loomID clothID -> do
|
CommentTopicCloth loomID clothID -> do
|
||||||
(_, _, Entity _ t, _, _, _) <- do
|
(_, _, Entity _ t, _, _, _) <- do
|
||||||
mcloth <- lift $ getCloth loomID clothID
|
mcloth <- lift $ getCloth loomID clothID
|
||||||
fromMaybeE mcloth "Note context no such local loom-hosted ticket"
|
fromMaybeE mcloth "Note context no such local loom-hosted ticket"
|
||||||
return $ ticketDiscuss t
|
return $ ticketDiscuss t
|
||||||
mmidParent <- for mparent $ \ parent ->
|
mmidParent <- for mparent $ \ parent ->
|
||||||
case parent of
|
case parent of
|
||||||
Left (personID, messageID) -> getLocalParentMessageId discussionID personID messageID
|
Left msg -> getLocalParentMessageId discussionID msg
|
||||||
Right (ObjURI hParent luParent) -> do
|
Right (ObjURI hParent luParent) -> do
|
||||||
mrm <- lift $ runMaybeT $ do
|
mrm <- lift $ runMaybeT $ do
|
||||||
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
||||||
|
@ -918,9 +893,9 @@ createNoteC (Entity pidUser personUser) summary audience note muTarget = do
|
||||||
let discussionID = remoteDiscussionDiscuss rd
|
let discussionID = remoteDiscussionDiscuss rd
|
||||||
meparent <- for mparent $ \ parent ->
|
meparent <- for mparent $ \ parent ->
|
||||||
case parent of
|
case parent of
|
||||||
Left (personID, messageID) -> do
|
Left msg -> do
|
||||||
when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
|
when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
|
||||||
Left <$> getLocalParentMessageId discussionID personID messageID
|
Left <$> getLocalParentMessageId discussionID msg
|
||||||
Right uParent@(ObjURI hParent luParent) -> do
|
Right uParent@(ObjURI hParent luParent) -> do
|
||||||
mrm <- lift $ runMaybeT $ do
|
mrm <- lift $ runMaybeT $ do
|
||||||
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
||||||
|
@ -948,7 +923,7 @@ createNoteC (Entity pidUser personUser) summary audience note muTarget = do
|
||||||
, messageRoot = did
|
, messageRoot = did
|
||||||
}
|
}
|
||||||
insert LocalMessage
|
insert LocalMessage
|
||||||
{ localMessageAuthor = pidUser
|
{ localMessageAuthor = personActor senderPerson
|
||||||
, localMessageRest = mid
|
, localMessageRest = mid
|
||||||
, localMessageCreate = obiidCreate
|
, localMessageCreate = obiidCreate
|
||||||
, localMessageUnlinkedParent =
|
, localMessageUnlinkedParent =
|
||||||
|
@ -957,40 +932,17 @@ createNoteC (Entity pidUser personUser) summary audience note muTarget = do
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
insertCreateToOutbox now senderHash blinded (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do
|
prepareCreate now senderHash messageID = do
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
hLocal <- asksSite siteInstanceHost
|
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
|
return action { AP.actionSpecific = AP.CreateActivity $ AP.Create (AP.CreateNote hLocal note') 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"
|
|
||||||
|
|
||||||
createPatchTrackerC
|
createPatchTrackerC
|
||||||
:: Entity Person
|
:: Entity Person
|
||||||
|
|
|
@ -19,11 +19,13 @@ module Vervis.Data.Actor
|
||||||
, activityRoute
|
, activityRoute
|
||||||
, stampRoute
|
, stampRoute
|
||||||
, parseStampRoute
|
, parseStampRoute
|
||||||
|
, localActorID
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Database.Persist.Types
|
||||||
|
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Yesod.ActivityPub
|
import Yesod.ActivityPub
|
||||||
|
@ -96,3 +98,9 @@ parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i)
|
||||||
parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i)
|
parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i)
|
||||||
parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i)
|
parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i)
|
||||||
parseStampRoute _ = Nothing
|
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
|
module Vervis.Federation.Discussion
|
||||||
( sharerCreateNoteF
|
( personCreateNoteF
|
||||||
, projectCreateNoteF
|
--, deckCreateNoteF
|
||||||
, repoCreateNoteF
|
--, loomCreateNoteF
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -54,6 +54,7 @@ import Database.Persist.JSON
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Network.HTTP.Digest
|
import Network.HTTP.Digest
|
||||||
import Web.ActivityPub hiding (ActorLocal (..))
|
import Web.ActivityPub hiding (ActorLocal (..))
|
||||||
|
import Web.Text
|
||||||
import Yesod.ActivityPub
|
import Yesod.ActivityPub
|
||||||
import Yesod.FedURI
|
import Yesod.FedURI
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
|
@ -65,63 +66,18 @@ import Database.Persist.Local
|
||||||
import Yesod.Persist.Local
|
import Yesod.Persist.Local
|
||||||
|
|
||||||
import Vervis.ActivityPub
|
import Vervis.ActivityPub
|
||||||
|
import Vervis.Cloth
|
||||||
|
import Vervis.Data.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Federation.Auth
|
import Vervis.Federation.Auth
|
||||||
import Vervis.Federation.Util
|
import Vervis.Federation.Util
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
|
import Vervis.Persist.Discussion
|
||||||
import Vervis.Recipient
|
import Vervis.Recipient
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
import Vervis.Ticket
|
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
|
-- | 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
|
-- this comment before, return the database ID of the newly created cached
|
||||||
|
@ -130,8 +86,8 @@ insertToDiscussion
|
||||||
:: RemoteAuthor
|
:: RemoteAuthor
|
||||||
-> LocalURI
|
-> LocalURI
|
||||||
-> UTCTime
|
-> UTCTime
|
||||||
-> Text
|
-> PandocMarkdown
|
||||||
-> Text
|
-> HTML
|
||||||
-> DiscussionId
|
-> DiscussionId
|
||||||
-> Maybe (Either MessageId FedURI)
|
-> Maybe (Either MessageId FedURI)
|
||||||
-> RemoteActivityId
|
-> RemoteActivityId
|
||||||
|
@ -207,121 +163,58 @@ updateOrphans author luNote did mid = do
|
||||||
m E.^. MessageRoot `op` E.val did
|
m E.^. MessageRoot `op` E.val did
|
||||||
return (rm E.^. RemoteMessageId, m E.^. MessageId)
|
return (rm E.^. RemoteMessageId, m E.^. MessageId)
|
||||||
|
|
||||||
sharerCreateNoteF
|
personCreateNoteF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> PersonId
|
-> KeyHashid Person
|
||||||
-> RemoteAuthor
|
-> RemoteAuthor
|
||||||
-> ActivityBody
|
-> ActivityBody
|
||||||
-> Maybe (LocalRecipientSet, ByteString)
|
-> Maybe (RecipientRoutes, ByteString)
|
||||||
-> LocalURI
|
-> LocalURI
|
||||||
-> Note URIMode
|
-> Note URIMode
|
||||||
-> ExceptT Text Handler Text
|
-> 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
|
||||||
|
|
||||||
|
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 $
|
return $
|
||||||
case mractid of
|
case mractid of
|
||||||
Nothing -> "I already have this activity in my inbox, doing nothing"
|
Nothing -> "I already have this activity in my inbox, doing nothing"
|
||||||
Just _ -> "Context is remote, so just inserting to my inbox"
|
Just _ -> "Inserted Create{Note} 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"
|
|
||||||
where
|
where
|
||||||
getRecip404 = do
|
|
||||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
|
||||||
Entity pid p <- getBy404 $ UniquePersonIdent sid
|
|
||||||
return (sid, pid, personInbox p)
|
|
||||||
checkContextParent (ObjURI hContext luContext) mparent = do
|
checkContextParent (ObjURI hContext luContext) mparent = do
|
||||||
mdid <- lift $ runMaybeT $ do
|
mdid <- lift $ runMaybeT $ do
|
||||||
iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
|
iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
|
||||||
|
@ -330,9 +223,9 @@ sharerCreateNoteF now pidRecip author body mfwd luCreate note = do
|
||||||
return $ remoteDiscussionDiscuss rd
|
return $ remoteDiscussionDiscuss rd
|
||||||
for_ mparent $ \ parent ->
|
for_ mparent $ \ parent ->
|
||||||
case parent of
|
case parent of
|
||||||
Left (shrP, lmidP) -> do
|
Left msg -> do
|
||||||
did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
|
did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
|
||||||
void $ getLocalParentMessageId did shrP lmidP
|
void $ getLocalParentMessageId did msg
|
||||||
Right (ObjURI hParent luParent) -> do
|
Right (ObjURI hParent luParent) -> do
|
||||||
mrm <- lift $ runMaybeT $ do
|
mrm <- lift $ runMaybeT $ do
|
||||||
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
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"
|
did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
|
||||||
unless (messageRoot m == did) $
|
unless (messageRoot m == did) $
|
||||||
throwE "Remote parent belongs to a different discussion"
|
throwE "Remote parent belongs to a different discussion"
|
||||||
-}
|
|
||||||
|
|
||||||
|
{-
|
||||||
projectCreateNoteF
|
projectCreateNoteF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> KeyHashid Project
|
-> KeyHashid Project
|
||||||
|
@ -356,51 +249,9 @@ projectCreateNoteF
|
||||||
-> Note URIMode
|
-> Note URIMode
|
||||||
-> ExceptT Text Handler Text
|
-> ExceptT Text Handler Text
|
||||||
projectCreateNoteF now deckRecip author body mfwd luCreate note = do
|
projectCreateNoteF now deckRecip author body mfwd luCreate note = do
|
||||||
error "projectCreateNoteF temporarily disabled"
|
|
||||||
|
|
||||||
|
|
||||||
{-
|
|
||||||
|
|
||||||
|
|
||||||
(luNote, published, context, mparent, source, content) <- checkNote note
|
(luNote, published, context, mparent, source, content) <- checkNote note
|
||||||
case context of
|
case context of
|
||||||
Right _ -> return "Not using; context isn't local"
|
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
|
Left (NoteContextProjectTicket shr prj ltid) -> do
|
||||||
mremotesHttp <- runDBExcept $ do
|
mremotesHttp <- runDBExcept $ do
|
||||||
(jid, ibid) <- lift getProjectRecip404
|
(jid, ibid) <- lift getProjectRecip404
|
||||||
|
@ -450,6 +301,7 @@ projectCreateNoteF now deckRecip author body mfwd luCreate note = do
|
||||||
return (jid, actorInbox a)
|
return (jid, actorInbox a)
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-
|
||||||
repoCreateNoteF
|
repoCreateNoteF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> KeyHashid Repo
|
-> KeyHashid Repo
|
||||||
|
@ -460,52 +312,9 @@ repoCreateNoteF
|
||||||
-> Note URIMode
|
-> Note URIMode
|
||||||
-> ExceptT Text Handler Text
|
-> ExceptT Text Handler Text
|
||||||
repoCreateNoteF now repoRecip author body mfwd luCreate note = do
|
repoCreateNoteF now repoRecip author body mfwd luCreate note = do
|
||||||
error "repoCreateNoteF temporarily disabled"
|
|
||||||
|
|
||||||
|
|
||||||
{-
|
|
||||||
|
|
||||||
|
|
||||||
(luNote, published, context, mparent, source, content) <- checkNote note
|
(luNote, published, context, mparent, source, content) <- checkNote note
|
||||||
case context of
|
case context of
|
||||||
Right _ -> return "Not using; context isn't local"
|
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 _ _ _) ->
|
Left (NoteContextProjectTicket _ _ _) ->
|
||||||
return "Context is a project-ticket, ignoring activity"
|
return "Context is a project-ticket, ignoring activity"
|
||||||
Left (NoteContextRepoProposal shr rp ltid) -> do
|
Left (NoteContextRepoProposal shr rp ltid) -> do
|
||||||
|
|
|
@ -848,6 +848,8 @@ instance YesodBreadcrumbs App where
|
||||||
GroupOutboxItemR g i -> (keyHashidText i, Just $ GroupOutboxR g)
|
GroupOutboxItemR g i -> (keyHashidText i, Just $ GroupOutboxR g)
|
||||||
GroupFollowersR g -> ("Followers", Just $ GroupR 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)
|
GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g)
|
||||||
|
|
||||||
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
|
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
|
||||||
|
@ -868,6 +870,8 @@ instance YesodBreadcrumbs App where
|
||||||
RepoBranchCommitsR r b -> ("Branch " <> b <> " Commits", Just $ RepoR r)
|
RepoBranchCommitsR r b -> ("Branch " <> b <> " Commits", Just $ RepoR r)
|
||||||
RepoCommitR r c -> (c, Just $ RepoCommitsR r)
|
RepoCommitR r c -> (c, Just $ RepoCommitsR r)
|
||||||
|
|
||||||
|
RepoMessageR r m -> ("Message #" <> keyHashidText m, Just $ RepoR r)
|
||||||
|
|
||||||
RepoNewR -> ("New Repo", Just HomeR)
|
RepoNewR -> ("New Repo", Just HomeR)
|
||||||
RepoDeleteR r -> ("", Nothing)
|
RepoDeleteR r -> ("", Nothing)
|
||||||
RepoEditR r -> ("Edit", Just $ RepoR r)
|
RepoEditR r -> ("Edit", Just $ RepoR r)
|
||||||
|
@ -889,6 +893,8 @@ instance YesodBreadcrumbs App where
|
||||||
|
|
||||||
DeckTreeR d -> ("Tree", Just $ DeckTicketsR d)
|
DeckTreeR d -> ("Tree", Just $ DeckTicketsR d)
|
||||||
|
|
||||||
|
DeckMessageR d m -> ("Message #" <> keyHashidText m, Just $ DeckR d)
|
||||||
|
|
||||||
DeckNewR -> ("New Ticket Tracker", Just HomeR)
|
DeckNewR -> ("New Ticket Tracker", Just HomeR)
|
||||||
DeckDeleteR _ -> ("", Nothing)
|
DeckDeleteR _ -> ("", Nothing)
|
||||||
DeckEditR d -> ("Edit", Just $ DeckR d)
|
DeckEditR d -> ("Edit", Just $ DeckR d)
|
||||||
|
@ -917,6 +923,8 @@ instance YesodBreadcrumbs App where
|
||||||
LoomFollowersR l -> ("Followers", Just $ LoomR l)
|
LoomFollowersR l -> ("Followers", Just $ LoomR l)
|
||||||
LoomClothsR l -> ("Merge Requests", 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)
|
LoomNewR -> ("New Patch Tracker", Just HomeR)
|
||||||
LoomFollowR _ -> ("", Nothing)
|
LoomFollowR _ -> ("", Nothing)
|
||||||
LoomUnfollowR _ -> ("", Nothing)
|
LoomUnfollowR _ -> ("", Nothing)
|
||||||
|
|
|
@ -106,7 +106,7 @@ import Vervis.ActivityPub
|
||||||
import Vervis.API
|
import Vervis.API
|
||||||
import Vervis.Cloth
|
import Vervis.Cloth
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.Discussion
|
import Vervis.Persist.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
|
|
@ -24,6 +24,8 @@ module Vervis.Handler.Deck
|
||||||
|
|
||||||
, getDeckTreeR
|
, getDeckTreeR
|
||||||
|
|
||||||
|
, getDeckMessageR
|
||||||
|
|
||||||
, getDeckNewR
|
, getDeckNewR
|
||||||
, postDeckNewR
|
, postDeckNewR
|
||||||
, postDeckDeleteR
|
, postDeckDeleteR
|
||||||
|
@ -313,6 +315,9 @@ getDeckTreeR _ = error "Temporarily disabled"
|
||||||
defaultLayout $ ticketTreeDW shr prj summaries deps
|
defaultLayout $ ticketTreeDW shr prj summaries deps
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
getDeckMessageR :: KeyHashid Deck -> KeyHashid LocalMessage -> Handler Html
|
||||||
|
getDeckMessageR _ _ = notFound
|
||||||
|
|
||||||
getDeckNewR :: Handler Html
|
getDeckNewR :: Handler Html
|
||||||
getDeckNewR = do
|
getDeckNewR = do
|
||||||
((_result, widget), enctype) <- runFormPost newProjectForm
|
((_result, widget), enctype) <- runFormPost newProjectForm
|
||||||
|
|
|
@ -20,6 +20,7 @@ module Vervis.Handler.Group
|
||||||
, getGroupOutboxR
|
, getGroupOutboxR
|
||||||
, getGroupOutboxItemR
|
, getGroupOutboxItemR
|
||||||
, getGroupFollowersR
|
, getGroupFollowersR
|
||||||
|
, getGroupMessageR
|
||||||
|
|
||||||
, getGroupStampR
|
, getGroupStampR
|
||||||
|
|
||||||
|
@ -49,6 +50,7 @@ import Data.Text (Text)
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Database.Persist
|
import Database.Persist
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
|
import Yesod.Core
|
||||||
import Yesod.Core.Content (TypedContent)
|
import Yesod.Core.Content (TypedContent)
|
||||||
import Yesod.Persist.Core
|
import Yesod.Persist.Core
|
||||||
|
|
||||||
|
@ -138,6 +140,10 @@ getGroupOutboxItemR = getOutboxItem GroupOutboxItemR groupActor
|
||||||
getGroupFollowersR :: KeyHashid Group -> Handler TypedContent
|
getGroupFollowersR :: KeyHashid Group -> Handler TypedContent
|
||||||
getGroupFollowersR = getActorFollowersCollection GroupFollowersR groupActor
|
getGroupFollowersR = getActorFollowersCollection GroupFollowersR groupActor
|
||||||
|
|
||||||
|
getGroupMessageR
|
||||||
|
:: KeyHashid Group -> KeyHashid LocalMessage -> Handler TypedContent
|
||||||
|
getGroupMessageR _ _ = notFound
|
||||||
|
|
||||||
getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent
|
getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent
|
||||||
getGroupStampR = servePerActorKey groupActor LocalActorGroup
|
getGroupStampR = servePerActorKey groupActor LocalActorGroup
|
||||||
|
|
||||||
|
|
|
@ -22,6 +22,8 @@ module Vervis.Handler.Loom
|
||||||
, getLoomFollowersR
|
, getLoomFollowersR
|
||||||
, getLoomClothsR
|
, getLoomClothsR
|
||||||
|
|
||||||
|
, getLoomMessageR
|
||||||
|
|
||||||
, getLoomNewR
|
, getLoomNewR
|
||||||
, postLoomNewR
|
, postLoomNewR
|
||||||
, postLoomFollowR
|
, postLoomFollowR
|
||||||
|
@ -248,6 +250,10 @@ getLoomClothsR loomHash = selectRep $ do
|
||||||
here = LoomClothsR loomHash
|
here = LoomClothsR loomHash
|
||||||
encodeStrict = BL.toStrict . encode
|
encodeStrict = BL.toStrict . encode
|
||||||
|
|
||||||
|
getLoomMessageR
|
||||||
|
:: KeyHashid Loom -> KeyHashid LocalMessage -> Handler TypedContent
|
||||||
|
getLoomMessageR _ _ = notFound
|
||||||
|
|
||||||
getLoomNewR :: Handler Html
|
getLoomNewR :: Handler Html
|
||||||
getLoomNewR = do
|
getLoomNewR = do
|
||||||
((_result, widget), enctype) <- runFormPost newLoomForm
|
((_result, widget), enctype) <- runFormPost newLoomForm
|
||||||
|
|
|
@ -74,6 +74,7 @@ import Vervis.API
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.Federation.Auth
|
import Vervis.Federation.Auth
|
||||||
import Vervis.Federation.Collab
|
import Vervis.Federation.Collab
|
||||||
|
import Vervis.Federation.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
@ -84,6 +85,7 @@ import Vervis.Secure
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
import Vervis.Web.Actor
|
import Vervis.Web.Actor
|
||||||
|
import Vervis.Web.Discussion
|
||||||
import Vervis.Widget
|
import Vervis.Widget
|
||||||
import Vervis.Widget.Person
|
import Vervis.Widget.Person
|
||||||
|
|
||||||
|
@ -204,13 +206,13 @@ postPersonInboxR recipPersonHash = postInbox handle
|
||||||
Right (AddBundle patches) ->
|
Right (AddBundle patches) ->
|
||||||
sharerAddBundleF now shrRecip author body mfwd luActivity patches target
|
sharerAddBundleF now shrRecip author body mfwd luActivity patches target
|
||||||
_ -> return ("Unsupported add object type for sharers", Nothing)
|
_ -> return ("Unsupported add object type for sharers", Nothing)
|
||||||
CreateActivity (Create obj mtarget) ->
|
-}
|
||||||
|
AP.CreateActivity (AP.Create obj mtarget) ->
|
||||||
case obj of
|
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 ->
|
FollowActivity follow ->
|
||||||
(,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow
|
(,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow
|
||||||
-}
|
-}
|
||||||
|
@ -318,10 +320,8 @@ postPersonOutboxR personHash = do
|
||||||
AP.ApplyActivity apply -> run applyC apply
|
AP.ApplyActivity apply -> run applyC apply
|
||||||
AP.CreateActivity (AP.Create obj mtarget) ->
|
AP.CreateActivity (AP.Create obj mtarget) ->
|
||||||
case obj of
|
case obj of
|
||||||
{-
|
AP.CreateNote _ note ->
|
||||||
CreateNote _ note ->
|
run createNoteC note mtarget
|
||||||
createNoteC eperson sharer summary audience note mtarget
|
|
||||||
-}
|
|
||||||
AP.CreateTicketTracker detail mlocal ->
|
AP.CreateTicketTracker detail mlocal ->
|
||||||
run createTicketTrackerC detail mlocal mtarget
|
run createTicketTrackerC detail mlocal mtarget
|
||||||
AP.CreateRepository detail vcs mlocal ->
|
AP.CreateRepository detail vcs mlocal ->
|
||||||
|
@ -393,68 +393,8 @@ getSshKeyR personHash keyHash = do
|
||||||
|
|
||||||
getPersonMessageR
|
getPersonMessageR
|
||||||
:: KeyHashid Person -> KeyHashid LocalMessage -> Handler TypedContent
|
:: 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 :: KeyHashid Person -> Handler ()
|
||||||
postPersonFollowR _ = error "Temporarily disabled"
|
postPersonFollowR _ = error "Temporarily disabled"
|
||||||
|
|
|
@ -32,6 +32,8 @@ module Vervis.Handler.Repo
|
||||||
, getRepoBranchCommitsR
|
, getRepoBranchCommitsR
|
||||||
, getRepoCommitR
|
, getRepoCommitR
|
||||||
|
|
||||||
|
, getRepoMessageR
|
||||||
|
|
||||||
, getRepoNewR
|
, getRepoNewR
|
||||||
, postRepoNewR
|
, postRepoNewR
|
||||||
, postRepoDeleteR
|
, postRepoDeleteR
|
||||||
|
@ -427,6 +429,10 @@ getRepoCommitR repoHash ref = do
|
||||||
VCSDarcs -> getDarcsPatch repoHash ref
|
VCSDarcs -> getDarcsPatch repoHash ref
|
||||||
VCSGit -> getGitPatch repoHash ref
|
VCSGit -> getGitPatch repoHash ref
|
||||||
|
|
||||||
|
getRepoMessageR
|
||||||
|
:: KeyHashid Repo -> KeyHashid LocalMessage -> Handler TypedContent
|
||||||
|
getRepoMessageR _ _ = notFound
|
||||||
|
|
||||||
getRepoNewR :: Handler Html
|
getRepoNewR :: Handler Html
|
||||||
getRepoNewR = do
|
getRepoNewR = do
|
||||||
((_result, widget), enctype) <- runFormPost newRepoForm
|
((_result, widget), enctype) <- runFormPost newRepoForm
|
||||||
|
|
|
@ -139,7 +139,7 @@ import Yesod.Persist.Local
|
||||||
import Vervis.ActivityPub
|
import Vervis.ActivityPub
|
||||||
import Vervis.API
|
import Vervis.API
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.Discussion
|
import Vervis.Persist.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
--import Vervis.GraphProxy (ticketDepGraph)
|
--import Vervis.GraphProxy (ticketDepGraph)
|
||||||
|
|
|
@ -2773,6 +2773,31 @@ changes hLocal ctx =
|
||||||
, removeEntity "ForwarderDeck"
|
, removeEntity "ForwarderDeck"
|
||||||
-- 503
|
-- 503
|
||||||
, removeEntity "ForwarderLoom"
|
, 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
|
migrateDB
|
||||||
|
|
|
@ -676,3 +676,6 @@ model_497_sigkey = $(schema "497_2022-09-29_sigkey")
|
||||||
|
|
||||||
makeEntitiesMigration "498"
|
makeEntitiesMigration "498"
|
||||||
$(modelFile "migrations/498_2022-10-03_forwarder.model")
|
$(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
|
module Vervis.Persist.Actor
|
||||||
( getLocalActor
|
( getLocalActor
|
||||||
|
, getLocalActorEntity
|
||||||
, verifyLocalActivityExistsInDB
|
, verifyLocalActivityExistsInDB
|
||||||
, getRemoteActorURI
|
, getRemoteActorURI
|
||||||
, insertActor
|
, insertActor
|
||||||
|
@ -75,6 +76,21 @@ getLocalActor actorID = do
|
||||||
(Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l
|
(Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l
|
||||||
_ -> error "Multi-usage of an ActorId"
|
_ -> 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
|
verifyLocalActivityExistsInDB
|
||||||
:: MonadIO m
|
:: MonadIO m
|
||||||
=> LocalActorBy Key
|
=> LocalActorBy Key
|
||||||
|
|
|
@ -13,16 +13,13 @@
|
||||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Vervis.Discussion
|
module Vervis.Persist.Discussion
|
||||||
( MessageTreeNodeAuthor (..)
|
( MessageTreeNodeAuthor (..)
|
||||||
, MessageTreeNode (..)
|
, MessageTreeNode (..)
|
||||||
, getDiscussionTree
|
, getDiscussionTree
|
||||||
, getRepliesCollection
|
--, getRepliesCollection
|
||||||
, NoteTopic (..)
|
|
||||||
, NoteParent (..)
|
|
||||||
, parseNoteContext
|
|
||||||
, parseNoteParent
|
|
||||||
, getLocalParentMessageId
|
, getLocalParentMessageId
|
||||||
|
, getMessageParent
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -30,6 +27,7 @@ import Control.Applicative
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Trans.Class
|
import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
import Data.Graph.Inductive.Graph (mkGraph, lab')
|
import Data.Graph.Inductive.Graph (mkGraph, lab')
|
||||||
import Data.Graph.Inductive.PatriciaTree (Gr)
|
import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||||
import Data.Graph.Inductive.Query.DFS (dffWith)
|
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 qualified Database.Esqueleto as E
|
||||||
|
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Web.ActivityPub
|
|
||||||
import Yesod.ActivityPub
|
import Yesod.ActivityPub
|
||||||
import Yesod.FedURI
|
import Yesod.FedURI
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
import Yesod.MonadSite
|
import Yesod.MonadSite
|
||||||
|
|
||||||
|
import qualified Web.ActivityPub as AP
|
||||||
|
|
||||||
import Control.Monad.Trans.Except.Local
|
import Control.Monad.Trans.Except.Local
|
||||||
import Data.Tree.Local (sortForestOn)
|
import Data.Tree.Local (sortForestOn)
|
||||||
|
import Database.Persist.Local
|
||||||
|
|
||||||
|
import Vervis.Data.Actor
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
import Vervis.Model.Ident
|
||||||
|
import Vervis.Persist.Actor
|
||||||
|
import Vervis.Recipient
|
||||||
|
|
||||||
data MessageTreeNodeAuthor
|
data MessageTreeNodeAuthor
|
||||||
= MessageTreeNodeLocal LocalMessageId PersonId
|
= MessageTreeNodeLocal LocalMessageId (LocalActorBy Key) Text Text
|
||||||
| MessageTreeNodeRemote Host LocalURI LocalURI (Maybe Text)
|
| MessageTreeNodeRemote Host LocalURI LocalURI (Maybe Text)
|
||||||
|
|
||||||
data MessageTreeNode = MessageTreeNode
|
data MessageTreeNode = MessageTreeNode
|
||||||
|
@ -70,10 +74,16 @@ data MessageTreeNode = MessageTreeNode
|
||||||
getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]
|
getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]
|
||||||
getMessages getdid = runDB $ do
|
getMessages getdid = runDB $ do
|
||||||
did <- getdid
|
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
|
on $ lm ^. LocalMessageRest ==. m ^. MessageId
|
||||||
where_ $ m ^. MessageRoot ==. val did
|
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
|
r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` ra `InnerJoin` ro `InnerJoin` i `InnerJoin` ro2) -> do
|
||||||
on $ rm ^. RemoteMessageIdent ==. ro2 ^. RemoteObjectId
|
on $ rm ^. RemoteMessageIdent ==. ro2 ^. RemoteObjectId
|
||||||
on $ ro ^. RemoteObjectInstance ==. i ^. InstanceId
|
on $ ro ^. RemoteObjectInstance ==. i ^. InstanceId
|
||||||
|
@ -88,10 +98,30 @@ getMessages getdid = runDB $ do
|
||||||
, ro ^. RemoteObjectIdent
|
, ro ^. RemoteObjectIdent
|
||||||
, ra ^. RemoteActorName
|
, ra ^. RemoteActorName
|
||||||
)
|
)
|
||||||
return $ map mklocal l ++ map mkremote r
|
locals <- traverse mklocal l
|
||||||
|
let remotes = map mkremote r
|
||||||
|
return $ locals ++ remotes
|
||||||
where
|
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) =
|
mkremote (Entity mid m, Value h, Value luMsg, Value luAuthor, Value name) =
|
||||||
MessageTreeNode mid m $ MessageTreeNodeRemote h luMsg luAuthor name
|
MessageTreeNode mid m $ MessageTreeNodeRemote h luMsg luAuthor name
|
||||||
|
|
||||||
|
@ -121,6 +151,7 @@ sortByTime = sortForestOn $ messageCreated . mtnMessage
|
||||||
getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode)
|
getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode)
|
||||||
getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid
|
getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid
|
||||||
|
|
||||||
|
{-
|
||||||
getRepliesCollection :: Route App -> AppDB DiscussionId -> Handler TypedContent
|
getRepliesCollection :: Route App -> AppDB DiscussionId -> Handler TypedContent
|
||||||
getRepliesCollection here getDiscussionId404 = do
|
getRepliesCollection here getDiscussionId404 = do
|
||||||
(locals, remotes) <- runDB $ do
|
(locals, remotes) <- runDB $ do
|
||||||
|
@ -166,78 +197,65 @@ getRepliesCollection here getDiscussionId404 = do
|
||||||
localUri hashPerson encR encH (E.Value pid, E.Value lmid) =
|
localUri hashPerson encR encH (E.Value pid, E.Value lmid) =
|
||||||
encR $ PersonMessageR (hashPerson pid) (encH lmid)
|
encR $ PersonMessageR (hashPerson pid) (encH lmid)
|
||||||
remoteUri (E.Value h, E.Value lu) = ObjURI h lu
|
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"
|
throwE "Local parent belongs to a different discussion"
|
||||||
parseNoteTopic _ = throwE "Local context isn't a ticket/cloth route"
|
return msgID
|
||||||
|
|
||||||
parseNoteContext
|
-- | Given the parent specified by the Note we received, check if we already
|
||||||
:: (MonadSite m, SiteEnv m ~ App)
|
-- know and have this parent note in the DB, and whether the child and parent
|
||||||
=> FedURI
|
-- belong to the same discussion root.
|
||||||
-> ExceptT Text m (Either NoteTopic FedURI)
|
getMessageParent
|
||||||
parseNoteContext uContext = do
|
:: DiscussionId
|
||||||
let ObjURI hContext luContext = uContext
|
-> Either (LocalActorBy Key, LocalMessageId) FedURI
|
||||||
local <- hostIsLocal hContext
|
-> ExceptT Text AppDB (Either MessageId FedURI)
|
||||||
if local
|
getMessageParent did (Left msg) = Left <$> getLocalParentMessageId did msg
|
||||||
then Left <$> do
|
getMessageParent did (Right p@(ObjURI hParent luParent)) = do
|
||||||
route <-
|
mrm <- lift $ runMaybeT $ do
|
||||||
fromMaybeE
|
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
||||||
(decodeRouteLocal luContext)
|
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
|
||||||
"Local context isn't a valid route"
|
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
|
||||||
parseNoteTopic route
|
case mrm of
|
||||||
else return $ Right uContext
|
Just rm -> Left <$> do
|
||||||
|
let mid = remoteMessageRest rm
|
||||||
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
|
m <- lift $ getJust mid
|
||||||
unless (messageRoot m == did) $
|
unless (messageRoot m == did) $
|
||||||
throwE "Local parent belongs to a different discussion"
|
throwE "Remote parent belongs to a different discussion"
|
||||||
return mid
|
return mid
|
||||||
|
Nothing -> return $ Right p
|
|
@ -19,6 +19,7 @@ module Vervis.Web.Discussion
|
||||||
--, postTopReply
|
--, postTopReply
|
||||||
--, getReply
|
--, getReply
|
||||||
--, postReply
|
--, postReply
|
||||||
|
, serveMessage
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -45,25 +46,31 @@ import qualified Data.Text as T
|
||||||
import Data.Aeson.Encode.Pretty.ToEncoding
|
import Data.Aeson.Encode.Pretty.ToEncoding
|
||||||
import Database.Persist.JSON
|
import Database.Persist.JSON
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Web.ActivityPub
|
|
||||||
import Yesod.ActivityPub
|
import Yesod.ActivityPub
|
||||||
import Yesod.Auth.Unverified
|
import Yesod.Auth.Unverified
|
||||||
import Yesod.FedURI
|
import Yesod.FedURI
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
import Yesod.MonadSite
|
import Yesod.MonadSite
|
||||||
|
import Yesod.RenderSource
|
||||||
|
|
||||||
|
import qualified Web.ActivityPub as AP
|
||||||
|
|
||||||
|
import Data.Either.Local
|
||||||
import Database.Persist.Local
|
import Database.Persist.Local
|
||||||
import Yesod.Persist.Local
|
import Yesod.Persist.Local
|
||||||
|
|
||||||
import Vervis.API
|
import Vervis.API
|
||||||
import Vervis.Discussion
|
import Vervis.Data.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Form.Discussion
|
import Vervis.Form.Discussion
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Yesod.RenderSource
|
import Vervis.Persist.Actor
|
||||||
|
import Vervis.Persist.Discussion
|
||||||
|
import Vervis.Recipient
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
|
import Vervis.Ticket
|
||||||
import Vervis.Widget.Discussion
|
import Vervis.Widget.Discussion
|
||||||
|
|
||||||
getDiscussion
|
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"
|
Nothing -> error "noteC succeeded but no lmid found for obiid"
|
||||||
Just lmid -> redirect $ after lmid
|
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 qualified Data.Text as T (filter)
|
||||||
|
|
||||||
|
import Data.MediaType
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
|
import Web.Text
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
|
import Yesod.RenderSource
|
||||||
|
|
||||||
import Data.EventTime.Local
|
import Data.EventTime.Local
|
||||||
import Data.Time.Clock.Local ()
|
import Data.Time.Clock.Local ()
|
||||||
|
|
||||||
import Vervis.Discussion
|
import Vervis.Data.Discussion
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Data.MediaType
|
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Yesod.RenderSource
|
import Vervis.Persist.Discussion
|
||||||
|
import Vervis.Recipient
|
||||||
import Vervis.Settings (widgetFile)
|
import Vervis.Settings (widgetFile)
|
||||||
import Vervis.Widget.Person
|
import Vervis.Widget.Person
|
||||||
|
|
||||||
actorLinkW :: MessageTreeNodeAuthor -> Widget
|
actorLinkW :: MessageTreeNodeAuthor -> Widget
|
||||||
actorLinkW actor = do
|
actorLinkW actor = do
|
||||||
hashPerson <- getEncodeKeyHashid
|
hashAuthor <- getHashLocalActor
|
||||||
$(widgetFile "widget/actor-link")
|
$(widgetFile "widget/actor-link")
|
||||||
where
|
where
|
||||||
shortURI h (LocalURI p) = renderAuthority h <> p
|
shortURI h (LocalURI p) = renderAuthority h <> p
|
||||||
|
@ -55,15 +58,13 @@ actorLinkW actor = do
|
||||||
messageW
|
messageW
|
||||||
:: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget
|
:: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget
|
||||||
messageW now (MessageTreeNode msgid msg author) reply = do
|
messageW now (MessageTreeNode msgid msg author) reply = do
|
||||||
hashPerson <- getEncodeKeyHashid
|
hashAuthor <- getHashLocalActor
|
||||||
encodeHid <- getEncodeKeyHashid
|
encodeHid <- getEncodeKeyHashid
|
||||||
let showTime =
|
let showTime =
|
||||||
showEventTime .
|
showEventTime .
|
||||||
intervalToEventTime .
|
intervalToEventTime .
|
||||||
FriendlyConvert .
|
FriendlyConvert .
|
||||||
diffUTCTime now
|
diffUTCTime now
|
||||||
showContent :: Text -> Widget
|
|
||||||
showContent = toWidget . preEscapedToMarkup
|
|
||||||
$(widgetFile "discussion/widget/message")
|
$(widgetFile "discussion/widget/message")
|
||||||
|
|
||||||
messageTreeW
|
messageTreeW
|
||||||
|
|
|
@ -147,7 +147,6 @@ import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
||||||
import Network.HTTP.Simple (JSONException)
|
import Network.HTTP.Simple (JSONException)
|
||||||
import Network.HTTP.Types.Header (HeaderName, hContentType)
|
import Network.HTTP.Types.Header (HeaderName, hContentType)
|
||||||
import Text.Email.Parser (EmailAddress)
|
import Text.Email.Parser (EmailAddress)
|
||||||
import Text.HTML.SanitizeXSS
|
|
||||||
import Yesod.Core.Content (ContentType)
|
import Yesod.Core.Content (ContentType)
|
||||||
import Yesod.Core.Handler (ProvidedRep, provideRepType)
|
import Yesod.Core.Handler (ProvidedRep, provideRepType)
|
||||||
|
|
||||||
|
@ -710,8 +709,8 @@ data Note u = Note
|
||||||
, noteReplyTo :: Maybe (ObjURI u)
|
, noteReplyTo :: Maybe (ObjURI u)
|
||||||
, noteContext :: Maybe (ObjURI u)
|
, noteContext :: Maybe (ObjURI u)
|
||||||
, notePublished :: Maybe UTCTime
|
, notePublished :: Maybe UTCTime
|
||||||
, noteSource :: Text
|
, noteSource :: PandocMarkdown
|
||||||
, noteContent :: Text
|
, noteContent :: HTML
|
||||||
}
|
}
|
||||||
|
|
||||||
withAuthorityT a m = do
|
withAuthorityT a m = do
|
||||||
|
@ -798,7 +797,7 @@ instance ActivityPub Note where
|
||||||
<*> o .:? "context"
|
<*> o .:? "context"
|
||||||
<*> o .:? "published"
|
<*> o .:? "published"
|
||||||
<*> source .: "content"
|
<*> source .: "content"
|
||||||
<*> (sanitizeBalance <$> o .: "content")
|
<*> o .: "content"
|
||||||
toSeries authority (Note mid attrib aud mreply mcontext mpublished src content)
|
toSeries authority (Note mid attrib aud mreply mcontext mpublished src content)
|
||||||
= "type" .= ("Note" :: Text)
|
= "type" .= ("Note" :: Text)
|
||||||
<> "id" .=? (ObjURI authority <$> mid)
|
<> "id" .=? (ObjURI authority <$> mid)
|
||||||
|
|
|
@ -18,13 +18,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
^{actorLinkW author}
|
^{actorLinkW author}
|
||||||
<span .time>
|
<span .time>
|
||||||
$case author
|
$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}
|
#{showTime $ messageCreated msg}
|
||||||
$of MessageTreeNodeRemote h luMsg _luAuthor _mname
|
$of MessageTreeNodeRemote h luMsg _luAuthor _mname
|
||||||
<a href="#{renderObjURI $ ObjURI h luMsg}"}>
|
<a href="#{renderObjURI $ ObjURI h luMsg}"}>
|
||||||
#{showTime $ messageCreated msg}
|
#{showTime $ messageCreated msg}
|
||||||
<span .content>
|
<span .content>
|
||||||
^{showContent $ messageContent msg}
|
^{markupHTML $ messageContent msg}
|
||||||
<span .reply>
|
<span .reply>
|
||||||
<a href=@{reply msgid}>reply
|
<a href=@{reply msgid}>reply
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
$# This file is part of Vervis.
|
$# 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.
|
$# ♡ 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/>.
|
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
|
|
||||||
$case actor
|
$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
|
$of MessageTreeNodeRemote h _luMsg luAuthor mname
|
||||||
<a href="#{renderObjURI $ ObjURI h luAuthor}">
|
<a href="#{renderObjURI $ ObjURI h luAuthor}">
|
||||||
$maybe name <- mname
|
$maybe name <- mname
|
||||||
|
|
|
@ -554,13 +554,13 @@ RemoteDiscussion
|
||||||
|
|
||||||
Message
|
Message
|
||||||
created UTCTime
|
created UTCTime
|
||||||
source Text -- Pandoc Markdown
|
source PandocMarkdown
|
||||||
content Text -- HTML
|
content HTML
|
||||||
parent MessageId Maybe
|
parent MessageId Maybe
|
||||||
root DiscussionId
|
root DiscussionId
|
||||||
|
|
||||||
LocalMessage
|
LocalMessage
|
||||||
author PersonId
|
author ActorId
|
||||||
rest MessageId
|
rest MessageId
|
||||||
create OutboxItemId
|
create OutboxItemId
|
||||||
unlinkedParent FedURI Maybe
|
unlinkedParent FedURI Maybe
|
||||||
|
|
|
@ -160,6 +160,8 @@
|
||||||
/groups/#GroupKeyHashid/outbox/#OutboxItemKeyHashid GroupOutboxItemR GET
|
/groups/#GroupKeyHashid/outbox/#OutboxItemKeyHashid GroupOutboxItemR GET
|
||||||
/groups/#GroupKeyHashid/followers GroupFollowersR GET
|
/groups/#GroupKeyHashid/followers GroupFollowersR GET
|
||||||
|
|
||||||
|
/groups/#GroupKeyHashid/messages/#LocalMessageKeyHashid GroupMessageR GET
|
||||||
|
|
||||||
/groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid GroupStampR GET
|
/groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid GroupStampR GET
|
||||||
|
|
||||||
---- Repo --------------------------------------------------------------------
|
---- Repo --------------------------------------------------------------------
|
||||||
|
@ -180,6 +182,8 @@
|
||||||
/repos/#RepoKeyHashid/commits-by/#Text RepoBranchCommitsR GET
|
/repos/#RepoKeyHashid/commits-by/#Text RepoBranchCommitsR GET
|
||||||
/repos/#RepoKeyHashid/commits/#Text RepoCommitR GET
|
/repos/#RepoKeyHashid/commits/#Text RepoCommitR GET
|
||||||
|
|
||||||
|
/repos/#RepoKeyHashid/messages/#LocalMessageKeyHashid RepoMessageR GET
|
||||||
|
|
||||||
/new-repo RepoNewR GET POST
|
/new-repo RepoNewR GET POST
|
||||||
/repos/#RepoKeyHashid/delete RepoDeleteR POST
|
/repos/#RepoKeyHashid/delete RepoDeleteR POST
|
||||||
/repos/#RepoKeyHashid/edit RepoEditR GET POST
|
/repos/#RepoKeyHashid/edit RepoEditR GET POST
|
||||||
|
@ -203,6 +207,8 @@
|
||||||
|
|
||||||
/decks/#DeckKeyHashid/tree DeckTreeR GET
|
/decks/#DeckKeyHashid/tree DeckTreeR GET
|
||||||
|
|
||||||
|
/decks/#DeckKeyHashid/messages/#LocalMessageKeyHashid DeckMessageR GET
|
||||||
|
|
||||||
/new-deck DeckNewR GET POST
|
/new-deck DeckNewR GET POST
|
||||||
/decks/#DeckKeyHashid/delete DeckDeleteR POST
|
/decks/#DeckKeyHashid/delete DeckDeleteR POST
|
||||||
/decks/#DeckKeyHashid/edit DeckEditR GET POST
|
/decks/#DeckKeyHashid/edit DeckEditR GET POST
|
||||||
|
@ -250,6 +256,8 @@
|
||||||
/looms/#LoomKeyHashid/followers LoomFollowersR GET
|
/looms/#LoomKeyHashid/followers LoomFollowersR GET
|
||||||
/looms/#LoomKeyHashid/cloths LoomClothsR GET
|
/looms/#LoomKeyHashid/cloths LoomClothsR GET
|
||||||
|
|
||||||
|
/looms/#LoomKeyHashid/messages/#LocalMessageKeyHashid LoomMessageR GET
|
||||||
|
|
||||||
/new-loom LoomNewR GET POST
|
/new-loom LoomNewR GET POST
|
||||||
-- /looms/#LoomKeyHashid/delete LoomDeleteR POST
|
-- /looms/#LoomKeyHashid/delete LoomDeleteR POST
|
||||||
-- /looms/#LoomKeyHashid/edit LoomEditR GET POST
|
-- /looms/#LoomKeyHashid/edit LoomEditR GET POST
|
||||||
|
|
|
@ -142,13 +142,13 @@ library
|
||||||
|
|
||||||
Vervis.Data.Actor
|
Vervis.Data.Actor
|
||||||
Vervis.Data.Collab
|
Vervis.Data.Collab
|
||||||
|
Vervis.Data.Discussion
|
||||||
Vervis.Data.Ticket
|
Vervis.Data.Ticket
|
||||||
|
|
||||||
Vervis.Discussion
|
|
||||||
--Vervis.Federation
|
--Vervis.Federation
|
||||||
Vervis.Federation.Auth
|
Vervis.Federation.Auth
|
||||||
Vervis.Federation.Collab
|
Vervis.Federation.Collab
|
||||||
--Vervis.Federation.Discussion
|
Vervis.Federation.Discussion
|
||||||
--Vervis.Federation.Offer
|
--Vervis.Federation.Offer
|
||||||
--Vervis.Federation.Push
|
--Vervis.Federation.Push
|
||||||
Vervis.Federation.Ticket
|
Vervis.Federation.Ticket
|
||||||
|
@ -209,6 +209,7 @@ library
|
||||||
|
|
||||||
Vervis.Persist.Actor
|
Vervis.Persist.Actor
|
||||||
Vervis.Persist.Collab
|
Vervis.Persist.Collab
|
||||||
|
Vervis.Persist.Discussion
|
||||||
Vervis.Persist.Ticket
|
Vervis.Persist.Ticket
|
||||||
|
|
||||||
Vervis.Query
|
Vervis.Query
|
||||||
|
|
Loading…
Reference in a new issue