UI: Repo, Loom: Project add-approve-remove buttons
This commit is contained in:
Pere Lev
parent
1bdd1e9e9b
commit
fe7ae763db
5 changed files with 299 additions and 9 deletions
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -59,14 +59,14 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<td>#{show role}
|
||||
<td>^{projectLinkFedW project}
|
||||
<td>#{showDate since}
|
||||
$# $if haveAdmin
|
||||
$# <td>^{buttonW POST "Remove" (RepoRemoveProjectR repoHash stemID)}
|
||||
$if haveAdmin
|
||||
<td>^{buttonW POST "Remove" (RepoRemoveProjectR repoHash stemID)}
|
||||
|
||||
$#$if haveAdmin
|
||||
$# <p>Add repo to a project:
|
||||
$# <form method=POST action=@{RepoAddProjectR repoHash} enctype=#{enctypeAP}>
|
||||
$# ^{widgetAP}
|
||||
$# <input type="submit">
|
||||
$if haveAdmin
|
||||
<p>Add repo to a project:
|
||||
<form method=POST action=@{RepoAddProjectR repoHash} enctype=#{enctypeAP}>
|
||||
^{widgetAP}
|
||||
<input type="submit">
|
||||
|
||||
<h2>Invites
|
||||
|
||||
|
|
@ -96,5 +96,5 @@ $# <input type="submit">
|
|||
[_]
|
||||
<td>#{show role}
|
||||
<td>#{showDate time}
|
||||
$# $if haveAdmin && (not accept && not us)
|
||||
$# <td>^{buttonW POST "Approve" (RepoApproveProjectR repoHash stemID)}
|
||||
$if haveAdmin && (not accept && not us)
|
||||
<td>^{buttonW POST "Approve" (RepoApproveProjectR repoHash stemID)}
|
||||
|
|
|
|||
10
th/routes
10
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue