UI: Group: Display parent and child invites & approve-remove buttons
This commit is contained in:
Pere Lev
parent
533fc60fe1
commit
74af2ea223
3 changed files with 244 additions and 17 deletions
|
|
@ -62,6 +62,7 @@ module Vervis.Handler.Group
|
|||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
|
@ -72,7 +73,7 @@ import Data.ByteString (ByteString)
|
|||
import Data.Default.Class
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
|
|
@ -416,15 +417,15 @@ getGroupChildrenR groupHash = do
|
|||
actor <- getJust $ groupActor group
|
||||
children <- getChildren groupID
|
||||
return (actor, group, children)
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hashGroup <- getEncodeKeyHashid
|
||||
h <- asksSite siteInstanceHost
|
||||
let makeId (Left (childID, _)) =
|
||||
encodeRouteHome $ GroupR $ hashGroup childID
|
||||
makeId (Right (i, ro, _)) =
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
makeItem (role, time, i) = AP.Relationship
|
||||
makeItem (role, time, i, _) = AP.Relationship
|
||||
{ AP.relationshipId = Nothing
|
||||
, AP.relationshipExtraTypes = []
|
||||
, AP.relationshipSubject = encodeRouteHome $ GroupR groupHash
|
||||
|
|
@ -451,13 +452,13 @@ getGroupChildrenR groupHash = do
|
|||
where
|
||||
|
||||
getChildren groupID = fmap (sortOn $ view _2) $ liftA2 (++)
|
||||
(map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor) ->
|
||||
(role, time, Left (child, actor))
|
||||
(map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor, E.Value destID) ->
|
||||
(role, time, Left (child, actor), destID)
|
||||
)
|
||||
<$> getLocals groupID
|
||||
)
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
|
||||
(role, time, Right (i, ro, ra))
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value destID) ->
|
||||
(role, time, Right (i, ro, ra), destID)
|
||||
)
|
||||
<$> getRemotes groupID
|
||||
)
|
||||
|
|
@ -478,6 +479,7 @@ getGroupChildrenR groupHash = do
|
|||
, grant E.^. OutboxItemPublished
|
||||
, topic E.^. DestTopicGroupChild
|
||||
, actor
|
||||
, dest E.^. DestId
|
||||
)
|
||||
|
||||
getRemotes groupID =
|
||||
|
|
@ -498,10 +500,80 @@ getGroupChildrenR groupHash = do
|
|||
, i
|
||||
, ro
|
||||
, ra
|
||||
, dest E.^. DestId
|
||||
)
|
||||
|
||||
getHtml groupID group actor children = do
|
||||
mp <- maybeAuthId
|
||||
haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do
|
||||
personID <- MaybeT $ pure mp
|
||||
MaybeT $ getCapability personID (Left $ groupResource group) AP.RoleAdmin
|
||||
((_, widgetAP), enctypeAP) <- runFormPost addChildForm
|
||||
invites <- handlerToWidget $ runDB $ do
|
||||
dests <- E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.LeftOuterJoin` accept `E.LeftOuterJoin` delegl `E.LeftOuterJoin` delegr) -> do
|
||||
E.on $ accept E.?. DestUsAcceptId E.==. delegr E.?. DestThemSendDelegatorRemoteDest
|
||||
E.on $ accept E.?. DestUsAcceptId E.==. delegl E.?. DestThemSendDelegatorLocalDest
|
||||
E.on $ E.just (dest E.^. DestId) E.==. accept E.?. DestUsAcceptDest
|
||||
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
|
||||
E.where_ $
|
||||
holder E.^. DestHolderGroupGroup E.==. E.val groupID E.&&.
|
||||
E.isNothing (delegl E.?. DestThemSendDelegatorLocalId) E.&&.
|
||||
E.isNothing (delegr E.?. DestThemSendDelegatorRemoteId)
|
||||
E.orderBy [E.asc $ dest E.^. DestId]
|
||||
return dest
|
||||
for dests $ \ (Entity destID (Dest role)) -> do
|
||||
child <- do
|
||||
topic <- getDestTopic destID
|
||||
bitraverse
|
||||
(\ (_, e) -> do
|
||||
jID <-
|
||||
case e of
|
||||
Right j -> pure j
|
||||
Left _ -> error "I'm a Group but my child is a Project"
|
||||
j <- getJust jID
|
||||
actor <- getJust $ groupActor j
|
||||
return (jID, actor)
|
||||
)
|
||||
(\ (_, actorID) -> getRemoteActorData actorID)
|
||||
topic
|
||||
accept <- isJust <$> getBy (UniqueDestUsAccept destID)
|
||||
((inviter, time), us) <- do
|
||||
usOrThem <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniqueDestOriginUs destID)
|
||||
(getKeyBy $ UniqueDestOriginThem destID)
|
||||
"Neither us nor them"
|
||||
"Both us and them"
|
||||
(addOrActor, us) <-
|
||||
case usOrThem of
|
||||
Left _usID -> (,True) <$>
|
||||
requireEitherAlt
|
||||
(fmap destUsGestureLocalActivity <$> getValBy (UniqueDestUsGestureLocal destID))
|
||||
(fmap (destUsGestureRemoteActor &&& destUsGestureRemoteActivity) <$> getValBy (UniqueDestUsGestureRemote destID))
|
||||
"Neither local not remote"
|
||||
"Both local and remote"
|
||||
Right themID -> (,False) <$>
|
||||
requireEitherAlt
|
||||
(fmap destThemGestureLocalAdd <$> getValBy (UniqueDestThemGestureLocal themID))
|
||||
(fmap (destThemGestureRemoteActor &&& destThemGestureRemoteAdd) <$> getValBy (UniqueDestThemGestureRemote themID))
|
||||
"Neither local not remote"
|
||||
"Both local and remote"
|
||||
(,us) <$> case addOrActor of
|
||||
Left addID -> do
|
||||
OutboxItem outboxID _ time <- getJust addID
|
||||
Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
|
||||
(,time) . Left . (,actor) <$> getLocalActor actorID
|
||||
Right (actorID, addID) -> do
|
||||
RemoteActivity _ _ time <- getJust addID
|
||||
(,time) . Right <$> getRemoteActorData actorID
|
||||
return (inviter, us, child, accept, time, role, destID)
|
||||
$(widgetFile "group/children")
|
||||
where
|
||||
getRemoteActorData actorID = do
|
||||
actor <- getJust actorID
|
||||
object <- getJust $ remoteActorIdent actor
|
||||
inztance <- getJust $ remoteObjectInstance object
|
||||
return (inztance, object, actor)
|
||||
|
||||
getGroupChildLiveR :: KeyHashid Group -> KeyHashid DestUsStart -> Handler ()
|
||||
getGroupChildLiveR groupHash startHash = do
|
||||
|
|
@ -531,7 +603,7 @@ getGroupParentsR groupHash = do
|
|||
encodeRouteHome $ GroupR $ hashGroup parentID
|
||||
makeId (Right (i, ro, _)) =
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
makeItem (role, time, i) = AP.Relationship
|
||||
makeItem (role, time, i, _) = AP.Relationship
|
||||
{ AP.relationshipId = Nothing
|
||||
, AP.relationshipExtraTypes = []
|
||||
, AP.relationshipSubject = encodeRouteHome $ GroupR groupHash
|
||||
|
|
@ -558,13 +630,13 @@ getGroupParentsR groupHash = do
|
|||
where
|
||||
|
||||
getParents groupID = fmap (sortOn $ view _2) $ liftA2 (++)
|
||||
(map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor) ->
|
||||
(role, time, Left (parent, actor))
|
||||
(map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor, E.Value sourceID) ->
|
||||
(role, time, Left (parent, actor), sourceID)
|
||||
)
|
||||
<$> getLocals groupID
|
||||
)
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
|
||||
(role, time, Right (i, ro, ra))
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value sourceID) ->
|
||||
(role, time, Right (i, ro, ra), sourceID)
|
||||
)
|
||||
<$> getRemotes groupID
|
||||
)
|
||||
|
|
@ -584,6 +656,7 @@ getGroupParentsR groupHash = do
|
|||
, grant E.^. OutboxItemPublished
|
||||
, topic E.^. SourceTopicGroupParent
|
||||
, actor
|
||||
, source E.^. SourceId
|
||||
)
|
||||
|
||||
getRemotes groupID =
|
||||
|
|
@ -603,10 +676,80 @@ getGroupParentsR groupHash = do
|
|||
, i
|
||||
, ro
|
||||
, ra
|
||||
, source E.^. SourceId
|
||||
)
|
||||
|
||||
getHtml groupID group actor parents = do
|
||||
mp <- maybeAuthId
|
||||
haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do
|
||||
personID <- MaybeT $ pure mp
|
||||
MaybeT $ getCapability personID (Left $ groupResource group) AP.RoleAdmin
|
||||
((_, widgetAC), enctypeAC) <- runFormPost addParentForm
|
||||
invites <- handlerToWidget $ runDB $ do
|
||||
sources <- E.select $ E.from $ \ (source `E.InnerJoin` holder `E.LeftOuterJoin` deleg) -> do
|
||||
E.on $ E.just (source E.^. SourceId) E.==. deleg E.?. SourceUsSendDelegatorSource
|
||||
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
|
||||
E.where_ $
|
||||
holder E.^. SourceHolderGroupGroup E.==. E.val groupID E.&&.
|
||||
E.isNothing (deleg E.?. SourceUsSendDelegatorId)
|
||||
E.orderBy [E.asc $ source E.^. SourceId]
|
||||
return source
|
||||
for sources $ \ (Entity sourceID (Source role)) -> do
|
||||
(parent, accept) <- do
|
||||
topic <- getSourceTopic sourceID
|
||||
accept <-
|
||||
case bimap fst fst topic of
|
||||
Left localID -> isJust <$> getBy (UniqueSourceThemAcceptLocal localID)
|
||||
Right remoteID -> isJust <$> getBy (UniqueSourceThemAcceptRemote remoteID)
|
||||
(,accept) <$> bitraverse
|
||||
(\ (_, e) -> do
|
||||
jID <-
|
||||
case e of
|
||||
Right j -> pure j
|
||||
Left _ -> error "I'm a Group but my parent is a Project"
|
||||
j <- getJust jID
|
||||
actor <- getJust $ groupActor j
|
||||
return (jID, actor)
|
||||
)
|
||||
(\ (_, actorID) -> getRemoteActorData actorID)
|
||||
topic
|
||||
((inviter, time), us) <- do
|
||||
usOrThem <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniqueSourceOriginUs sourceID)
|
||||
(getKeyBy $ UniqueSourceOriginThem sourceID)
|
||||
"Neither us nor them"
|
||||
"Both us and them"
|
||||
(addOrActor, us) <-
|
||||
case usOrThem of
|
||||
Left usID -> (,True) <$>
|
||||
requireEitherAlt
|
||||
(fmap sourceUsGestureLocalAdd <$> getValBy (UniqueSourceUsGestureLocal usID))
|
||||
(fmap (sourceUsGestureRemoteActor &&& sourceUsGestureRemoteAdd) <$> getValBy (UniqueSourceUsGestureRemote usID))
|
||||
"Neither local not remote"
|
||||
"Both local and remote"
|
||||
Right themID -> (,False) <$>
|
||||
requireEitherAlt
|
||||
(fmap sourceThemGestureLocalAdd <$> getValBy (UniqueSourceThemGestureLocal themID))
|
||||
(fmap (sourceThemGestureRemoteActor &&& sourceThemGestureRemoteAdd) <$> getValBy (UniqueSourceThemGestureRemote themID))
|
||||
"Neither local not remote"
|
||||
"Both local and remote"
|
||||
(,us) <$> case addOrActor of
|
||||
Left addID -> do
|
||||
OutboxItem outboxID _ time <- getJust addID
|
||||
Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
|
||||
(,time) . Left . (,actor) <$> getLocalActor actorID
|
||||
Right (actorID, addID) -> do
|
||||
RemoteActivity _ _ time <- getJust addID
|
||||
(,time) . Right <$> getRemoteActorData actorID
|
||||
return (inviter, us, parent, accept, time, role, sourceID)
|
||||
$(widgetFile "group/parents")
|
||||
where
|
||||
getRemoteActorData actorID = do
|
||||
actor <- getJust actorID
|
||||
object <- getJust $ remoteActorIdent actor
|
||||
inztance <- getJust $ remoteObjectInstance object
|
||||
return (inztance, object, actor)
|
||||
|
||||
getGroupMemberLiveR
|
||||
:: KeyHashid Group -> KeyHashid CollabEnable -> Handler ()
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$# Written in 2016, 2019, 2022, 2023, 2024
|
||||
$# by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
$#
|
||||
|
|
@ -21,8 +22,49 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<th>Role
|
||||
<th>Since
|
||||
<th>Child
|
||||
$forall (role, since, child) <- children
|
||||
$if haveAdmin
|
||||
<th>Remove
|
||||
$forall (role, since, child, destID) <- children
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>#{showDate since}
|
||||
<td>^{groupLinkFedW child}
|
||||
$if haveAdmin
|
||||
<td>^{buttonW POST "Remove" (GroupRemoveChildR groupHash destID)}
|
||||
|
||||
$if haveAdmin
|
||||
<p>Add a child:
|
||||
<form method=POST action=@{GroupAddChildR groupHash} enctype=#{enctypeAP}>
|
||||
^{widgetAP}
|
||||
<input type=submit>
|
||||
|
||||
<h2>Invites
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Inviter
|
||||
<th>Via
|
||||
<th>Invited child
|
||||
<th>I accepted?
|
||||
<th>Role
|
||||
<th>Time
|
||||
$if haveAdmin
|
||||
<th>Approve
|
||||
$forall (inviter, us, child, accept, time, role, destID) <- invites
|
||||
<tr>
|
||||
<td>^{actorLinkFedW inviter}
|
||||
<td>
|
||||
$if us
|
||||
Us
|
||||
$else
|
||||
Them
|
||||
<td>^{groupLinkFedW child}
|
||||
<td>
|
||||
$if accept
|
||||
[x]
|
||||
$else
|
||||
[_]
|
||||
<td>#{show role}
|
||||
<td>#{showDate time}
|
||||
$if haveAdmin && (not accept && not us)
|
||||
<td>^{buttonW POST "Approve" (GroupApproveChildR groupHash destID)}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$# Written in 2016, 2019, 2022, 2023, 2024
|
||||
$# by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
$#
|
||||
|
|
@ -20,9 +21,50 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<tr>
|
||||
<th>Role
|
||||
<th>Since
|
||||
<th>Child
|
||||
$forall (role, since, parent) <- parents
|
||||
<th>Parent
|
||||
$if haveAdmin
|
||||
<th>Remove
|
||||
$forall (role, since, parent, sourceID) <- parents
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>#{showDate since}
|
||||
<td>^{groupLinkFedW parent}
|
||||
$if haveAdmin
|
||||
<td>^{buttonW POST "Remove" (GroupRemoveParentR groupHash sourceID)}
|
||||
|
||||
$if haveAdmin
|
||||
<p>Add a parent:
|
||||
<form method=POST action=@{GroupAddParentR groupHash} enctype=#{enctypeAC}>
|
||||
^{widgetAC}
|
||||
<input type=submit>
|
||||
|
||||
<h2>Invites
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Inviter
|
||||
<th>Via
|
||||
<th>Invited parent
|
||||
<th>Parent accepted?
|
||||
<th>Role
|
||||
<th>Time
|
||||
$if haveAdmin
|
||||
<th>Approve
|
||||
$forall (inviter, us, parent, accept, time, role, sourceID) <- invites
|
||||
<tr>
|
||||
<td>^{actorLinkFedW inviter}
|
||||
<td>
|
||||
$if us
|
||||
Us
|
||||
$else
|
||||
Them
|
||||
<td>^{groupLinkFedW parent}
|
||||
<td>
|
||||
$if accept
|
||||
[x]
|
||||
$else
|
||||
[_]
|
||||
<td>#{show role}
|
||||
<td>#{showDate time}
|
||||
$if haveAdmin && (accept && not us)
|
||||
<td>^{buttonW POST "Approve" (GroupApproveParentR groupHash sourceID)}
|
||||
|
|
|
|||
Loading…
Reference in a new issue