UI: Project: Children: Button for approving the Add

src/Vervis/Foundation.hs

@@ -1042,3 +1042,5 @@ instance YesodBreadcrumbs App where
         ProjectRemoveParentR _ _ -> ("", Nothing)
 
         ProjectAddChildR _ -> ("", Nothing)
+
+        ProjectApproveChildR _ _ -> ("", Nothing)

src/Vervis/Handler/Project.hs

@@ -48,6 +48,8 @@ module Vervis.Handler.Project
     , postProjectRemoveParentR
 
     , postProjectAddChildR
+
+    , postProjectApproveChildR
     )
 where
 
@@ -744,7 +746,7 @@ getProjectChildrenR projectHash = do
                         Right (actorID, addID) -> do
                             RemoteActivity _ _ time <- getJust addID
                             (,time) . Right <$> getRemoteActorData actorID
-                return (inviter, us, child, accept, time, role)
+                return (inviter, us, child, accept, time, role, sourceID)
         $(widgetFile "project/children")
         where
         getRemoteActorData actorID = do
@@ -1079,3 +1081,63 @@ postProjectAddChildR projectHash = do
         Right removeID ->
             setMessage "Add sent"
     redirect $ ProjectChildrenR projectHash
+
+postProjectApproveChildR :: KeyHashid Project -> SourceId -> Handler Html
+postProjectApproveChildR 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
+
+            uAdd <- lift $ do
+                add <- getSourceAdd sourceID
+                renderActivityURI add
+
+            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,uAdd,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, accept) <- do
+            uChild <-
+                case pidOrU of
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+                    Right u -> pure u
+            let uParent = 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 children"
+        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 "Add sent"
+    redirect $ ProjectChildrenR projectHash

src/Vervis/Persist/Collab.hs

@@ -33,6 +33,7 @@ module Vervis.Persist.Collab
 
     , getComponentIdent
     , getSourceTopic
+    , getSourceAdd
     , getDestTopic
     , getDestHolder
 
@@ -461,6 +462,47 @@ getSourceTopic sourceID = do
         (\ (Entity k v) -> pure (k, sourceTopicRemoteTopic v))
         ident
 
+getSourceAdd
+    :: MonadIO m
+    => SourceId
+    -> ReaderT SqlBackend m
+        (Either
+            (LocalActorBy Key, OutboxItemId)
+            FedURI
+        )
+getSourceAdd sourceID = do
+    usOrThem <-
+        requireEitherAlt
+            (getKeyBy $ UniqueSourceOriginUs sourceID)
+            (getKeyBy $ UniqueSourceOriginThem sourceID)
+            "Neither us nor them"
+            "Both us and them"
+    add <-
+        case usOrThem of
+            Left usID ->
+                requireEitherAlt
+                    (fmap sourceUsGestureLocalAdd <$> getValBy (UniqueSourceUsGestureLocal usID))
+                    (fmap sourceUsGestureRemoteAdd <$> getValBy (UniqueSourceUsGestureRemote usID))
+                    "Neither local not remote"
+                    "Both local and remote"
+            Right themID ->
+                requireEitherAlt
+                    (fmap sourceThemGestureLocalAdd <$> getValBy (UniqueSourceThemGestureLocal themID))
+                    (fmap sourceThemGestureRemoteAdd <$> getValBy (UniqueSourceThemGestureRemote 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
+
 getDestTopic
     :: MonadIO m
     => DestId

templates/project/children.hamlet

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

th/routes

@@ -358,3 +358,5 @@
 /projects/#ProjectKeyHashid/parent/remove/#DestId ProjectRemoveParentR POST
 
 /projects/#ProjectKeyHashid/child/add ProjectAddChildR POST
+
+/projects/#ProjectKeyHashid/child/approve/#SourceId ProjectApproveChildR POST