UI: Repo, Loom: Project add-approve-remove buttons

src/Vervis/Foundation.hs

@@ -945,6 +945,9 @@ instance YesodBreadcrumbs App where
         RepoInviteR _ -> ("", Nothing)
         RepoRemoveR _ _ -> ("", Nothing)
         RepoProjectsR r -> ("Projects", Just $ RepoR r)
+        RepoApproveProjectR d c -> ("", Nothing)
+        RepoRemoveProjectR d c -> ("", Nothing)
+        RepoAddProjectR d -> ("", Nothing)
 
         RepoTeamsR r -> ("Teams", Just $ RepoR r)
 
@@ -1021,6 +1024,9 @@ instance YesodBreadcrumbs App where
         LoomInviteR _ -> ("", Nothing)
         LoomRemoveR _ _ -> ("", Nothing)
         LoomProjectsR l -> ("Projects", Just $ LoomR l)
+        LoomApproveProjectR d c -> ("", Nothing)
+        LoomRemoveProjectR d c -> ("", Nothing)
+        LoomAddProjectR d -> ("", Nothing)
 
         LoomTeamsR l -> ("Teams", Just $ LoomR l)
 

src/Vervis/Handler/Loom.hs

@@ -34,6 +34,9 @@ module Vervis.Handler.Loom
     , postLoomInviteR
     , postLoomRemoveR
     , getLoomProjectsR
+    , postLoomAddProjectR
+    , postLoomApproveProjectR
+    , postLoomRemoveProjectR
 
     , getLoomTeamsR
 
@@ -424,6 +427,139 @@ getLoomProjectsR loomHash = do
 addProjectForm = renderDivs $
     areq fedUriField "(URI) Project" Nothing
 
+postLoomAddProjectR :: KeyHashid Loom -> Handler ()
+postLoomAddProjectR loomHash = do
+    loomID <- decodeKeyHashid404 loomHash
+    uProject <-
+        runFormPostRedirect (LoomProjectsR loomHash) addProjectForm
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    let uCollection = encodeRouteHome $ LoomProjectsR loomHash
+
+    result <- runExceptT $ do
+        (maybeSummary, audience, add) <- C.add personID uProject uCollection AP.RoleAdmin
+        cap <- do
+            maybeItem <- lift $ runDB $ do
+                resourceID <- loomResource <$> get404 loomID
+                getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Loom to add projects"
+        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 -> setMessage $ toHtml e
+        Right inviteID -> setMessage "Add sent"
+    redirect $ LoomProjectsR loomHash
+
+postLoomApproveProjectR :: KeyHashid Loom -> StemId -> Handler Html
+postLoomApproveProjectR loomHash stemID = do
+    loomID <- decodeKeyHashid404 loomHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            loom <- MaybeT $ get loomID
+            Stem _ kompID <- MaybeT $ get stemID
+            guard $ kompID == loomKomponent loom
+
+            uAdd <- lift $ do
+                add <- getStemAdd stemID
+                renderActivityURI add
+
+            topic <- lift $ getStemProject stemID
+            lift $
+                (loomResource loom,uAdd,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, accept) <- do
+            uProject <-
+                case pidOrU of
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+                    Right u -> pure u
+            let uLoom = encodeRouteHome $ LoomR loomHash
+            C.acceptParentChild personID uAdd uProject uLoom
+        cap <- do
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Loom to approve projects"
+        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 $ LoomProjectsR loomHash
+
+postLoomRemoveProjectR :: KeyHashid Loom -> StemId -> Handler Html
+postLoomRemoveProjectR loomHash stemID = do
+    loomID <- decodeKeyHashid404 loomHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            loom <- MaybeT $ get loomID
+            Stem _ kompID <- MaybeT $ get stemID
+            guard $ kompID == loomKomponent loom
+            acceptID <- MaybeT $ getKeyBy $ UniqueStemComponentAccept stemID
+            _ <- MaybeT $ getBy $ UniqueStemDelegateLocal acceptID
+
+            uAdd <- lift $ do
+                add <- getStemAdd stemID
+                renderActivityURI add
+
+            topic <- lift $ getStemProject stemID
+            lift $
+                (loomResource loom,uAdd,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, remove) <- do
+            uProject <-
+                case pidOrU of
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+                    Right u -> pure u
+            let uCollection = encodeRouteHome $ LoomProjectsR loomHash
+            C.remove personID uProject uCollection
+        cap <- do
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Loom to remove projects"
+        uCap <- lift $ renderActivityURI cap
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
+        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 "Remove sent"
+    redirect $ LoomProjectsR loomHash
+
 getLoomTeamsR :: KeyHashid Loom -> Handler TypedContent
 getLoomTeamsR loomHash = do
     loomID <- decodeKeyHashid404 loomHash

