UI: Project: Parents: Button for approving a parent

src/Vervis/Foundation.hs

@@ -1045,3 +1045,4 @@ instance YesodBreadcrumbs App where
         ProjectAddParentR _ -> ("", Nothing)
 
         ProjectApproveChildR _ _ -> ("", Nothing)
+        ProjectApproveParentR _ _ -> ("", Nothing)

src/Vervis/Handler/Project.hs

@@ -51,6 +51,7 @@ module Vervis.Handler.Project
     , postProjectAddParentR
 
     , postProjectApproveChildR
+    , postProjectApproveParentR
     )
 where
 
@@ -913,7 +914,7 @@ getProjectParentsR projectHash = do
                         Right (actorID, addID) -> do
                             RemoteActivity _ _ time <- getJust addID
                             (,time) . Right <$> getRemoteActorData actorID
-                return (inviter, us, parent, accept, time, role)
+                return (inviter, us, parent, accept, time, role, destID)
         $(widgetFile "project/parents")
         where
         getRemoteActorData actorID = do
@@ -1176,5 +1177,65 @@ postProjectApproveChildR projectHash sourceID = do
         Left e -> do
             setMessage $ toHtml e
         Right removeID ->
-            setMessage "Add sent"
+            setMessage "Accept sent"
     redirect $ ProjectChildrenR projectHash
+
+postProjectApproveParentR :: KeyHashid Project -> DestId -> Handler Html
+postProjectApproveParentR projectHash destID = 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 destID
+            DestHolderProject _ j <-
+                MaybeT $ getValBy $ UniqueDestHolderProject destID
+            guard $ projectID == j
+
+            uAdd <- lift $ do
+                add <- getDestAdd destID
+                renderActivityURI add
+
+            topic <- lift $ do
+                t <- bimap snd snd <$> getDestTopic destID
+                bitraverse
+                    (\case
+                        Left j' -> pure j'
+                        Right _g -> error "I'm a project, I have a Dest with topic being Group"
+                    )
+                    pure
+                    t
+            lift $
+                (projectResource project,uAdd,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, accept) <- do
+            uParent <-
+                case pidOrU of
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+                    Right u -> pure u
+            let uChild = encodeRouteHome $ ProjectR projectHash
+            C.acceptParentChild personID uAdd uParent uChild
+        cap <- do
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Project to approve parents"
+        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 $ ProjectParentsR projectHash

src/Vervis/Persist/Collab.hs

@@ -36,6 +36,7 @@ module Vervis.Persist.Collab
     , getSourceAdd
     , getDestTopic
     , getDestHolder
+    , getDestAdd
 
     , checkExistingStems
     , checkExistingPermits
@@ -548,6 +549,47 @@ getDestHolder destID =
         "Found Dest without holder"
         "Found Dest with both project and team holder"
 
+getDestAdd
+    :: MonadIO m
+    => DestId
+    -> ReaderT SqlBackend m
+        (Either
+            (LocalActorBy Key, OutboxItemId)
+            FedURI
+        )
+getDestAdd destID = do
+    usOrThem <-
+        requireEitherAlt
+            (getKeyBy $ UniqueDestOriginUs destID)
+            (getKeyBy $ UniqueDestOriginThem destID)
+            "Neither us nor them"
+            "Both us and them"
+    add <-
+        case usOrThem of
+            Left _usID ->
+                requireEitherAlt
+                    (fmap destUsGestureLocalActivity <$> getValBy (UniqueDestUsGestureLocal destID))
+                    (fmap destUsGestureRemoteActivity <$> getValBy (UniqueDestUsGestureRemote destID))
+                    "Neither local not remote"
+                    "Both local and remote"
+            Right themID ->
+                requireEitherAlt
+                    (fmap destThemGestureLocalAdd <$> getValBy (UniqueDestThemGestureLocal themID))
+                    (fmap destThemGestureRemoteAdd <$> getValBy (UniqueDestThemGestureRemote themID))
+                    "Neither local not remote"
+                    "Both local and remote"
+    bitraverse
+        (\ addID -> do
+            OutboxItem outboxID _ time <- getJust addID
+            Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
+            (,addID) <$> getLocalActor actorID
+        )
+        (\ addID -> do
+            add <- getJust addID
+            getRemoteActivityURI add
+        )
+        add
+
 checkExistingStems
     :: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()
 checkExistingStems componentByID projectDB = do

templates/project/parents.hamlet

@@ -48,7 +48,9 @@ $if haveAdmin
     <th>I accepted?
     <th>Role
     <th>Time
-  $forall (inviter, us, parent, accept, time, role) <- invites
+    $if haveAdmin
+      <th>Approve
+  $forall (inviter, us, parent, accept, time, role, destID) <- invites
     <tr>
       <td>^{actorLinkFedW inviter}
       <td>
@@ -64,3 +66,5 @@ $if haveAdmin
           [_]
       <td>#{show role}
       <td>#{showDate time}
+      $if haveAdmin && (not accept && not us)
+        <td>^{buttonW POST "Approve" (ProjectApproveParentR projectHash destID)}

th/routes

@@ -361,3 +361,4 @@
 /projects/#ProjectKeyHashid/parent/add ProjectAddParentR POST
 
 /projects/#ProjectKeyHashid/child/approve/#SourceId ProjectApproveChildR POST
+/projects/#ProjectKeyHashid/parent/approve/#DestId ProjectApproveParentR POST