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

2023-11-21 15:01:51 +02:00 · 2023-11-21 15:01:51 +02:00 · 2797e5f3be
commit 2797e5f3be
parent 80a08dea0a
8 changed files with 240 additions and 45 deletions
--- a/src/Vervis/Foundation.hs
+++ b/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)
--- a/src/Vervis/Handler/Group.hs
+++ b/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.Persist.Core
+import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
+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
-    where
-    here = GroupR groupHash
+    provideHtmlAndAP groupAP $(widgetFile "group/one")

 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
--- a/src/Vervis/Widget/Tracker.hs
+++ b/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
--- a/src/Web/ActivityPub.hs
+++ b/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)
--- a/templates/group/member/list.hamlet
+++ b/templates/group/member/list.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>
-  #{fromMaybe (shr2text $ sharerIdent group) $ sharerName group}
+^{groupNavW (Entity groupID group) actor}

-<p>
-  Created on #{showDate $ sharerCreated group}.
+<h2>Members

-<p>
-  Members:
-
-<ul>
-  $forall Entity _sid s <- members
-    <li>
-      ^{sharerLinkW s}
+<table>
+  <tr>
+    <th>Role
+    <th>Member
+    <th>Since
+  $forall (person, role, ctID, since) <- members
+    <tr>
+      <td>#{show role}
+      <td>^{personLinkFedW person}
+      <td>#{showDate since}
+      $#<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
--- a/templates/group/nav.hamlet
+++ b/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]
--- a/templates/group/one.hamlet
+++ b/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>
-  <a href=@{GroupMembersR shar}>Members
+^{groupNavW (Entity groupID group) actor}
--- a/th/routes
+++ b/th/routes
@ -166,6 +166,8 @@

 /groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid         GroupStampR      GET

+/groups/#GroupKeyHashid/members                         GroupMembersR    GET
+
 ---- Repo --------------------------------------------------------------------

 /repos/#RepoKeyHashid                             RepoR              GET