UI: Project: Provide buttons for removing children
This commit is contained in:
Pere Lev
parent
07d9f9adab
commit
abefcbd310
6 changed files with 202 additions and 11 deletions
|
|
@ -23,7 +23,7 @@ module Vervis.Data.Actor
|
|||
, parseStampRoute
|
||||
, localActorID
|
||||
, localResourceID
|
||||
, parseLocalURI
|
||||
, WA.parseLocalURI
|
||||
, parseFedURIOld
|
||||
, parseLocalActorE
|
||||
, parseLocalActorE'
|
||||
|
|
@ -33,6 +33,8 @@ module Vervis.Data.Actor
|
|||
, parseActorURI'
|
||||
, parseResourceURI
|
||||
, parseResourceURI'
|
||||
, renderActivityURI
|
||||
, renderActivityURI'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -51,7 +53,6 @@ import qualified Data.HashMap.Strict as HM
|
|||
import qualified Data.Text as T
|
||||
|
||||
import Network.FedURI
|
||||
import Web.Actor
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Actor
|
||||
import Yesod.FedURI
|
||||
|
|
@ -198,7 +199,7 @@ parseFedURIOld
|
|||
parseFedURIOld u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocalOld h
|
||||
if hl
|
||||
then Left <$> parseLocalURI lu
|
||||
then Left <$> WA.parseLocalURI lu
|
||||
else pure $ Right u
|
||||
|
||||
parseLocalActorE
|
||||
|
|
@ -238,7 +239,7 @@ parseActorURI u = do
|
|||
|
||||
parseActorURI' :: FedURI -> VA.ActE (Either (LocalActorBy Key) FedURI)
|
||||
parseActorURI' u = do
|
||||
routeOrRemote <- parseFedURI u
|
||||
routeOrRemote <- WA.parseFedURI u
|
||||
bitraverse
|
||||
parseLocalActorE'
|
||||
pure
|
||||
|
|
@ -257,8 +258,31 @@ parseResourceURI u = do
|
|||
|
||||
parseResourceURI' :: FedURI -> VA.ActE (Either (LocalResourceBy Key) FedURI)
|
||||
parseResourceURI' u = do
|
||||
routeOrRemote <- parseFedURI u
|
||||
routeOrRemote <- WA.parseFedURI u
|
||||
bitraverse
|
||||
parseLocalResourceE'
|
||||
pure
|
||||
routeOrRemote
|
||||
|
||||
renderActivityURI
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> Either (LocalActorBy Key, OutboxItemId) FedURI
|
||||
-> m FedURI
|
||||
renderActivityURI = \case
|
||||
Left (la, i) -> do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
lah <- hashLocalActor la
|
||||
ih <- encodeKeyHashid i
|
||||
return $ encodeRouteHome $ activityRoute lah ih
|
||||
Right u -> pure u
|
||||
|
||||
renderActivityURI'
|
||||
:: Either (LocalActorBy Key, OutboxItemId) FedURI
|
||||
-> VA.Act FedURI
|
||||
renderActivityURI' = \case
|
||||
Left (la, i) -> do
|
||||
encodeRouteHome <- WA.getEncodeRouteHome
|
||||
lah <- VA.hashLocalActor la
|
||||
ih <- WAP.encodeKeyHashid i
|
||||
return $ encodeRouteHome $ activityRoute lah ih
|
||||
Right u -> pure u
|
||||
|
|
|
|||
|
|
@ -1037,3 +1037,5 @@ instance YesodBreadcrumbs App where
|
|||
ProjectChildrenR j -> ("Child projects", Just $ ProjectR j)
|
||||
ProjectParentsR j -> ("Parent projects", Just $ ProjectR j)
|
||||
ProjectParentLiveR j d -> (keyHashidText d, Just $ ProjectParentsR j)
|
||||
|
||||
ProjectRemoveChildR _ _ -> ("", Nothing)
|
||||
|
|
|
|||
|
|
@ -43,6 +43,8 @@ module Vervis.Handler.Project
|
|||
, getProjectChildrenR
|
||||
, getProjectParentsR
|
||||
, getProjectParentLiveR
|
||||
|
||||
, postProjectRemoveChildR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -97,6 +99,7 @@ import Yesod.Persist.Local
|
|||
import Vervis.Access
|
||||
import Vervis.Actor (resourceToActor)
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Discussion
|
||||
|
|
@ -598,7 +601,7 @@ getProjectChildrenR projectHash = do
|
|||
encodeRouteHome $ ProjectR $ hashProject 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 $ ProjectR projectHash
|
||||
|
|
@ -625,13 +628,13 @@ getProjectChildrenR projectHash = do
|
|||
where
|
||||
|
||||
getChildren projectID = 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 sourceID) ->
|
||||
(role, time, Left (child, actor), sourceID)
|
||||
)
|
||||
<$> getLocals projectID
|
||||
)
|
||||
(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 projectID
|
||||
)
|
||||
|
|
@ -651,6 +654,7 @@ getProjectChildrenR projectHash = do
|
|||
, grant E.^. OutboxItemPublished
|
||||
, topic E.^. SourceTopicProjectChild
|
||||
, actor
|
||||
, source E.^. SourceId
|
||||
)
|
||||
|
||||
getRemotes projectID =
|
||||
|
|
@ -670,9 +674,14 @@ getProjectChildrenR projectHash = do
|
|||
, i
|
||||
, ro
|
||||
, ra
|
||||
, source E.^. SourceId
|
||||
)
|
||||
|
||||
getHtml projectID project actor children = do
|
||||
mp <- maybeAuthId
|
||||
haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do
|
||||
personID <- MaybeT $ pure mp
|
||||
MaybeT $ getCapability personID (Left $ projectResource project) AP.RoleAdmin
|
||||
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
|
||||
|
|
@ -909,3 +918,60 @@ getProjectParentLiveR projectHash startHash = do
|
|||
Entity _ (DestHolderProject _ j) <-
|
||||
getBy404 $ UniqueDestHolderProject destID
|
||||
unless (j == projectID) notFound
|
||||
|
||||
postProjectRemoveChildR :: KeyHashid Project -> SourceId -> Handler Html
|
||||
postProjectRemoveChildR projectHash sourceID = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
project <- MaybeT $ get projectID
|
||||
_ <- MaybeT $ get sourceID
|
||||
SourceHolderProject _ j <-
|
||||
MaybeT $ getValBy $ UniqueSourceHolderProject sourceID
|
||||
guard $ projectID == j
|
||||
_ <- MaybeT $ getBy $ UniqueSourceUsSendDelegator sourceID
|
||||
|
||||
topic <- lift $ do
|
||||
t <- bimap snd snd <$> getSourceTopic sourceID
|
||||
bitraverse
|
||||
(\case
|
||||
Left j' -> pure j'
|
||||
Right _g -> error "I'm a project, I have a Source with topic being Group"
|
||||
)
|
||||
pure
|
||||
t
|
||||
lift $
|
||||
(projectResource project,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uChild <-
|
||||
case pidOrU of
|
||||
Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
|
||||
Right u -> pure u
|
||||
let uCollection = encodeRouteHome $ ProjectChildrenR projectHash
|
||||
C.remove personID uChild uCollection
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Project to remove people"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Remove sent"
|
||||
redirect $ ProjectChildrenR projectHash
|
||||
|
|
|
|||
|
|
@ -52,6 +52,7 @@ module Vervis.Persist.Collab
|
|||
, getGrantActivityBody
|
||||
|
||||
, getPermitsForResource
|
||||
, getCapability
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1074,3 +1075,95 @@ getPermitsForResource personID actor = do
|
|||
return (Right u, Right (inztance, remoteObject, remoteActor))
|
||||
return (uExt, role, Just via)
|
||||
return $ directsFinal ++ extsFinal
|
||||
|
||||
getCapability
|
||||
:: MonadIO m
|
||||
=> PersonId
|
||||
-> Either ResourceId RemoteActorId
|
||||
-> AP.Role
|
||||
-> ReaderT SqlBackend m
|
||||
(Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI))
|
||||
getCapability personID actor role = do
|
||||
maybeDirect <-
|
||||
case actor of
|
||||
Left resourceID ->
|
||||
fmap (fmap (Left . (resourceID,)) . listToMaybe) $
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
|
||||
E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
|
||||
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
topic E.^. PermitTopicLocalTopic E.==. E.val resourceID E.&&.
|
||||
permit E.^. PermitRole E.>=. E.val role
|
||||
E.orderBy [E.desc $ enable E.^. PermitTopicEnableLocalId]
|
||||
E.limit 1
|
||||
return $ enable E.^. PermitTopicEnableLocalGrant
|
||||
Right actorID ->
|
||||
fmap (fmap Right . listToMaybe) $
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
|
||||
E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
|
||||
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
topic E.^. PermitTopicRemoteActor E.==. E.val actorID E.&&.
|
||||
permit E.^. PermitRole E.>=. E.val role
|
||||
E.orderBy [E.desc $ enable E.^. PermitTopicEnableRemoteId]
|
||||
E.limit 1
|
||||
return $ enable E.^. PermitTopicEnableRemoteGrant
|
||||
maybeDirect' <- for maybeDirect $ \case
|
||||
Left (resourceID, E.Value grantID) -> do
|
||||
lr <- getLocalResource resourceID
|
||||
let la = resourceToActor lr
|
||||
return $ Left (la, grantID)
|
||||
Right (E.Value grantID) -> do
|
||||
grant <- getJust grantID
|
||||
u <- getRemoteActivityURI grant
|
||||
return $ Right u
|
||||
maybeExt <-
|
||||
listToMaybe <$>
|
||||
case actor of
|
||||
Left resourceID ->
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do
|
||||
E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceLocalPermit
|
||||
E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit
|
||||
E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit
|
||||
E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
resource E.^. PermitTopicExtendResourceLocalResource E.==. E.val resourceID E.&&.
|
||||
extend E.^. PermitTopicExtendRole E.>=. E.val role
|
||||
E.orderBy [E.desc $ extend E.^. PermitTopicExtendId]
|
||||
E.limit 1
|
||||
return $ extend E.^. PermitTopicExtendId
|
||||
Right actorID ->
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do
|
||||
E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceRemotePermit
|
||||
E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit
|
||||
E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit
|
||||
E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
resource E.^. PermitTopicExtendResourceRemoteActor E.==. E.val actorID E.&&.
|
||||
extend E.^. PermitTopicExtendRole E.>=. E.val role
|
||||
E.orderBy [E.desc $ extend E.^. PermitTopicExtendId]
|
||||
E.limit 1
|
||||
return $ extend E.^. PermitTopicExtendId
|
||||
maybeExt' <- for maybeExt $ \ (E.Value extendID) -> do
|
||||
sender <-
|
||||
requireEitherAlt
|
||||
(getValBy $ UniquePermitTopicExtendLocal extendID)
|
||||
(getValBy $ UniquePermitTopicExtendRemote extendID)
|
||||
"PermitTopicExtend* neither"
|
||||
"PermitTopicExtend* both"
|
||||
case sender of
|
||||
Left (PermitTopicExtendLocal _ enableID grantID) -> do
|
||||
PermitTopicEnableLocal _ topicID _ <- getJust enableID
|
||||
PermitTopicLocal _ resourceID <- getJust topicID
|
||||
byk <- getLocalResource resourceID
|
||||
let byk' = resourceToActor byk
|
||||
return $ Left (byk', grantID)
|
||||
Right (PermitTopicExtendRemote _ _enableID grantID) -> do
|
||||
grant <- getJust grantID
|
||||
u <- getRemoteActivityURI grant
|
||||
return $ Right u
|
||||
return $ maybeDirect' <|> maybeExt'
|
||||
|
|
|
|||
|
|
@ -22,11 +22,15 @@ $# <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, sourceID) <- children
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>#{showDate since}
|
||||
<td>^{projectLinkFedW child}
|
||||
$if haveAdmin
|
||||
<td>^{buttonW POST "Remove" (ProjectRemoveChildR projectHash sourceID)}
|
||||
|
||||
<h2>Invites
|
||||
|
||||
|
|
|
|||
|
|
@ -353,3 +353,5 @@
|
|||
/projects/#ProjectKeyHashid/children ProjectChildrenR GET
|
||||
/projects/#ProjectKeyHashid/parents ProjectParentsR GET
|
||||
/projects/#ProjectKeyHashid/parents/#DestUsStartKeyHashid/live ProjectParentLiveR GET
|
||||
|
||||
/projects/#ProjectKeyHashid/children/remove/#SourceId ProjectRemoveChildR POST
|
||||
|
|
|
|||
Loading…
Reference in a new issue