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

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)

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
 
 
 

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
 

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"

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