Vocab, UI: Component: Specify and serve teams collection

src/Vervis/Foundation.hs

@@ -940,6 +940,8 @@ instance YesodBreadcrumbs App where
         RepoCollabsR r -> ("Collaborators", Just $ RepoR r)
         RepoProjectsR r -> ("Projects", Just $ RepoR r)
 
+        RepoTeamsR r -> ("Teams", Just $ RepoR r)
+
         DeckR d             -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
         DeckInboxR d        -> ("Inbox", Just $ DeckR d)
         DeckOutboxR d       -> ("Outbox", Just $ DeckR d)
@@ -969,6 +971,8 @@ instance YesodBreadcrumbs App where
         DeckRemoveProjectR d c -> ("", Nothing)
         DeckAddProjectR d -> ("", Nothing)
 
+        DeckTeamsR d -> ("Teams", Just $ DeckR d)
+
         TicketR d t            -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
         TicketDiscussionR d t  -> ("Discussion", Just $ TicketR d t)
         TicketEventsR d t      -> ("Events", Just $ TicketR d t)
@@ -1004,6 +1008,8 @@ instance YesodBreadcrumbs App where
         LoomCollabsR l -> ("Collaborators", Just $ LoomR l)
         LoomProjectsR l -> ("Projects", Just $ LoomR l)
 
+        LoomTeamsR l -> ("Teams", Just $ LoomR l)
+
         ClothR l c            -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
         ClothDiscussionR l c  -> ("Discussion", Just $ ClothR l c)
         ClothEventsR l c      -> ("Events", Just $ ClothR l c)

src/Vervis/Handler/Deck.hs

@@ -47,6 +47,7 @@ module Vervis.Handler.Deck
     , postDeckApproveProjectR
     , postDeckRemoveProjectR
 
+    , getDeckTeamsR
 
 
 
@@ -135,6 +136,7 @@ import Vervis.Ticket
 import Vervis.TicketFilter
 import Vervis.Time
 import Vervis.Web.Actor
+import Vervis.Web.Collab
 import Vervis.Widget
 import Vervis.Widget.Person
 import Vervis.Widget.Ticket
@@ -185,6 +187,8 @@ getDeckR deckHash = do
                 encodeRouteLocal $ DeckCollabsR deckHash
             , AP.ticketTrackerProjects =
                 encodeRouteLocal $ DeckProjectsR deckHash
+            , AP.ticketTrackerTeams =
+                encodeRouteLocal $ DeckTeamsR deckHash
             }
 
     provideHtmlAndAP deckAP $ redirect $ DeckTicketsR deckHash
@@ -735,6 +739,14 @@ postDeckRemoveProjectR deckHash stemID = do
             setMessage "Remove sent"
     redirect $ DeckProjectsR deckHash
 
+getDeckTeamsR :: KeyHashid Deck -> Handler TypedContent
+getDeckTeamsR deckHash = do
+    deckID <- decodeKeyHashid404 deckHash
+    resourceID <- runDB $ do
+        komponentID <- deckKomponent <$> get404 deckID
+        komponentResource <$> getJust komponentID
+    serveTeamsCollection (DeckR deckHash) (DeckTeamsR deckHash) resourceID
+
 {-
 getProjectsR :: ShrIdent -> Handler Html
 getProjectsR ident = do

src/Vervis/Handler/Loom.hs

@@ -34,6 +34,8 @@ module Vervis.Handler.Loom
 
     , getLoomCollabsR
     , getLoomProjectsR
+
+    , getLoomTeamsR
     )
 where
 
@@ -98,6 +100,7 @@ import Vervis.Ticket
 import Vervis.TicketFilter
 import Vervis.Time
 import Vervis.Web.Actor
+import Vervis.Web.Collab
 import Vervis.Widget.Person
 import Vervis.Widget.Ticket
 import Vervis.Widget.Tracker
@@ -144,6 +147,8 @@ getLoomR loomHash = do
                 encodeRouteLocal $ LoomCollabsR loomHash
             , AP.patchTrackerProjects =
                 encodeRouteLocal $ LoomProjectsR loomHash
+            , AP.patchTrackerTeams =
+                encodeRouteLocal $ LoomTeamsR loomHash
             }
 
     provideHtmlAndAP loomAP $ redirect $ LoomClothsR loomHash
@@ -384,3 +389,11 @@ getLoomProjectsR loomHash = do
 
 addProjectForm = renderDivs $
     areq fedUriField "(URI) Project" Nothing
