diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 8f40380..dcab196 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 52c8a5f..08a892b 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -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 diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index d793533..028f759 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -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 diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index e61b366..316a637 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -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" diff --git a/th/routes b/th/routes index 3e71d4e..ed9bf7a 100644 --- a/th/routes +++ b/th/routes @@ -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