From 2797e5f3beda255d40847dd89ea4d9600d029607 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 21 Nov 2023 15:01:51 +0200 Subject: [PATCH] UI: Team & team members HTML page + AP JSON object --- src/Vervis/Foundation.hs | 2 + src/Vervis/Handler/Group.hs | 165 +++++++++++++++--- src/Vervis/Widget/Tracker.hs | 6 + src/Web/ActivityPub.hs | 45 ++++- .../{member/list.hamlet => members.hamlet} | 26 +-- templates/group/nav.hamlet | 34 ++++ templates/group/one.hamlet | 5 +- th/routes | 2 + 8 files changed, 240 insertions(+), 45 deletions(-) rename templates/group/{member/list.hamlet => members.hamlet} (54%) create mode 100644 templates/group/nav.hamlet diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 4963e87..dcc07cb 100644 --- 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) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 2d2570c..c14b38c 100644 --- 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 diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index 7acf220..17edc8e 100644 --- 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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index b78bcd2..d022c47 100644 --- 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) diff --git a/templates/group/member/list.hamlet b/templates/group/members.hamlet similarity index 54% rename from templates/group/member/list.hamlet rename to templates/group/members.hamlet index e869c65..c5ac3f7 100644 --- a/templates/group/member/list.hamlet +++ b/templates/group/members.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2019 by fr33domlover . +$# Written in 2016, 2019, 2023 by fr33domlover . $# $# ♡ 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 $# . -

- #{fromMaybe (shr2text $ sharerIdent group) $ sharerName group} +^{groupNavW (Entity groupID group) actor} -

- Created on #{showDate $ sharerCreated group}. +

Members -

- Members: - -