+
+getLoomTeamsR :: KeyHashid Loom -> Handler TypedContent
+getLoomTeamsR loomHash = do
+    loomID <- decodeKeyHashid404 loomHash
+    resourceID <- runDB $ do
+        komponentID <- loomKomponent <$> get404 loomID
+        komponentResource <$> getJust komponentID
+    serveTeamsCollection (LoomR loomHash) (LoomTeamsR loomHash) resourceID

src/Vervis/Handler/Repo.hs

@@ -52,6 +52,8 @@ module Vervis.Handler.Repo
     , getRepoCollabsR
     , getRepoProjectsR
 
+    , getRepoTeamsR
+
 
 
 
@@ -186,6 +188,7 @@ import Vervis.SourceTree
 import Vervis.Style
 import Vervis.Time
 import Vervis.Web.Actor
+import Vervis.Web.Collab
 import Vervis.Web.Darcs
 import Vervis.Web.Delivery
 import Vervis.Web.Git
@@ -240,6 +243,7 @@ getRepoR repoHash = do
             , AP.repoClone = encodeRouteLocal (RepoR repoHash) :| []
             , AP.repoCollaborators = encodeRouteLocal $ RepoCollabsR repoHash
             , AP.repoProjects = encodeRouteLocal $ RepoProjectsR repoHash
+            , AP.repoTeams = encodeRouteLocal $ RepoTeamsR repoHash
             }
 
         next =
@@ -809,6 +813,14 @@ getRepoProjectsR repoHash = do
     hashLoom <- getEncodeKeyHashid
     defaultLayout $(widgetFile "repo/projects")
 
+getRepoTeamsR :: KeyHashid Repo -> Handler TypedContent
+getRepoTeamsR repoHash = do
+    repoID <- decodeKeyHashid404 repoHash
+    resourceID <- runDB $ do
+        komponentID <- repoKomponent <$> get404 repoID
+        komponentResource <$> getJust komponentID
+    serveTeamsCollection (RepoR repoHash) (RepoTeamsR repoHash) resourceID
+
 
 
 

src/Vervis/Migration.hs

@@ -3813,6 +3813,12 @@ changes hLocal ctx =
     , addEntities model_638_effort_squad
       -- 639
     , addEntities model_639_component_convey
+      -- 640
+    , addFieldRefRequiredEmpty "Squad" "holder" "Resource"
+      -- 641
+    , removeEntity "SquadHolderProject"
+      -- 642
+    , removeEntity "SquadHolderComponent"
     ]
 
 migrateDB

src/Vervis/Persist/Collab.hs

@@ -60,6 +60,8 @@ module Vervis.Persist.Collab
 
     , getStems
     , getStemDrafts
+
+    , getResourceTeams
     )
 where
 
@@ -1350,3 +1352,63 @@ getStemDrafts komponentID = do
                     RemoteActivity _ _ time <- getJust addID
                     (,time) . Right <$> getRemoteActorData actorID
         return (inviter, us, project, accept, time, role, stemID)
+
+getResourceTeams
+    :: MonadIO m
+    => ResourceId
+    -> ReaderT SqlBackend m
+        [ ( AP.Role
+          , UTCTime
+          , Either (GroupId, Actor) (Instance, RemoteObject, RemoteActor)
+          , SquadId
+          )
+        ]
+getResourceTeams resourceID =
+    fmap (sortOn $ view _2) $ liftA2 (++)
+        (map (\ (E.Value role, E.Value time, E.Value groupID, Entity _ actor, E.Value squadID) ->
+                (role, time, Left (groupID, actor), squadID)
+             )
+            <$> getLocals
+        )
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value squadID) ->
+                (role, time, Right (i, ro, ra), squadID)
+             )
+            <$> getRemotes
+        )
+    where
+    getLocals =
+        E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` group `E.InnerJoin` actor `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
+            E.on $ deleg E.^. SquadThemSendDelegatorLocalGrant E.==. grant E.^. OutboxItemId
+            E.on $ accept E.^. SquadUsAcceptId E.==. deleg E.^. SquadThemSendDelegatorLocalSquad
+            E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
+            E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
+            E.on $ topic E.^. SquadTopicLocalGroup E.==. group E.^. GroupId
+            E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad
+            E.where_ $ squad E.^. SquadHolder E.==. E.val resourceID
+            E.orderBy [E.asc $ grant E.^. OutboxItemPublished]
+            return
+                ( squad E.^. SquadRole
+                , grant E.^. OutboxItemPublished
+                , topic E.^. SquadTopicLocalGroup
+                , actor
+                , squad E.^. SquadId
+                )
+    getRemotes =
+        E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
+            E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+            E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
+            E.on $ topic E.^. SquadTopicRemoteTopic E.==. ra E.^. RemoteActorId
+            E.on $ deleg E.^. SquadThemSendDelegatorRemoteGrant E.==. grant E.^. RemoteActivityId
+            E.on $ accept E.^. SquadUsAcceptId E.==. deleg E.^. SquadThemSendDelegatorRemoteSquad
+            E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
+            E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad
+            E.where_ $ squad E.^. SquadHolder E.==. E.val resourceID
+            E.orderBy [E.asc $ grant E.^. RemoteActivityReceived]
+            return
+                ( squad E.^. SquadRole
+                , grant E.^. RemoteActivityReceived
+                , i
+                , ro
+                , ra
+                , squad E.^. SquadId
+                )

