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