UI: Team & team members HTML page + AP JSON object

src/Vervis/Foundation.hs

@@ -882,6 +882,8 @@ instance YesodBreadcrumbs App where
 
         GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g)
 
+        GroupMembersR g -> ("Members", Just $ GroupR g)
+
         RepoR r             -> ("Repo ^" <> keyHashidText r, Just HomeR)
         RepoInboxR r        -> ("Inbox", Just $ RepoR r)
         RepoOutboxR r       -> ("Outbox", Just $ RepoR r)

src/Vervis/Handler/Group.hs

@@ -24,7 +24,7 @@ module Vervis.Handler.Group
 
     , getGroupStampR
 
-
+    , getGroupMembersR
 
 
 
@@ -35,7 +35,6 @@ module Vervis.Handler.Group
     , getGroupsR
     , postGroupsR
     , getGroupNewR
-    , getGroupMembersR
     , postGroupMembersR
     , getGroupMemberNewR
     , getGroupMemberR
@@ -45,16 +44,37 @@ module Vervis.Handler.Group
     )
 where
 
+import Control.Applicative
+import Control.Monad
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.Aeson
+import Data.Bifunctor
+import Data.Bitraversable
+import Data.ByteString (ByteString)
+import Data.Default.Class
+import Data.Foldable
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
-import Data.ByteString (ByteString)
+import Network.HTTP.Types.Method
+import Text.Blaze.Html (Html)
+import Yesod.Auth (requireAuth)
 import Yesod.Core
-import Yesod.Core.Content (TypedContent)
+import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
-import Yesod.Persist.Core
+import Yesod.Form.Functions (runFormPost, runFormGet)
+import Yesod.Form.Types (FormResult (..))
+import Yesod.Persist.Core (runDB, get404, getBy404)
 
+import qualified Data.ByteString.Lazy as BL
+import qualified Database.Esqueleto as E
+
+import Database.Persist.JSON
+import Development.PatchMediaType
 import Network.FedURI
+import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@@ -62,13 +82,41 @@ import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Data.Paginate.Local
+import Database.Persist.Local
+import Yesod.Form.Local
+import Yesod.Persist.Local
+
+import Vervis.Access
+import Vervis.API
+import Vervis.Data.Collab
 import Vervis.Federation.Auth
+import Vervis.Federation.Collab
+import Vervis.Federation.Discussion
+import Vervis.Federation.Offer
+import Vervis.Federation.Ticket
 import Vervis.FedURI
+import Vervis.Form.Ticket
+import Vervis.Form.Tracker
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Paginate
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.Settings
+import Vervis.Ticket
+import Vervis.TicketFilter
+import Vervis.Time
 import Vervis.Web.Actor
+import Vervis.Widget
+import Vervis.Widget.Person
+import Vervis.Widget.Ticket
+import Vervis.Widget.Tracker
+
+import qualified Vervis.Client as C
 
 getGroupR :: KeyHashid Group -> Handler TypedContent
 getGroupR groupHash = do
@@ -85,7 +133,7 @@ getGroupR groupHash = do
     perActor <- asksSite $ appPerActorKeys . appSettings
 
     let route mk = encodeRouteLocal $ mk groupHash
