From fe7ae763db6e9c2f3a9a2e41de26606dfe72f08e Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 10 Jun 2024 17:07:32 +0300 Subject: [PATCH] UI: Repo, Loom: Project add-approve-remove buttons --- src/Vervis/Foundation.hs | 6 ++ src/Vervis/Handler/Loom.hs | 136 ++++++++++++++++++++++++++++++++ src/Vervis/Handler/Repo.hs | 138 +++++++++++++++++++++++++++++++++ templates/repo/projects.hamlet | 18 ++--- th/routes | 10 +++ 5 files changed, 299 insertions(+), 9 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index e59cb1d..9c80014 100644 --- a/src/Vervis/Foundation.hs +++ b/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) diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index ad0f3d2..cd70a5a 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 48bcec7..763e3fb 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/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 diff --git a/templates/repo/projects.hamlet b/templates/repo/projects.hamlet index b4e85e7..64358ae 100644 --- a/templates/repo/projects.hamlet +++ b/templates/repo/projects.hamlet @@ -59,14 +59,14 @@ $# . #{show role} ^{projectLinkFedW project} #{showDate since} -$# $if haveAdmin -$# ^{buttonW POST "Remove" (RepoRemoveProjectR repoHash stemID)} + $if haveAdmin + ^{buttonW POST "Remove" (RepoRemoveProjectR repoHash stemID)} -$#$if haveAdmin -$#

Add repo to a project: -$#

-$# ^{widgetAP} -$# +$if haveAdmin +

Add repo to a project: + + ^{widgetAP} +

Invites @@ -96,5 +96,5 @@ $# [_] #{show role} #{showDate time} -$# $if haveAdmin && (not accept && not us) -$# ^{buttonW POST "Approve" (RepoApproveProjectR repoHash stemID)} + $if haveAdmin && (not accept && not us) + ^{buttonW POST "Approve" (RepoApproveProjectR repoHash stemID)} diff --git a/th/routes b/th/routes index 1be4d61..ed2ee00 100644 --- a/th/routes +++ b/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