From 99f6d950a203e00a073e039b764c011fdaa6eec0 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Sat, 27 Apr 2024 21:46:49 +0300
Subject: [PATCH] UI: Project: Parents: Form for adding a parent by URI

---
 src/Vervis/Foundation.hs         |  1 +
 src/Vervis/Handler/Project.hs    | 37 ++++++++++++++++++++++++++++++++
 templates/project/parents.hamlet |  6 ++++++
 th/routes                        |  1 +
 4 files changed, 45 insertions(+)

diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 406cafd..0760015 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -1042,5 +1042,6 @@ instance YesodBreadcrumbs App where
         ProjectRemoveParentR _ _ -> ("", Nothing)
 
         ProjectAddChildR _ -> ("", Nothing)
+        ProjectAddParentR _ -> ("", Nothing)
 
         ProjectApproveChildR _ _ -> ("", Nothing)
diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs
index d45f33b..0a574cb 100644
--- a/src/Vervis/Handler/Project.hs
+++ b/src/Vervis/Handler/Project.hs
@@ -48,6 +48,7 @@ module Vervis.Handler.Project
     , postProjectRemoveParentR
 
     , postProjectAddChildR
+    , postProjectAddParentR
 
     , postProjectApproveChildR
     )
@@ -854,6 +855,7 @@ getProjectParentsR projectHash = do
         haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do
             personID <- MaybeT $ pure mp
             MaybeT $ getCapability personID (Left $ projectResource project) AP.RoleAdmin
+        ((_, widgetAP), enctypeAP) <- runFormPost addParentForm
         invites <- handlerToWidget $ runDB $ do
             dests <- E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.LeftOuterJoin` accept `E.LeftOuterJoin` delegl `E.LeftOuterJoin` delegr) -> do
                 E.on $ accept E.?. DestUsAcceptId E.==. delegr E.?. DestThemSendDelegatorRemoteDest
@@ -1082,6 +1084,41 @@ postProjectAddChildR projectHash = do
             setMessage "Add sent"
     redirect $ ProjectChildrenR projectHash
 
+addParentForm = renderDivs $
+    areq fedUriField "(URI) Parent project" Nothing
+
+postProjectAddParentR :: KeyHashid Project -> Handler Html
+postProjectAddParentR projectHash = do
+    uParent <- runFormPostRedirect (ProjectChildrenR projectHash) addParentForm
+    encodeRouteHome <- getEncodeRouteHome
+    let uCollection = encodeRouteHome $ ProjectParentsR projectHash
+
+    projectID <- decodeKeyHashid404 projectHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+
+    result <- runExceptT $ do
+        project <- lift $ runDB $ get404 projectID
+        (maybeSummary, audience, add) <- C.add personID uParent uCollection AP.RoleAdmin
+        cap <- do
+            let resourceID = projectResource project
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Project to add parents"
+        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 $ ProjectChildrenR projectHash
+
 postProjectApproveChildR :: KeyHashid Project -> SourceId -> Handler Html
 postProjectApproveChildR projectHash sourceID = do
     projectID <- decodeKeyHashid404 projectHash
diff --git a/templates/project/parents.hamlet b/templates/project/parents.hamlet
index 0cd049a..c3c749d 100644
--- a/templates/project/parents.hamlet
+++ b/templates/project/parents.hamlet
@@ -32,6 +32,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       $if haveAdmin
         <td>^{buttonW POST "Remove" (ProjectRemoveParentR projectHash destID)}
 
+$if haveAdmin
+  <p>Add a parent:
+  <form method=POST action=@{ProjectAddParentR projectHash} enctype=#{enctypeAP}>
+    ^{widgetAP}
+    <input type=submit>
+
 <h2>Invites
 
 <table>
diff --git a/th/routes b/th/routes
index ed455be..2a51f0e 100644
--- a/th/routes
+++ b/th/routes
@@ -358,5 +358,6 @@
 /projects/#ProjectKeyHashid/parent/remove/#DestId ProjectRemoveParentR POST
 
 /projects/#ProjectKeyHashid/child/add ProjectAddChildR POST
+/projects/#ProjectKeyHashid/parent/add ProjectAddParentR POST
 
 /projects/#ProjectKeyHashid/child/approve/#SourceId ProjectApproveChildR POST