forge/Vervis
1
0
Fork 0
Code Pull requests Activity

UI: Group: POST handlers for resource add-approve-remove buttons

Browse source
This commit is contained in:
Pere Lev 2024-05-18 13:44:55 +03:00
parent f93f67a098
commit e542c7d531
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
5 changed files with 199 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/Vervis/Foundation.hs
View file

@ -906,6 +906,9 @@ instance YesodBreadcrumbs App where
GroupApproveParentR _ _ -> ("", Nothing)
GroupEffortsR g -> ("Accessible Resources", Just $ GroupR g)
GroupAddEffortR _ -> ("", Nothing)
GroupApproveEffortR _ _ -> ("", Nothing)
GroupRemoveEffortR _ _ -> ("", Nothing)
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
RepoInboxR r -> ("Inbox", Just $ RepoR r)

139
src/Vervis/Handler/Group.hs
View file

@ -46,6 +46,9 @@ module Vervis.Handler.Group
, postGroupApproveParentR
, getGroupEffortsR
, postGroupAddEffortR
, postGroupApproveEffortR
, postGroupRemoveEffortR
@ -788,7 +791,7 @@ addParentForm = renderDivs $
postGroupAddParentR :: KeyHashid Group -> Handler Html
postGroupAddParentR groupHash = do
uParent <- runFormPostRedirect (GroupChildrenR groupHash) addParentForm
uParent <- runFormPostRedirect (GroupParentsR groupHash) addParentForm
encodeRouteHome <- getEncodeRouteHome
let uCollection = encodeRouteHome $ GroupParentsR groupHash
@ -979,8 +982,142 @@ getGroupEffortsR groupHash = do
}
provideHtmlAndAP effortsAP $ redirectToPrettyJSON (GroupEffortsR groupHash)
addEffortForm = renderDivs $ (,)
<$> areq fedUriField "Resource actor URI*" Nothing
<*> areq selectRole "Role*" Nothing
where
selectRole :: Field Handler AP.Role
selectRole = selectField optionsEnum
postGroupAddEffortR :: KeyHashid Group -> Handler Html
postGroupAddEffortR groupHash = do
(uEffort, role) <-
runFormPostRedirect (GroupChildrenR groupHash) addEffortForm
encodeRouteHome <- getEncodeRouteHome
let uCollection = encodeRouteHome $ GroupEffortsR groupHash
groupID <- decodeKeyHashid404 groupHash
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
result <- runExceptT $ do
group <- lift $ runDB $ get404 groupID
(maybeSummary, audience, add) <- C.add personID uEffort uCollection role
cap <- do
let resourceID = groupResource group
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
fromMaybeE maybeItem "You need to be have Admin access to the Group to add resources"
uCap <- lift $ renderActivityURI cap
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AddActivity add
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 "Add sent"
redirect $ GroupEffortsR groupHash
postGroupApproveEffortR :: KeyHashid Group -> EffortId -> Handler Html
postGroupApproveEffortR groupHash effortID = do
groupID <- decodeKeyHashid404 groupHash
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do
group <- MaybeT $ get groupID
Effort _ g <- MaybeT $ get effortID
guard $ groupID == g
uAdd <- lift $ do
add <- getEffortAdd effortID
renderActivityURI add
topic <- lift $ bimap snd snd <$> getEffortTopic effortID
lift $
(groupResource group,uAdd,) <$>
bitraverse
getLocalResource
(getRemoteActorURI <=< getJust)
topic
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
(maybeSummary, audience, accept) <- do
uEffort <-
case pidOrU of
Left lr -> encodeRouteHome . renderLocalResource <$> hashLocalResource lr
Right u -> pure u
let uMe = encodeRouteHome $ GroupR groupHash
C.acceptParentChild personID uAdd uEffort uMe
cap <- do
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
fromMaybeE maybeItem "You need to be have Admin access to the Group to approve resources"
uCap <- lift $ renderActivityURI cap
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
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 "Accept sent"
redirect $ GroupEffortsR groupHash
postGroupRemoveEffortR :: KeyHashid Group -> EffortId -> Handler Html
postGroupRemoveEffortR groupHash effortID = do
groupID <- decodeKeyHashid404 groupHash
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do
group <- MaybeT $ get groupID
Effort _ g <- MaybeT $ get effortID
guard $ groupID == g
_ <- MaybeT $ getBy $ UniqueEffortUsSendDelegator effortID
topic <- lift $ bimap snd snd <$> getEffortTopic effortID
lift $
(groupResource group,) <$>
bitraverse
getLocalResource
(getRemoteActorURI <=< getJust)
topic
(resourceID, pidOrU) <- maybe notFound pure mpidOrU
(maybeSummary, audience, remove) <- do
uEffort <-
case pidOrU of
Left lr -> encodeRouteHome . renderLocalResource <$> hashLocalResource lr
Right u -> pure u
let uCollection = encodeRouteHome $ GroupEffortsR groupHash
C.remove personID uEffort uCollection
cap <- do
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
fromMaybeE maybeItem "You need to be have Admin access to the Group to remove resources"
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 $ GroupEffortsR groupHash