src/Vervis/Web/Collab.hs

@@ -16,6 +16,7 @@
 module Vervis.Web.Collab
     ( verifyCapability''
     , checkCapabilityBeforeExtending
+    , serveTeamsCollection
     )
 where
 
@@ -63,6 +64,7 @@ import Yesod.Hashids
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
+import qualified Yesod.FedURI as YF
 
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
@@ -517,3 +519,37 @@ checkCapabilityBeforeExtending uCap extender = do
                 AP.grantAllows grant == AP.Distribute &&
                 targetIsTeam &&
                 (AP.grantAllows h == AP.Distribute || AP.grantAllows h == AP.Invoke)
+
+serveTeamsCollection meR hereR resourceID = do
+    teams <- runDB $ getResourceTeams resourceID
+    h <- asksSite siteInstanceHost
+    encodeRouteLocal <- YF.getEncodeRouteLocal
+    encodeRouteHome <- YF.getEncodeRouteHome
+    hashGroup <- getEncodeKeyHashid
+    let makeItem (role, time, team, _) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome meR
+            , AP.relationshipProperty     = Left AP.RelHasRecCollab
+            , AP.relationshipObject       =
+                case team of
+                    Left (groupID, _) ->
+                        encodeRouteHome $ GroupR $ hashGroup groupID
+                    Right (i, ro, _) ->
+                        ObjURI (instanceHost i) (remoteObjectIdent ro)
+            , AP.relationshipAttributedTo = encodeRouteLocal meR
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        teamsAP = AP.Collection
+            { AP.collectionId         = encodeRouteLocal hereR
+            , AP.collectionType       = CollectionTypeUnordered
+            , AP.collectionTotalItems = Just $ length teams
+            , AP.collectionCurrent    = Nothing
+            , AP.collectionFirst      = Nothing
+            , AP.collectionLast       = Nothing
+            , AP.collectionItems      = map (Doc h . makeItem) teams
+            , AP.collectionContext    = Just $ encodeRouteLocal meR
+            }
+    provideHtmlAndAP teamsAP $ redirectToPrettyJSON hereR

src/Web/ActivityPub.hs

@@ -660,6 +660,7 @@ data Repo u = Repo
     , repoClone :: NonEmpty LocalURI
     , repoCollaborators :: LocalURI
     , repoProjects :: LocalURI
+    , repoTeams :: LocalURI
     }
 
 instance ActivityPub Repo where
@@ -676,7 +677,8 @@ instance ActivityPub Repo where
                 <*> (traverse (withAuthorityO h . pure) =<< o .:*+ "cloneUri")
                 <*> withAuthorityO h (o .: "collaborators")
                 <*> withAuthorityO h (o .: "context")
-    toSeries h (Repo actor team vcs loom clone collabs projects)
+                <*> withAuthorityO h (o .: "teams")
+    toSeries h (Repo actor team vcs loom clone collabs projects teams)
         =  toSeries h actor
         <> "team"                 .= (ObjURI h <$> team)
         <> "versionControlSystem" .= vcs
@@ -684,12 +686,14 @@ instance ActivityPub Repo where
         <> "cloneUri"             .=*+ (ObjURI h <$> clone)
         <> "collaborators"        .= ObjURI h collabs
         <> "context"              .= ObjURI h projects
+        <> "teams"                .= ObjURI h teams
 
 data TicketTracker u = TicketTracker
     { ticketTrackerActor :: Actor u
     , ticketTrackerTeam  :: Maybe LocalURI
     , ticketTrackerCollaborators :: LocalURI
     , ticketTrackerProjects :: LocalURI
+    , ticketTrackerTeams :: LocalURI
     }
 
 instance ActivityPub TicketTracker where
