From 61d1029926aad3d80906bf188518cc4cd09b6030 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 11 Jun 2019 12:19:51 +0000 Subject: [PATCH] Project team and followers * Have a project team collection, content is the same as ticket team (but potentially ticket team allows people to opt out of updates on specific tickets, while project team isn't tied to any specific ticket or other child object) * Have a project followers collection, and address it in ticket comments in addition to the already used recipients (project, ticket team, ticket followers) --- config/models | 2 + config/routes | 2 + migrations/2019_06_10.model | 4 ++ src/Vervis/Federation.hs | 127 +++++++++++++++++++++++++-------- src/Vervis/Form/Project.hs | 1 + src/Vervis/Handler/Inbox.hs | 3 +- src/Vervis/Handler/Person.hs | 1 + src/Vervis/Handler/Project.hs | 128 ++++++++++++++++++++++++---------- src/Vervis/Handler/Ticket.hs | 61 ++++------------ src/Vervis/Migration.hs | 14 ++++ src/Vervis/Migration/Model.hs | 5 ++ src/Web/ActivityPub.hs | 42 ++++++++--- 12 files changed, 265 insertions(+), 125 deletions(-) create mode 100644 migrations/2019_06_10.model diff --git a/config/models b/config/models index 5e95012..9d396a0 100644 --- a/config/models +++ b/config/models @@ -214,9 +214,11 @@ Project collabUser RoleId Maybe collabAnon RoleId Maybe inbox InboxId + followers FollowerSetId UniqueProject ident sharer UniqueProjectInbox inbox + UniqueProjectFollowers followers Repo ident RpIdent diff --git a/config/routes b/config/routes index 8d79137..533ab2c 100644 --- a/config/routes +++ b/config/routes @@ -96,6 +96,8 @@ /s/#ShrIdent/p/!new ProjectNewR GET /s/#ShrIdent/p/#PrjIdent ProjectR GET PUT POST /s/#ShrIdent/p/#PrjIdent/inbox ProjectInboxR GET POST +/s/#ShrIdent/p/#PrjIdent/team ProjectTeamR GET +/s/#ShrIdent/p/#PrjIdent/followers ProjectFollowersR GET /s/#ShrIdent/p/#PrjIdent/edit ProjectEditR GET /s/#ShrIdent/p/#PrjIdent/d ProjectDevsR GET POST /s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET diff --git a/migrations/2019_06_10.model b/migrations/2019_06_10.model new file mode 100644 index 0000000..c9f6184 --- /dev/null +++ b/migrations/2019_06_10.model @@ -0,0 +1,4 @@ +FollowerSet + +Project + followers FollowerSetId diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 8c10141..2f442db 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -21,6 +21,7 @@ module Vervis.Federation , fixRunningDeliveries , handleOutboxNote , retryOutboxDelivery + , getFollowersCollection ) where @@ -42,7 +43,7 @@ import Data.ByteString (ByteString) import Data.Either import Data.Foldable import Data.Function -import Data.List (sort, deleteBy, nub, union, unionBy) +import Data.List (sort, deleteBy, nub, union, unionBy, partition) import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Maybe import Data.Semigroup @@ -541,6 +542,9 @@ getFollowers fsid = do mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)] mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys +mergeConcat3 :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)] -> [(a, b)] +mergeConcat3 xs ys zs = mergeConcat xs $ LO.mergeBy (compare `on` fst) ys zs + fst3 :: (a, b, c) -> a fst3 (x, _, _) = x @@ -686,6 +690,12 @@ handleSharerInbox now shrRecip (Right iidSender) raw activity = return $ "Activity already exists in inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip +data CreateNoteRecipColl + = CreateNoteRecipProjectFollowers + | CreateNoteRecipTicketParticipants + | CreateNoteRecipTicketTeam + deriving Eq + handleProjectInbox :: UTCTime -> ShrIdent @@ -725,13 +735,13 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a hLocal <- getsYesod $ appInstanceHost . appSettings let colls = findRelevantCollections hLocal num audience mremotesHttp <- runDBExcept $ do - (sid, fsid, jid, ibid, did, meparent) <- getContextAndParent num mparent + (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent lift $ join <$> do - mmid <- insertToDiscussion luNote published ibid did meparent fsid + mmid <- insertToDiscussion luNote published ibid did meparent fsidTicket for mmid $ \ (ractid, mid) -> do updateOrphans luNote did mid for msig $ \ sig -> do - remoteRecips <- deliverLocal ractid colls sid fsid + remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket (sig,) <$> deliverRemoteDB ractid jid sig remoteRecips lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e) @@ -773,21 +783,24 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a guard $ h == hLocal route <- decodeRouteLocal lu case route of + ProjectFollowersR shr prj + | shr == shrRecip && prj == prjRecip + -> Just CreateNoteRecipProjectFollowers TicketParticipantsR shr prj num | shr == shrRecip && prj == prjRecip && num == numCtx - -> Just LocalTicketParticipants + -> Just CreateNoteRecipTicketParticipants TicketTeamR shr prj num | shr == shrRecip && prj == prjRecip && num == numCtx - -> Just LocalTicketTeam + -> Just CreateNoteRecipTicketTeam _ -> Nothing recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] getContextAndParent num mparent = do mt <- lift $ do sid <- getKeyBy404 $ UniqueSharer shrRecip Entity jid j <- getBy404 $ UniqueProject prjRecip sid - fmap (jid, projectInbox j, sid ,) <$> + fmap (jid, projectInbox j, projectFollowers j, sid ,) <$> getValBy (UniqueTicket jid num) - (jid, ibid, sid, t) <- fromMaybeE mt "Context: No such local ticket" + (jid, ibid, fsidProject, sid, t) <- fromMaybeE mt "Context: No such local ticket" let did = ticketDiscuss t meparent <- for mparent $ \ parent -> case parent of @@ -804,7 +817,7 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a throwE "Remote parent belongs to a different discussion" return mid Nothing -> return $ Right $ l2f hParent luParent - return (sid, ticketFollowers t, jid, ibid, did, meparent) + return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent) insertToDiscussion luNote published ibid did meparent fsid = do ractid <- either entityKey id <$> insertBy' RemoteActivity { remoteActivityInstance = iidSender @@ -873,22 +886,27 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a return (rm E.^. RemoteMessageId, m E.^. MessageId) deliverLocal :: RemoteActivityId - -> [LocalTicketRecipient] + -> [CreateNoteRecipColl] -> SharerId -> FollowerSetId + -> FollowerSetId -> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] - deliverLocal ractid recips sid fsid = do + deliverLocal ractid recips sid fsidProject fsidTicket = do (teamPids, teamRemotes) <- - if LocalTicketTeam `elem` recips + if CreateNoteRecipTicketTeam `elem` recips then getTicketTeam sid else return ([], []) - (fsPids, fsRemotes) <- - if LocalTicketParticipants `elem` recips - then getFollowers fsid + (tfsPids, tfsRemotes) <- + if CreateNoteRecipTicketParticipants `elem` recips + then getFollowers fsidTicket else return ([], []) - let pids = union teamPids fsPids + (jfsPids, jfsRemotes) <- + if CreateNoteRecipProjectFollowers `elem` recips + then getFollowers fsidProject + else return ([], []) + let pids = union teamPids tfsPids `union` jfsPids -- TODO inefficient, see the other TODOs about mergeConcat - remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes + remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes for_ pids $ \ pid -> do ibid <- personInbox <$> getJust pid ibiid <- insert $ InboxItem True @@ -985,6 +1003,7 @@ data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam data LocalProjectRecipient = LocalProject + | LocalProjectFollowers | LocalTicketRelated Int LocalTicketRecipient deriving (Eq, Ord) @@ -1002,8 +1021,9 @@ data LocalTicketRelatedSet | BothTicketParticipantsAndTeam data LocalProjectRelatedSet = LocalProjectRelatedSet - { localRecipProject :: Bool - , localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)] + { localRecipProject :: Bool + , localRecipProjectFollowers :: Bool + , localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)] } data LocalSharerRelatedSet = LocalSharerRelatedSet @@ -1084,8 +1104,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s sid <- MaybeT $ getKeyBy $ UniqueSharer shr Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid t <- MaybeT $ getValBy $ UniqueTicket jid num - return (sid, projectInbox j, t) - (sid, ibidProject, t) <- fromMaybeE mt "Context: No such local ticket" + return (sid, projectInbox j, projectFollowers j, t) + (sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket" let did = ticketDiscuss t mmidParent <- for mparent $ \ parent -> case parent of @@ -1101,7 +1121,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s throwE "Remote parent belongs to a different discussion" return mid lift $ insertUnique_ $ Follow pid (ticketFollowers t) False - return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject)) + return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject)) Nothing -> do (rd, rdnew) <- lift $ do let (hContext, luContext) = f2l uContext @@ -1202,6 +1222,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer parseLocalRecipient (ProjectR shr prj) = Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject + parseLocalRecipient (ProjectFollowersR shr prj) = + Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProjectFollowers parseLocalRecipient (TicketParticipantsR shr prj num) = Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants parseLocalRecipient (TicketTeamR shr prj num) = @@ -1225,9 +1247,11 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s (not . null) ( map ( second - $ uncurry LocalProjectRelatedSet + $ uncurry localProjectRelatedSet . bimap - (not . null) + ( bimap (not . null) (not . null) + . partition id + ) ( map (second ltrs2ltrs) . groupWithExtract fst snd ) @@ -1246,7 +1270,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s where lsr2e LocalSharer = Left () lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr) - lpr2e LocalProject = Left () + lpr2e LocalProject = Left False + lpr2e LocalProjectFollowers = Left True lpr2e (LocalTicketRelated num ltr) = Right (num, ltr) ltrs2ltrs (LocalTicketParticipants :| l) = if LocalTicketTeam `elem` l @@ -1256,6 +1281,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s if LocalTicketParticipants `elem` l then BothTicketParticipantsAndTeam else OnlyTicketTeam + localProjectRelatedSet (f, j) t = + LocalProjectRelatedSet j f t parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))) parseParent _ Nothing = return Nothing @@ -1288,6 +1315,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets" unless (prj == prj') $ throwE "Note project recipients mismatch context's project" unless (localRecipProject lprSet) $ throwE "Note context's project not addressed" + unless (localRecipProjectFollowers lprSet) $ throwE "Note context's project followers not addressed" (num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets" unless (num == num') $ throwE "Note project recipients mismatch context's ticket number" case ltrSet of @@ -1389,7 +1417,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s :: PersonId -> OutboxItemId -> [ShrIdent] - -> Maybe (SharerId, FollowerSetId, InboxId) + -> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId) -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] deliverLocal pidAuthor obid recips mticket = do recipPids <- traverse getPersonId $ nub recips @@ -1398,11 +1426,12 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s (morePids, remotes) <- lift $ case mticket of Nothing -> return ([], []) - Just (sid, fsid, _) -> do + Just (sid, fsidT, _, fsidJ) -> do (teamPids, teamRemotes) <- getTicketTeam sid - (fsPids, fsRemotes) <- getFollowers fsid + (tfsPids, tfsRemotes) <- getFollowers fsidT + (jfsPids, jfsRemotes) <- getFollowers fsidJ return - ( L.delete pidAuthor $ union teamPids fsPids + ( L.delete pidAuthor $ union teamPids $ union tfsPids jfsPids -- TODO this is inefficient! The way this combines -- same-host sharer lists is: -- @@ -1441,10 +1470,10 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s -- instances aren't repeated. Use a custom merge -- where we can unionBy or LO.unionBy whenever both -- lists have the same instance. - , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes + , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes ) lift $ do - for_ mticket $ \ (_, _, ibidProject) -> do + for_ mticket $ \ (_, _, ibidProject, _) -> do ibiid <- insert $ InboxItem False insert_ $ InboxItemLocal ibidProject obid ibiid for_ (union recipPids morePids) $ \ pid -> do @@ -1976,3 +2005,39 @@ retryOutboxDelivery = do unless (and results) $ logError $ "Periodic FW delivery error for host " <> h return True + +getFollowersCollection + :: Route App -> AppDB FollowerSetId -> Handler TypedContent +getFollowersCollection here getFsid = do + (locals, remotes) <- runDB $ do + fsid <- getFsid + (,) <$> do pids <- map (followPerson . entityVal) <$> + selectList [FollowTarget ==. fsid] [] + sids <- + map (personIdent . entityVal) <$> + selectList [PersonId <-. pids] [] + map (sharerIdent . entityVal) <$> + selectList [SharerId <-. sids] [] + <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do + E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId + E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId + E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid + return + ( i E.^. InstanceHost + , ra E.^. RemoteActorIdent + ) + + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let followersAP = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length locals + length remotes + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map (encodeRouteHome . SharerR) locals ++ + map (uncurry l2f . bimap E.unValue E.unValue) remotes + } + provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")]) diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index 16c1ef8..0e48e98 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -116,6 +116,7 @@ editProjectAForm sid (Entity jid project) = Project <*> aopt selectRole "User role" (Just $ projectCollabUser project) <*> aopt selectRole "Guest role" (Just $ projectCollabAnon project) <*> pure (projectInbox project) + <*> pure (projectFollowers project) where selectWiki = selectField $ diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index a4e5d0d..ee2315d 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -458,7 +458,8 @@ postOutboxR shrAuthor = do uTicket = encodeRecipRoute $ TicketR shrTicket prj num (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor collections = - [ TicketParticipantsR shrTicket prj num + [ ProjectFollowersR shrTicket prj + , TicketParticipantsR shrTicket prj num , TicketTeamR shrTicket prj num ] recips = ProjectR shrTicket prj : collections diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 5ec2012..71ffde2 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -144,6 +144,7 @@ getPerson shr sharer person = do , actorSummary = Nothing , actorInbox = route2local $ SharerInboxR shr , actorOutbox = Just $ route2local $ OutboxR shr + , actorFollowers = Nothing , actorPublicKeys = [ Left $ route2local ActorKey1R , Left $ route2local ActorKey2R diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 3d7415e..4fde839 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -27,6 +27,8 @@ module Vervis.Handler.Project , getProjectDevR , deleteProjectDevR , postProjectDevR + , getProjectTeamR + , getProjectFollowersR ) where @@ -47,9 +49,17 @@ import Yesod.Persist.Core (runDB, get404, getBy404) import qualified Database.Esqueleto as E import Network.FedURI -import Web.ActivityPub +import Web.ActivityPub hiding (Project (..)) +import Yesod.ActivityPub import Yesod.FedURI +import qualified Web.ActivityPub as AP + +import Data.Either.Local +import Database.Persist.Local +import Yesod.Persist.Local + +import Vervis.Federation import Vervis.Form.Project import Vervis.Foundation import Vervis.Model @@ -78,6 +88,7 @@ postProjectsR shr = do pid <- requireAuthId runDB $ do ibid <- insert Inbox + fsid <- insert FollowerSet let project = Project { projectIdent = npIdent np , projectSharer = sid @@ -89,6 +100,7 @@ postProjectsR shr = do , projectCollabAnon = Nothing , projectCollabUser = Nothing , projectInbox = ibid + , projectFollowers = fsid } jid <- insert project let collab = ProjectCollab @@ -113,41 +125,40 @@ getProjectNewR shr = do defaultLayout $(widgetFile "project/new") getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent -getProjectR shar proj = selectRep $ do - provideRep $ do - (project, workflow, wsharer, repos) <- runDB $ do - Entity sid s <- getBy404 $ UniqueSharer shar - Entity pid p <- getBy404 $ UniqueProject proj sid - w <- get404 $ projectWorkflow p - sw <- - if workflowSharer w == sid - then return s - else get404 $ workflowSharer w - rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] - return (p, w, sw, rs) - defaultLayout $(widgetFile "project/one") - provideAP $ do - project <- runDB $ do - Entity sid _s <- getBy404 $ UniqueSharer shar - Entity _pid p <- getBy404 $ UniqueProject proj sid - return p - route2fed <- getEncodeRouteHome - route2local <- getEncodeRouteLocal - let (host, me) = f2l $ route2fed $ ProjectR shar proj - return $ Doc host Actor - { actorId = me - , actorType = ActorTypeProject - , actorUsername = Nothing - , actorName = - Just $ fromMaybe (prj2text proj) $ projectName project - , actorSummary = projectDesc project - , actorInbox = route2local $ ProjectInboxR shar proj - , actorOutbox = Nothing - , actorPublicKeys = - [ Left $ route2local ActorKey1R - , Left $ route2local ActorKey2R - ] +getProjectR shar proj = do + (project, workflow, wsharer, repos) <- runDB $ do + Entity sid s <- getBy404 $ UniqueSharer shar + Entity pid p <- getBy404 $ UniqueProject proj sid + w <- get404 $ projectWorkflow p + sw <- + if workflowSharer w == sid + then return s + else get404 $ workflowSharer w + rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] + return (p, w, sw, rs) + + route2fed <- getEncodeRouteHome + route2local <- getEncodeRouteLocal + let projectAP = AP.Project + { AP.projectActor = Actor + { actorId = route2local $ ProjectR shar proj + , actorType = ActorTypeProject + , actorUsername = Nothing + , actorName = + Just $ fromMaybe (prj2text proj) $ projectName project + , actorSummary = projectDesc project + , actorInbox = route2local $ ProjectInboxR shar proj + , actorOutbox = Nothing + , actorFollowers = + Just $ route2local $ ProjectFollowersR shar proj + , actorPublicKeys = + [ Left $ route2local ActorKey1R + , Left $ route2local ActorKey2R + ] + } + , AP.projectTeam = route2local $ ProjectTeamR shar proj } + provideHtmlAndAP projectAP $(widgetFile "project/one") putProjectR :: ShrIdent -> PrjIdent -> Handler Html putProjectR shr prj = do @@ -273,3 +284,50 @@ postProjectDevR shr rp dev = do case mmethod of Just "DELETE" -> deleteProjectDevR shr rp dev _ -> notFound + +getProjectTeamR :: ShrIdent -> PrjIdent -> Handler TypedContent +getProjectTeamR shr prj = do + memberShrs <- runDB $ do + sid <- getKeyBy404 $ UniqueSharer shr + _jid <- getKeyBy404 $ UniqueProject prj sid + id_ <- + requireEitherAlt + (getKeyBy $ UniquePersonIdent sid) + (getKeyBy $ UniqueGroup sid) + "Found sharer that is neither person nor group" + "Found sharer that is both person and group" + case id_ of + Left pid -> return [shr] + Right gid -> do + pids <- + map (groupMemberPerson . entityVal) <$> + selectList [GroupMemberGroup ==. gid] [] + sids <- + map (personIdent . entityVal) <$> + selectList [PersonId <-. pids] [] + map (sharerIdent . entityVal) <$> + selectList [SharerId <-. sids] [] + + let here = ProjectTeamR shr prj + + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let team = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length memberShrs + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = map (encodeRouteHome . SharerR) memberShrs + } + provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")]) + +getProjectFollowersR :: ShrIdent -> PrjIdent -> Handler TypedContent +getProjectFollowersR shr prj = getFollowersCollection here getFsid + where + here = ProjectFollowersR shr prj + getFsid = do + sid <- getKeyBy404 $ UniqueSharer shr + j <- getValBy404 $ UniqueProject prj sid + return $ projectFollowers j diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 3471176..cb76842 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -101,6 +101,7 @@ import Data.Maybe.Local (partitionMaybePairs) import Database.Persist.Local import Yesod.Persist.Local +import Vervis.Federation import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Handler.Discussion @@ -894,49 +895,14 @@ getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketReverseDepsR = getTicketDeps False getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent -getTicketParticipantsR shr prj num = do - (locals, remotes) <- runDB $ do +getTicketParticipantsR shr prj num = getFollowersCollection here getFsid + where + here = TicketParticipantsR shr prj num + getFsid = do sid <- getKeyBy404 $ UniqueSharer shr jid <- getKeyBy404 $ UniqueProject prj sid t <- getValBy404 $ UniqueTicket jid num - let fsid = ticketFollowers t - (,) <$> do pids <- map (followPerson . entityVal) <$> - selectList [FollowTarget ==. fsid] [] - sids <- - map (personIdent . entityVal) <$> - selectList [PersonId <-. pids] [] - map (sharerIdent . entityVal) <$> - selectList [SharerId <-. sids] [] - <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do - E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId - E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId - E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid - return - ( i E.^. InstanceHost - , ra E.^. RemoteActorIdent - ) - - hLocal <- getsYesod $ appInstanceHost . appSettings - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - let doc = Doc hLocal Collection - { collectionId = - encodeRouteLocal $ TicketParticipantsR shr prj num - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ length locals + length remotes - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = - map (encodeRouteHome . SharerR) locals ++ - map (uncurry l2f . bimap E.unValue E.unValue) remotes - } - selectRep $ do - provideAP $ pure doc - provideRep $ defaultLayout $ - [whamlet| - 
#{encodePrettyToLazyText doc}
-            |]
+        return $ ticketFollowers t
 
 getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
 getTicketTeamR shr prj num = do
