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 @@ $# .
$if haveAdmin
| ^{buttonW POST "Remove" (ProjectRemoveParentR projectHash destID)}
+$if haveAdmin
+ Add a parent:
+ |