2
src/Vervis/Handler/Project.hs
View file

@ -1033,7 +1033,7 @@ addParentForm = renderDivs $
postProjectAddParentR :: KeyHashid Project -> Handler Html
postProjectAddParentR projectHash = do
uParent <- runFormPostRedirect (ProjectChildrenR projectHash) addParentForm
uParent <- runFormPostRedirect (ProjectParentsR projectHash) addParentForm
encodeRouteHome <- getEncodeRouteHome
let uCollection = encodeRouteHome $ ProjectParentsR projectHash

53
src/Vervis/Persist/Collab.hs
View file

@ -68,6 +68,9 @@ module Vervis.Persist.Collab
, getSquadTeam
, getTeamResources
, getEffortAdd
, getEffortTopic
)
where
@ -1760,3 +1763,53 @@ getTeamResources groupID =
, ra
, effort E.^. EffortId
)
getEffortAdd
:: MonadIO m
=> EffortId
-> ReaderT SqlBackend m
(Either
(LocalActorBy Key, OutboxItemId)
FedURI
)
getEffortAdd effortID = do
usOrThem <-
requireEitherAlt
(getKeyBy $ UniqueEffortOriginUs effortID)
(getKeyBy $ UniqueEffortOriginThem effortID)
"Neither us nor them"
"Both us and them"
add <-
case usOrThem of
Left usID ->
requireEitherAlt
(fmap effortUsGestureLocalAdd <$> getValBy (UniqueEffortUsGestureLocal usID))
(fmap effortUsGestureRemoteAdd <$> getValBy (UniqueEffortUsGestureRemote usID))
"Neither local not remote"
"Both local and remote"
Right themID ->
requireEitherAlt
(fmap effortThemGestureLocalAdd <$> getValBy (UniqueEffortThemGestureLocal themID))
(fmap effortThemGestureRemoteAdd <$> getValBy (UniqueEffortThemGestureRemote themID))
"Neither local not remote"
"Both local and remote"
getActivityIdent add
getEffortTopic
:: MonadIO m
=> EffortId
-> ReaderT SqlBackend m
(Either
(EffortTopicLocalId, ResourceId)
(EffortTopicRemoteId, RemoteActorId)
)
getEffortTopic effortID =
bimap
(\ (Entity k v) -> (k, effortTopicLocalTopic v))
(\ (Entity k v) -> (k, effortTopicRemoteTopic v))
<$>
requireEitherAlt
(getBy $ UniqueEffortTopicLocal effortID)
(getBy $ UniqueEffortTopicRemote effortID)
"Found Effort without topic"
"Found Effort with both local and remote topic"

4
th/routes
View file

@ -200,6 +200,10 @@
/groups/#GroupKeyHashid/efforts GroupEffortsR GET
/groups/#GroupKeyHashid/effort/add GroupAddEffortR POST
/groups/#GroupKeyHashid/effort/approve/#EffortId GroupApproveEffortR POST
/groups/#GroupKeyHashid/effort/remove/#EffortId GroupRemoveEffortR POST
---- Repo --------------------------------------------------------------------
/repos/#RepoKeyHashid RepoR GET