@@ -703,16 +707,19 @@ instance ActivityPub TicketTracker where
                 <$> withAuthorityMaybeO h (o .:|? "team")
                 <*> withAuthorityO h (o .: "collaborators")
                 <*> withAuthorityO h (o .: "context")
-    toSeries h (TicketTracker actor team collabs projects)
+                <*> withAuthorityO h (o .: "teams")
+    toSeries h (TicketTracker actor team collabs projects teams)
         =  toSeries h actor
         <> "team" .= (ObjURI h <$> team)
         <> "collaborators"  .= ObjURI h collabs
         <> "context"  .= ObjURI h projects
+        <> "teams"  .= ObjURI h teams
 
 data PatchTracker u = PatchTracker
     { patchTrackerActor :: Actor u
     , patchTrackerCollaborators :: LocalURI
     , patchTrackerProjects :: LocalURI
+    , patchTrackerTeams :: LocalURI
     }
 
 instance ActivityPub PatchTracker where
@@ -725,10 +732,12 @@ instance ActivityPub PatchTracker where
             PatchTracker a
                 <$> withAuthorityO h (o .: "collaborators")
                 <*> withAuthorityO h (o .: "context")
-    toSeries h (PatchTracker actor collabs projects)
+                <*> withAuthorityO h (o .: "teams")
+    toSeries h (PatchTracker actor collabs projects teams)
         =  toSeries h actor
         <> "collaborators" .= ObjURI h collabs
         <> "context"       .= ObjURI h projects
+        <> "teams"         .= ObjURI h teams
 
 data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered
 
@@ -1119,7 +1128,7 @@ instance ActivityPub Note where
         <> "mediaType"    .=  ("text/html" :: Text)
 
 data RelationshipProperty =
-    RelDependsOn | RelHasCollab | RelHasMember | RelHasChild | RelHasParent
+    RelDependsOn | RelHasCollab | RelHasMember | RelHasChild | RelHasParent | RelHasRecCollab
     deriving Eq
 
 instance FromJSON RelationshipProperty where
@@ -1131,6 +1140,7 @@ instance FromJSON RelationshipProperty where
             | t == "hasMember" = pure RelHasMember
             | t == "hasChild" = pure RelHasChild
             | t == "hasParent" = pure RelHasParent
+            | t == "hasRecursiveCollaborator" = pure RelHasRecCollab
             | otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t
 
 instance ToJSON RelationshipProperty where
@@ -1142,6 +1152,7 @@ instance ToJSON RelationshipProperty where
             RelHasMember -> "hasMember"
             RelHasChild -> "hasChild"
             RelHasParent -> "hasParent"
+            RelHasRecCollab -> "hasRecursiveCollaborator"
 
 data Relationship u = Relationship
     { relationshipId           :: Maybe (ObjURI u)

th/models

@@ -1861,18 +1861,7 @@ EffortRemove
 
 Squad
     role   Role
-
+    holder ResourceId
-SquadHolderProject
-    squad   SquadId
-    project ProjectId
-
-    UniqueSquadHolderProject squad
-
-SquadHolderComponent
-    squad     SquadId
-    component KomponentId
-
-    UniqueSquadHolderComponent squad
 
 ---------------------------------- Squad topic --------------------------------
 

th/routes

@@ -234,6 +234,8 @@
 /repos/#RepoKeyHashid/collabs                     RepoCollabsR       GET
 /repos/#RepoKeyHashid/projects                    RepoProjectsR      GET
 
+/repos/#RepoKeyHashid/teams                       RepoTeamsR         GET
+
 ---- Deck --------------------------------------------------------------------
 
 /decks/#DeckKeyHashid                             DeckR           GET
@@ -266,6 +268,8 @@
 /decks/#DeckKeyHashid/project/approve/#StemId DeckApproveProjectR POST
 /decks/#DeckKeyHashid/project/remove/#StemId  DeckRemoveProjectR  POST
 
+/decks/#DeckKeyHashid/teams                       DeckTeamsR      GET
+
 ---- Ticket ------------------------------------------------------------------
 
 /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid            TicketR            GET
@@ -319,6 +323,8 @@
 /looms/#LoomKeyHashid/collabs                     LoomCollabsR    GET
 /looms/#LoomKeyHashid/projects                    LoomProjectsR   GET
 
+/looms/#LoomKeyHashid/teams                       LoomTeamsR      GET
+
 ---- Cloth -------------------------------------------------------------------
 
 /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid            ClothR            GET