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:
-$# |