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

@@ -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

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

migrations/2019_06_10.model

@@ -0,0 +1,4 @@
+FollowerSet
+
+Project
+    followers FollowerSetId

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) <-
+            (tfsPids, tfsRemotes) <-
-                if LocalTicketParticipants `elem` recips
+                if CreateNoteRecipTicketParticipants `elem` recips
-                    then getFollowers fsid
+                    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)
 
@@ -1003,6 +1022,7 @@ data LocalTicketRelatedSet
 
 data LocalProjectRelatedSet = LocalProjectRelatedSet
     { localRecipProject          :: Bool
+    , localRecipProjectFollowers :: Bool
     , localRecipTicketRelated    :: [(Int, LocalTicketRelatedSet)]
     }
 
@@ -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)
+                    return (sid, projectInbox j, projectFollowers j, t)
-                (sid, ibidProject, t) <- fromMaybeE mt "Context: No such local ticket"
+                (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")])

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 $

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

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

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,8 +125,7 @@ getProjectNewR shr = do
     defaultLayout $(widgetFile "project/new")
 
 getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent
-getProjectR shar proj = selectRep $ do
+getProjectR shar proj = do
-    provideRep $ do
     (project, workflow, wsharer, repos) <- runDB $ do
         Entity sid s <- getBy404 $ UniqueSharer shar
         Entity pid p <- getBy404 $ UniqueProject proj sid
@@ -125,17 +136,12 @@ getProjectR shar proj = selectRep $ do
                 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
+    let projectAP = AP.Project
-        return $ Doc host Actor
+            { AP.projectActor = Actor
-            { actorId         = me
+                { actorId         = route2local $ ProjectR shar proj
                 , actorType       = ActorTypeProject
                 , actorUsername   = Nothing
                 , actorName       =
@@ -143,11 +149,16 @@ getProjectR shar proj = selectRep $ do
                 , 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

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
+getTicketParticipantsR shr prj num = getFollowersCollection here getFsid
-    (locals, remotes) <- runDB $ do
+    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
+        return $ 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|
-                <div><pre>#{encodePrettyToLazyText doc}
-            |]
 
 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
+    let team = Collection
-            { collectionId         = encodeRouteLocal $ TicketTeamR shr prj num
+            { 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
+    provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
-        provideAP $ pure doc
-        provideRep $ defaultLayout $
-            [whamlet|
-                <div><pre>#{encodePrettyToLazyText doc}
-            |]
 
 getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
 getTicketEventsR shr prj num = error "TODO not implemented"

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

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

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,7 +338,8 @@ 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)
+    toSeries host
+        (Actor id_ typ musername mname msummary inbox outbox followers pkeys)
             =  "id"                .=     l2f host id_
             <> "type"              .=     typ
             <> "preferredUsername" .=?    musername
@@ -342,8 +347,27 @@ instance ActivityPub Actor where
             <> "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
 
 instance FromJSON CollectionType where