@@ -961,11 +927,13 @@ getTicketTeamR shr prj num = do
                         selectList [PersonId <-. pids] []
                 map (sharerIdent . entityVal) <$>
                     selectList [SharerId <-. sids] []
-    hLocal <- getsYesod $ appInstanceHost . appSettings
+
+    let here = TicketTeamR shr prj num
+
     encodeRouteLocal <- getEncodeRouteLocal
     encodeRouteHome <- getEncodeRouteHome
-    let doc = Doc hLocal Collection
-            { collectionId         = encodeRouteLocal $ TicketTeamR shr prj num
+    let team = Collection
+            { collectionId         = encodeRouteLocal here
             , collectionType       = CollectionTypeUnordered
             , collectionTotalItems = Just $ length memberShrs
             , collectionCurrent    = Nothing
@@ -973,12 +941,7 @@ getTicketTeamR shr prj num = do
             , collectionLast       = Nothing
             , collectionItems      = map (encodeRouteHome . SharerR) memberShrs
             }
-    selectRep $ do
-        provideAP $ pure doc
-        provideRep $ defaultLayout $
-            [whamlet|
-                
#{encodePrettyToLazyText doc}
-            |]
+    provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
 
 getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
 getTicketEventsR shr prj num = error "TODO not implemented"
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index 26cc662..0fcc8ba 100644
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@@ -649,6 +649,20 @@ changes hLocal ctx =
                         insert_ $ InboxItemLocal2019Fill ibid obid ibiid
                     Right ractid ->
                         insert_ $ InboxItemRemote2019Fill ibid ractid ibiid
+      -- 110
+    , addFieldRefRequired'
+        "Project"
+        FollowerSet20190610
+        (Just $ do
+            jids <- selectKeysList ([] :: [Filter Project20190610]) []
+            for_ jids $ \ jid -> do
+                fsid <- insert FollowerSet20190610
+                update jid [Project20190610Followers =. fsid]
+        )
+        "followers"
+        "FollowerSet"
+      -- 111
+    , addUnique "Project" $ Unique "UniqueProjectFollowers" ["followers"]
     ]
 
 migrateDB
diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs
index 4a89933..9d61f72 100644
--- a/src/Vervis/Migration/Model.hs
+++ b/src/Vervis/Migration/Model.hs
@@ -79,6 +79,8 @@ module Vervis.Migration.Model
     , Message2019FillGeneric (..)
     , LocalMessage2019FillGeneric (..)
     , RemoteMessage2019FillGeneric (..)
+    , FollowerSet20190610Generic (..)
+    , Project20190610
     )
 where
 
@@ -183,3 +185,6 @@ makeEntitiesMigration "20190609"
 
 makeEntitiesMigration "2019Fill"
     $(modelFile "migrations/2019_06_09_fill.model")
+
+makeEntitiesMigration "20190610"
+    $(modelFile "migrations/2019_06_10.model")
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index adb36a7..f99e0c1 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -31,6 +31,7 @@ module Web.ActivityPub
     , Owner (..)
     , PublicKey (..)
     , Actor (..)
+    , Project (..)
     , CollectionType (..)
     , Collection (..)
     , CollectionPageType (..)
@@ -188,6 +189,7 @@ instance ActivityPub a => ToJSON (Doc a) where
             <> toSeries h v
 
 data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
+    deriving Eq
 
 instance FromJSON ActorType where
     parseJSON = withText "ActorType" $ pure . parse