-        groupAP = AP.Actor
+        actorAP = AP.Actor
             { AP.actorLocal = AP.ActorLocal
                 { AP.actorId         = route GroupR
                 , AP.actorInbox      = route GroupInboxR
@@ -100,16 +148,20 @@ getGroupR groupHash = do
                 , AP.actorSshKeys    = []
                 }
             , AP.actorDetail = AP.ActorDetail
-                { AP.actorType       = AP.ActorTypeOther "Group"
+                { AP.actorType       = AP.ActorTypeTeam
                 , AP.actorUsername   = Nothing
                 , AP.actorName       = Just $ actorName actor
                 , AP.actorSummary    = Just $ actorDesc actor
                 }
             }
+        groupAP = AP.Team
+            { AP.teamActor    = actorAP
+            , AP.teamChildren = []
+            , AP.teamParents  = []
+            , AP.teamMembers  = encodeRouteLocal $ GroupMembersR groupHash
+            }
 
-    provideHtmlAndAP groupAP $ redirectToPrettyJSON here
+    provideHtmlAndAP groupAP $(widgetFile "group/one")
-    where
-    here = GroupR groupHash
 
 getGroupInboxR :: KeyHashid Group -> Handler TypedContent
 getGroupInboxR = getInbox GroupInboxR groupActor
@@ -136,7 +188,80 @@ getGroupMessageR _ _ = notFound
 getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent
 getGroupStampR = servePerActorKey groupActor LocalActorGroup
 
-
+getGroupMembersR :: KeyHashid Group -> Handler TypedContent
+getGroupMembersR groupHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    members <- runDB $ do
+        _group <- get404 groupID
+        grants <-
+            --getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
+            pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
+        for grants $ \ (role, actor, _ct, time) ->
+            (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
+    h <- asksSite siteInstanceHost
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashPerson <- getEncodeKeyHashid
+    let makeItem (role, time, i) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome $ GroupR groupHash
+            , AP.relationshipProperty     = Left AP.RelHasMember
+            , AP.relationshipObject       =
+                case i of
+                    Left personID -> encodeRouteHome $ PersonR $ hashPerson personID
+                    Right u -> u
+            , AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        membersAP = AP.Collection
+            { AP.collectionId         = encodeRouteLocal $ GroupMembersR groupHash
+            , AP.collectionType       = CollectionTypeUnordered
+            , AP.collectionTotalItems = Just $ length members
+            , AP.collectionCurrent    = Nothing
+            , AP.collectionFirst      = Nothing
+            , AP.collectionLast       = Nothing
+            , AP.collectionItems      = map (Doc h . makeItem) members
+            , AP.collectionContext    =
+                Just $ encodeRouteLocal $ GroupR groupHash
+            }
+    provideHtmlAndAP membersAP $ getHtml groupID
+    where
+    getHtml groupID = do
+        (group, actor, members{-, invites, joins-}) <- handlerToWidget $ runDB $ do
+            group <- get404 groupID
+            actor <- getJust $ groupActor group
+            members <- do
+                grants <-
+                    --getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
+                    pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
+                for grants $ \ (role, actor, ct, time) ->
+                    (,role,ct,time) <$> getPersonWidgetInfo actor
+            {-
+            invites <- do
+                invites' <-
+                    getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID
+                for invites' $ \ (inviter, recip, time, role) -> (,,,)
+                    <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+                    <*> getPersonWidgetInfo recip
+                    <*> pure time
+                    <*> pure role
+            joins <- do
+                joins' <-
+                    getTopicJoins CollabTopicGroupCollab CollabTopicGroupGroup groupID
+                for joins' $ \ (recip, time, role) ->
+                    (,time,role) <$> getPersonWidgetInfo recip
+            -}
+            return (group, actor, members{-, invites, joins-})
+        $(widgetFile "group/members")
+        where
+        grabPerson actorID = do
+            actorByKey <- getLocalActor actorID
+            case actorByKey of
+                LocalActorPerson personID -> return personID
+                _ -> error "Surprise, local inviter actor isn't a Person"
 
 
 
@@ -203,24 +328,6 @@ getGroupNewR = do
     ((_result, widget), enctype) <- runFormPost newGroupForm
     defaultLayout $(widgetFile "group/new")
 
-getGroupMembersR :: ShrIdent -> Handler Html
-getGroupMembersR shar = do
-    (group, members) <- runDB $ do
-        Entity sid s <- getBy404 $ UniqueSharer shar
-        Entity gid _g <- getBy404 $ UniqueGroup sid
-        ms <- select $ from $ \ (member, person, sharer) -> do
-            where_ $
-                member ^. GroupMemberGroup  E.==. val gid            &&.
-                member ^. GroupMemberPerson E.==. person ^. PersonId &&.
-                person ^. PersonIdent       E.==. sharer ^. SharerId
-            orderBy
-                [ asc $ member ^. GroupMemberRole
-                , asc $ sharer ^. SharerIdent
-                ]
-            return sharer
-        return (s, ms)
-    defaultLayout $(widgetFile "group/member/list")
-
 getgid :: ShrIdent -> AppDB GroupId
 getgid shar = do
     Entity s _ <- getBy404 $ UniqueSharer shar

src/Vervis/Widget/Tracker.hs

@@ -19,6 +19,7 @@ module Vervis.Widget.Tracker
     , projectNavW
     , componentLinkFedW
     , projectLinkFedW
+    , groupNavW
     )
 where
 
@@ -50,6 +51,11 @@ projectNavW (Entity projectID project) actor = do
     projectHash <- encodeKeyHashid projectID
     $(widgetFile "project/widget/nav")
 
+groupNavW :: Entity Group -> Actor -> Widget
+groupNavW (Entity groupID group) actor = do
+    groupHash <- encodeKeyHashid groupID
+    $(widgetFile "group/nav")
+
 componentLinkW :: ComponentBy Key -> Actor -> Widget
 componentLinkW (ComponentRepo k) actor = do
     h <- encodeKeyHashid k

src/Web/ActivityPub.hs

@@ -51,6 +51,7 @@ module Web.ActivityPub
     , Resource (..)
     , ResourceWithCollections (..)
     , Project (..)
+    , Team (..)
 
       -- * Content objects
     , Note (..)
@@ -917,6 +918,44 @@ instance ActivityPub Project where
         <> "components"     .= ObjURI h components
         <> "collaborators"  .= ObjURI h collabs
 
+data Team u = Team
+    { teamActor    :: Actor u
+    , teamChildren :: [ObjURI u]
+    , teamParents  :: [ObjURI u]
+    , teamMembers  :: LocalURI
+    }
+
+instance ActivityPub Team where
+    jsonldContext _ = [as2Context, secContext, forgeContext]
+    parseObject o = do
+        (h, a) <- parseObject o
+        unless (actorType (actorDetail a) == ActorTypeTeam) $
+            fail "Actor type isn't Team"
+        fmap (h,) $
+            Team a
+                <$> (do c <- o .: "subteams"
+                        typ <- c .: "type"
+                        unless (typ == ("Collection" :: Text)) $
+                            fail "subteams.type isn't Collection"
+                        items <- c .: "items"
+                        mtotal <- c .:? "totalItems"
+                        for_ mtotal $ \ total ->
+                            unless (length items == total) $
+                                fail "Incorrect totalItems"
+                        return items
+                    )
+                <*> o .:? "context" .!= []
+                <*> withAuthorityO h (o .: "members")
+    toSeries h (Team actor children parents members)
+        =  toSeries h actor
+        <> "subteams" `pair` pairs
+            (  "type"       .= ("Collection" :: Text)
+            <> "items"      .= children
+            <> "totalItems" .= length children
+            )
+        <> "context"        .= parents
+        <> "members"        .= ObjURI h members
+
 data Audience u = Audience
     { audienceTo        :: [ObjURI u]
     , audienceBto       :: [ObjURI u]
@@ -1077,7 +1116,9 @@ instance ActivityPub Note where
         <> "content"      .=  content
         <> "mediaType"    .=  ("text/html" :: Text)
 
-data RelationshipProperty = RelDependsOn | RelHasCollab deriving Eq
+data RelationshipProperty =
+    RelDependsOn | RelHasCollab | RelHasMember
+    deriving Eq
 
 instance FromJSON RelationshipProperty where
     parseJSON = withText "RelationshipProperty" parse
@@ -1085,6 +1126,7 @@ instance FromJSON RelationshipProperty where
         parse t
             | t == "dependsOn" = pure RelDependsOn
             | t == "hasCollaborator" = pure RelHasCollab
+            | t == "hasMember" = pure RelHasMember
             | otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t
 
 instance ToJSON RelationshipProperty where
@@ -1093,6 +1135,7 @@ instance ToJSON RelationshipProperty where
         toEncoding $ case at of
             RelDependsOn -> "dependsOn" :: Text
             RelHasCollab -> "hasCollaborator"
+            RelHasMember -> "hasMember"
 
 data Relationship u = Relationship
     { relationshipId           :: Maybe (ObjURI u)

templates/group/members.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,16 +12,18 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
 $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-<h2>
+^{groupNavW (Entity groupID group) actor}
-  #{fromMaybe (shr2text $ sharerIdent group) $ sharerName group}
 
-<p>
+<h2>Members
-  Created on #{showDate $ sharerCreated group}.
 
-<p>
+<table>
-  Members:
+  <tr>
-
+    <th>Role
-<ul>
+    <th>Member
-  $forall Entity _sid s <- members
+    <th>Since
-    <li>
+  $forall (person, role, ctID, since) <- members
-      ^{sharerLinkW s}
+    <tr>
+      <td>#{show role}
+      <td>^{personLinkFedW person}
+      <td>#{showDate since}
+      $#<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}

templates/group/nav.hamlet

@@ -0,0 +1,34 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<div>
+  <span>
+    [[ 🏗
+    <a href=@{GroupR groupHash}>
+      &#{keyHashidText groupHash} #{actorName actor}
+    ]] ::
+  <span>
+    <a href=@{GroupInboxR groupHash}>
+      [📥 Inbox]
+  <span>
+    <a href=@{GroupOutboxR groupHash}>
+      [📤 Outbox]
+  <span>
+    <a href=@{GroupFollowersR groupHash}>
+      [🐤 Followers]
+  <span>
+    <a href=@{GroupMembersR groupHash}>
+      [🤝 Members]
+  <span>
+    [✏ Edit]

templates/group/one.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,5 +12,4 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
 $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-<p>
+^{groupNavW (Entity groupID group) actor}
-  <a href=@{GroupMembersR shar}>Members

th/routes

@@ -166,6 +166,8 @@
 
 /groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid         GroupStampR      GET
 
+/groups/#GroupKeyHashid/members                         GroupMembersR    GET
+
 ---- Repo --------------------------------------------------------------------
 
 /repos/#RepoKeyHashid                             RepoR              GET