src/Vervis/Handler/Repo.hs

@@ -51,6 +51,9 @@ module Vervis.Handler.Repo
     , postRepoInviteR
     , postRepoRemoveR
     , getRepoProjectsR
+    , postRepoAddProjectR
+    , postRepoApproveProjectR
+    , postRepoRemoveProjectR
 
     , getRepoTeamsR
 
@@ -118,6 +121,7 @@ import Formatting (sformat, stext, (%))
 import Network.Git.Transport.HTTP.Fetch.RefDiscovery
 import Network.Git.Transport.HTTP.Fetch.UploadRequest
 import Network.Git.Types
+import Network.HTTP.Types.Method
 import Network.Wai (strictRequestBody)
 import System.Directory
 import System.FilePath
@@ -201,6 +205,7 @@ import Vervis.Web.Collab
 import Vervis.Web.Darcs
 import Vervis.Web.Delivery
 import Vervis.Web.Git
+import Vervis.Widget
 import Vervis.Widget.Repo
 import Vervis.Widget.Tracker
 
@@ -848,6 +853,139 @@ getRepoProjectsR repoHash = do
     hashLoom <- getEncodeKeyHashid
     defaultLayout $(widgetFile "repo/projects")
 
+postRepoAddProjectR :: KeyHashid Repo -> Handler ()
+postRepoAddProjectR repoHash = do
+    repoID <- decodeKeyHashid404 repoHash
+    uProject <-
+        runFormPostRedirect (RepoProjectsR repoHash) addProjectForm
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    let uCollection = encodeRouteHome $ RepoProjectsR repoHash
+
+    result <- runExceptT $ do
+        (maybeSummary, audience, add) <- C.add personID uProject uCollection AP.RoleAdmin
+        cap <- do
+            maybeItem <- lift $ runDB $ do
+                resourceID <- repoResource <$> get404 repoID
+                getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Repo to add projects"
+        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 -> setMessage $ toHtml e
+        Right inviteID -> setMessage "Add sent"
+    redirect $ RepoProjectsR repoHash
+
+postRepoApproveProjectR :: KeyHashid Repo -> StemId -> Handler Html
+postRepoApproveProjectR repoHash stemID = do
+    repoID <- decodeKeyHashid404 repoHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            repo <- MaybeT $ get repoID
+            Stem _ kompID <- MaybeT $ get stemID
+            guard $ kompID == repoKomponent repo
+
+            uAdd <- lift $ do
+                add <- getStemAdd stemID
+                renderActivityURI add
+
+            topic <- lift $ getStemProject stemID
+            lift $
+                (repoResource repo,uAdd,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, accept) <- do
+            uProject <-
+                case pidOrU of
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+                    Right u -> pure u
+            let uRepo = encodeRouteHome $ RepoR repoHash
+            C.acceptParentChild personID uAdd uProject uRepo
+        cap <- do
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Repo to approve projects"
+        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 $ RepoProjectsR repoHash
+
+postRepoRemoveProjectR :: KeyHashid Repo -> StemId -> Handler Html
+postRepoRemoveProjectR repoHash stemID = do
+    repoID <- decodeKeyHashid404 repoHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            repo <- MaybeT $ get repoID
+            Stem _ kompID <- MaybeT $ get stemID
+            guard $ kompID == repoKomponent repo
+            acceptID <- MaybeT $ getKeyBy $ UniqueStemComponentAccept stemID
+            _ <- MaybeT $ getBy $ UniqueStemDelegateLocal acceptID
+
+            uAdd <- lift $ do
+                add <- getStemAdd stemID
+                renderActivityURI add
+
+            topic <- lift $ getStemProject stemID
+            lift $
+                (repoResource repo,uAdd,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, remove) <- do
+            uProject <-
+                case pidOrU of
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+                    Right u -> pure u
+            let uCollection = encodeRouteHome $ RepoProjectsR repoHash
+            C.remove personID uProject uCollection
+        cap <- do
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Repo to remove projects"
+        uCap <- lift $ renderActivityURI cap
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
+        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 "Remove sent"
+    redirect $ RepoProjectsR repoHash
+
 getRepoTeamsR :: KeyHashid Repo -> Handler TypedContent
 getRepoTeamsR repoHash = do
     repoID <- decodeKeyHashid404 repoHash