@@ -312,6 +314,7 @@ data Actor = Actor
     , actorSummary    :: Maybe Text
     , actorInbox      :: LocalURI
     , actorOutbox     :: Maybe LocalURI
+    , actorFollowers  :: Maybe LocalURI
     , actorPublicKeys :: [Either LocalURI PublicKey]
     }
 
@@ -327,6 +330,7 @@ instance ActivityPub Actor where
                 <*> o .:? "summary"
                 <*> withHost host (f2l <$> o .: "inbox")
                 <*> withHostMaybe host (fmap f2l <$> o .:? "outbox")
+                <*> withHostMaybe host (fmap f2l <$> o .:? "followers")
                 <*> withHost host (parsePublicKeySet =<< o .: "publicKey")
         where
         withHost h a = do
@@ -334,15 +338,35 @@ instance ActivityPub Actor where
             if h == h'
                 then return v
                 else fail "URI host mismatch"
-    toSeries host (Actor id_ typ musername mname msummary inbox outbox pkeys)
-        =  "id"                .=     l2f host id_
-        <> "type"              .=     typ
-        <> "preferredUsername" .=?    musername
-        <> "name"              .=?    mname
-        <> "summary"           .=?    msummary
-        <> "inbox"             .=     l2f host inbox
-        <> "outbox"            .=?    (l2f host <$> outbox)
-        <> "publicKey"         `pair` encodePublicKeySet host pkeys
+    toSeries host
+        (Actor id_ typ musername mname msummary inbox outbox followers pkeys)
+            =  "id"                .=     l2f host id_
+            <> "type"              .=     typ
+            <> "preferredUsername" .=?    musername
+            <> "name"              .=?    mname
+            <> "summary"           .=?    msummary
+            <> "inbox"             .=     l2f host inbox
+            <> "outbox"            .=?    (l2f host <$> outbox)
+            <> "followers"         .=?    (l2f host <$> followers)
+            <> "publicKey"         `pair` encodePublicKeySet host pkeys
+
+data Project = Project
+    { projectActor :: Actor
+    , projectTeam  :: LocalURI
+    }
+
+instance ActivityPub Project where
+    jsonldContext _ = ContextActor
+    parseObject o = do
+        (h, a) <- parseObject o
+        unless (actorType a == ActorTypeProject) $
+            fail "Actor type isn't Project"
+        fmap (h,) $
+            Project a
+                <$> withHost h (f2l <$> o .: (frg <> "team"))
+    toSeries host (Project actor team)
+        =  toSeries host actor
+        <> (frg <> "team") .= l2f host team
 
 data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered