UI: Project: Parents: Form for adding a parent by URI

src/Vervis/Foundation.hs

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

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

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>

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