templates/repo/projects.hamlet

@@ -59,14 +59,14 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <td>#{show role}
       <td>^{projectLinkFedW project}
       <td>#{showDate since}
-$#      $if haveAdmin
+      $if haveAdmin
-$#        <td>^{buttonW POST "Remove" (RepoRemoveProjectR repoHash stemID)}
+        <td>^{buttonW POST "Remove" (RepoRemoveProjectR repoHash stemID)}
 
-$#$if haveAdmin
+$if haveAdmin
-$#  <p>Add repo to a project:
+  <p>Add repo to a project:
-$#  <form method=POST action=@{RepoAddProjectR repoHash} enctype=#{enctypeAP}>
+  <form method=POST action=@{RepoAddProjectR repoHash} enctype=#{enctypeAP}>
-$#    ^{widgetAP}
+    ^{widgetAP}
-$#    <input type="submit">
+    <input type="submit">
 
 <h2>Invites
 
@@ -96,5 +96,5 @@ $#    <input type="submit">
           [_]
       <td>#{show role}
       <td>#{showDate time}
-$#      $if haveAdmin && (not accept && not us)
+      $if haveAdmin && (not accept && not us)
-$#        <td>^{buttonW POST "Approve" (RepoApproveProjectR repoHash stemID)}
+        <td>^{buttonW POST "Approve" (RepoApproveProjectR repoHash stemID)}

th/routes

@@ -240,6 +240,11 @@
 /repos/#RepoKeyHashid/remove/#CollabId            RepoRemoveR     POST
 /repos/#RepoKeyHashid/projects                    RepoProjectsR      GET
 
+/repos/#RepoKeyHashid/add-project                 RepoAddProjectR POST
+
+/repos/#RepoKeyHashid/project/approve/#StemId RepoApproveProjectR POST
+/repos/#RepoKeyHashid/project/remove/#StemId  RepoRemoveProjectR  POST
+
 /repos/#RepoKeyHashid/teams                       RepoTeamsR         GET
 
 /repos/#RepoKeyHashid/add-team              RepoAddTeamR     POST
@@ -337,6 +342,11 @@
 /looms/#LoomKeyHashid/remove/#CollabId            LoomRemoveR     POST
 /looms/#LoomKeyHashid/projects                    LoomProjectsR   GET
 
+/looms/#LoomKeyHashid/add-project                 LoomAddProjectR POST
+
+/looms/#LoomKeyHashid/project/approve/#StemId LoomApproveProjectR POST
+/looms/#LoomKeyHashid/project/remove/#StemId  LoomRemoveProjectR  POST
+
 /looms/#LoomKeyHashid/teams                       LoomTeamsR      GET
 
 /looms/#LoomKeyHashid/add-team              LoomAddTeamR     POST