UI: Component: POST handlers for team add/approve/remove buttons
This commit is contained in:
Pere Lev
parent
6de8ce6b25
commit
7ade4984d7
6 changed files with 500 additions and 0 deletions
|
|
@ -942,6 +942,10 @@ instance YesodBreadcrumbs App where
|
|||
|
||||
RepoTeamsR r -> ("Teams", Just $ RepoR r)
|
||||
|
||||
RepoAddTeamR r -> ("", Nothing)
|
||||
RepoApproveTeamR r t -> ("", Nothing)
|
||||
RepoRemoveTeamR r t -> ("", Nothing)
|
||||
|
||||
DeckR d -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
|
||||
DeckInboxR d -> ("Inbox", Just $ DeckR d)
|
||||
DeckOutboxR d -> ("Outbox", Just $ DeckR d)
|
||||
|
|
@ -973,6 +977,10 @@ instance YesodBreadcrumbs App where
|
|||
|
||||
DeckTeamsR d -> ("Teams", Just $ DeckR d)
|
||||
|
||||
DeckAddTeamR d -> ("", Nothing)
|
||||
DeckApproveTeamR d t -> ("", Nothing)
|
||||
DeckRemoveTeamR d t -> ("", Nothing)
|
||||
|
||||
TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
|
||||
TicketDiscussionR d t -> ("Discussion", Just $ TicketR d t)
|
||||
TicketEventsR d t -> ("Events", Just $ TicketR d t)
|
||||
|
|
@ -1010,6 +1018,10 @@ instance YesodBreadcrumbs App where
|
|||
|
||||
LoomTeamsR l -> ("Teams", Just $ LoomR l)
|
||||
|
||||
LoomAddTeamR l -> ("", Nothing)
|
||||
LoomApproveTeamR l t -> ("", Nothing)
|
||||
LoomRemoveTeamR l t -> ("", Nothing)
|
||||
|
||||
ClothR l c -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
|
||||
ClothDiscussionR l c -> ("Discussion", Just $ ClothR l c)
|
||||
ClothEventsR l c -> ("Events", Just $ ClothR l c)
|
||||
|
|
|
|||
|
|
@ -49,6 +49,9 @@ module Vervis.Handler.Deck
|
|||
|
||||
, getDeckTeamsR
|
||||
|
||||
, postDeckAddTeamR
|
||||
, postDeckApproveTeamR
|
||||
, postDeckRemoveTeamR
|
||||
|
||||
|
||||
|
||||
|
|
@ -747,6 +750,142 @@ getDeckTeamsR deckHash = do
|
|||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (DeckR deckHash) (DeckTeamsR deckHash) resourceID
|
||||
|
||||
addTeamForm = renderDivs $
|
||||
areq fedUriField "(URI) Team" Nothing
|
||||
|
||||
postDeckAddTeamR :: KeyHashid Deck -> Handler ()
|
||||
postDeckAddTeamR deckHash = do
|
||||
deckID <- decodeKeyHashid404 deckHash
|
||||
uTeam <-
|
||||
runFormPostRedirect (DeckCollabsR deckHash) addTeamForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let uCollection = encodeRouteHome $ DeckTeamsR deckHash
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam uCollection AP.RoleAdmin
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ do
|
||||
resourceID <- deckResource <$> get404 deckID
|
||||
getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Deck to add teams"
|
||||
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 $ DeckCollabsR deckHash
|
||||
|
||||
postDeckApproveTeamR :: KeyHashid Deck -> SquadId -> Handler Html
|
||||
postDeckApproveTeamR deckHash squadID = do
|
||||
deckID <- decodeKeyHashid404 deckHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
deck <- MaybeT $ get deckID
|
||||
Squad _ resourceID <- MaybeT $ get squadID
|
||||
guard $ resourceID == deckResource deck
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSquadAdd squadID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ bimap snd snd <$> getSquadTeam squadID
|
||||
lift $
|
||||
(deckResource deck,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, accept) <- do
|
||||
uTeam <-
|
||||
case pidOrU of
|
||||
Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g
|
||||
Right u -> pure u
|
||||
let uDeck = encodeRouteHome $ DeckR deckHash
|
||||
C.acceptParentChild personID uAdd uTeam uDeck
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Deck to approve teams"
|
||||
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 $ DeckCollabsR deckHash
|
||||
|
||||
postDeckRemoveTeamR :: KeyHashid Deck -> SquadId -> Handler Html
|
||||
postDeckRemoveTeamR deckHash squadID = do
|
||||
deckID <- decodeKeyHashid404 deckHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
deck <- MaybeT $ get deckID
|
||||
Squad _ resourceID <- MaybeT $ get squadID
|
||||
guard $ resourceID == deckResource deck
|
||||
acceptID <- MaybeT $ getKeyBy $ UniqueSquadUsAccept squadID
|
||||
_ <- MaybeT $ getBy $ UniqueSquadUsStart acceptID
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSquadAdd squadID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ bimap snd snd <$> getSquadTeam squadID
|
||||
lift $
|
||||
(deckResource deck,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uTeam <-
|
||||
case pidOrU of
|
||||
Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g
|
||||
Right u -> pure u
|
||||
let uCollection = encodeRouteHome $ DeckTeamsR deckHash
|
||||
C.remove personID uTeam uCollection
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Deck to remove teams"
|
||||
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 $ DeckCollabsR deckHash
|
||||
|
||||
{-
|
||||
getProjectsR :: ShrIdent -> Handler Html
|
||||
getProjectsR ident = do
|
||||
|
|
|
|||
|
|
@ -36,6 +36,10 @@ module Vervis.Handler.Loom
|
|||
, getLoomProjectsR
|
||||
|
||||
, getLoomTeamsR
|
||||
|
||||
, postLoomAddTeamR
|
||||
, postLoomApproveTeamR
|
||||
, postLoomRemoveTeamR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -43,6 +47,8 @@ import Control.Monad
|
|||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Default.Class
|
||||
import Data.Foldable
|
||||
|
|
@ -82,6 +88,7 @@ import Yesod.Persist.Local
|
|||
|
||||
import Vervis.Access
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Discussion
|
||||
import Vervis.Federation.Offer
|
||||
|
|
@ -397,3 +404,139 @@ getLoomTeamsR loomHash = do
|
|||
komponentID <- loomKomponent <$> get404 loomID
|
||||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (LoomR loomHash) (LoomTeamsR loomHash) resourceID
|
||||
|
||||
addTeamForm = renderDivs $
|
||||
areq fedUriField "(URI) Team" Nothing
|
||||
|
||||
postLoomAddTeamR :: KeyHashid Loom -> Handler ()
|
||||
postLoomAddTeamR loomHash = do
|
||||
loomID <- decodeKeyHashid404 loomHash
|
||||
uTeam <-
|
||||
runFormPostRedirect (LoomCollabsR loomHash) addTeamForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let uCollection = encodeRouteHome $ LoomTeamsR loomHash
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam 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 teams"
|
||||
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 $ LoomCollabsR loomHash
|
||||
|
||||
postLoomApproveTeamR :: KeyHashid Loom -> SquadId -> Handler Html
|
||||
postLoomApproveTeamR loomHash squadID = 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
|
||||
Squad _ resourceID <- MaybeT $ get squadID
|
||||
guard $ resourceID == loomResource loom
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSquadAdd squadID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ bimap snd snd <$> getSquadTeam squadID
|
||||
lift $
|
||||
(loomResource loom,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, accept) <- do
|
||||
uTeam <-
|
||||
case pidOrU of
|
||||
Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g
|
||||
Right u -> pure u
|
||||
let uLoom = encodeRouteHome $ LoomR loomHash
|
||||
C.acceptParentChild personID uAdd uTeam 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 teams"
|
||||
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 $ LoomCollabsR loomHash
|
||||
|
||||
postLoomRemoveTeamR :: KeyHashid Loom -> SquadId -> Handler Html
|
||||
postLoomRemoveTeamR loomHash squadID = 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
|
||||
Squad _ resourceID <- MaybeT $ get squadID
|
||||
guard $ resourceID == loomResource loom
|
||||
acceptID <- MaybeT $ getKeyBy $ UniqueSquadUsAccept squadID
|
||||
_ <- MaybeT $ getBy $ UniqueSquadUsStart acceptID
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSquadAdd squadID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ bimap snd snd <$> getSquadTeam squadID
|
||||
lift $
|
||||
(loomResource loom,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uTeam <-
|
||||
case pidOrU of
|
||||
Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g
|
||||
Right u -> pure u
|
||||
let uCollection = encodeRouteHome $ LoomTeamsR loomHash
|
||||
C.remove personID uTeam 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 teams"
|
||||
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 $ LoomCollabsR loomHash
|
||||
|
|
|
|||
|
|
@ -54,6 +54,9 @@ module Vervis.Handler.Repo
|
|||
|
||||
, getRepoTeamsR
|
||||
|
||||
, postRepoAddTeamR
|
||||
, postRepoApproveTeamR
|
||||
, postRepoRemoveTeamR
|
||||
|
||||
|
||||
|
||||
|
|
@ -84,6 +87,7 @@ import Control.Monad.Trans.Except
|
|||
import Control.Monad.Trans.Maybe
|
||||
import Data.Bifunctor
|
||||
import Data.Binary.Put
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.Git.Graph
|
||||
|
|
@ -154,6 +158,7 @@ import Yesod.RenderSource
|
|||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.ByteString.Char8.Local (takeLine)
|
||||
import Data.Either.Local
|
||||
import Data.Git.Local
|
||||
|
|
@ -169,6 +174,7 @@ import qualified Darcs.Local.Repository as D (createRepo)
|
|||
import Vervis.Access
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Offer
|
||||
import Vervis.FedURI
|
||||
|
|
@ -821,6 +827,141 @@ getRepoTeamsR repoHash = do
|
|||
komponentResource <$> getJust komponentID
|
||||
serveTeamsCollection (RepoR repoHash) (RepoTeamsR repoHash) resourceID
|
||||
|
||||
addTeamForm = renderDivs $
|
||||
areq fedUriField "(URI) Team" Nothing
|
||||
|
||||
postRepoAddTeamR :: KeyHashid Repo -> Handler ()
|
||||
postRepoAddTeamR repoHash = do
|
||||
repoID <- decodeKeyHashid404 repoHash
|
||||
uTeam <-
|
||||
runFormPostRedirect (RepoCollabsR repoHash) addTeamForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let uCollection = encodeRouteHome $ RepoTeamsR repoHash
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, add) <- C.add personID uTeam 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 teams"
|
||||
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 $ RepoCollabsR repoHash
|
||||
|
||||
postRepoApproveTeamR :: KeyHashid Repo -> SquadId -> Handler Html
|
||||
postRepoApproveTeamR repoHash squadID = 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
|
||||
Squad _ resourceID <- MaybeT $ get squadID
|
||||
guard $ resourceID == repoResource repo
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSquadAdd squadID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ bimap snd snd <$> getSquadTeam squadID
|
||||
lift $
|
||||
(repoResource repo,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, accept) <- do
|
||||
uTeam <-
|
||||
case pidOrU of
|
||||
Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g
|
||||
Right u -> pure u
|
||||
let uRepo = encodeRouteHome $ RepoR repoHash
|
||||
C.acceptParentChild personID uAdd uTeam 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 teams"
|
||||
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 $ RepoCollabsR repoHash
|
||||
|
||||
postRepoRemoveTeamR :: KeyHashid Repo -> SquadId -> Handler Html
|
||||
postRepoRemoveTeamR repoHash squadID = 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
|
||||
Squad _ resourceID <- MaybeT $ get squadID
|
||||
guard $ resourceID == repoResource repo
|
||||
acceptID <- MaybeT $ getKeyBy $ UniqueSquadUsAccept squadID
|
||||
_ <- MaybeT $ getBy $ UniqueSquadUsStart acceptID
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSquadAdd squadID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ bimap snd snd <$> getSquadTeam squadID
|
||||
lift $
|
||||
(repoResource repo,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uTeam <-
|
||||
case pidOrU of
|
||||
Left g -> encodeRouteHome . GroupR <$> encodeKeyHashid g
|
||||
Right u -> pure u
|
||||
let uCollection = encodeRouteHome $ RepoTeamsR repoHash
|
||||
C.remove personID uTeam 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 teams"
|
||||
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 $ RepoCollabsR repoHash
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -62,6 +62,9 @@ module Vervis.Persist.Collab
|
|||
, getStemDrafts
|
||||
|
||||
, getResourceTeams
|
||||
|
||||
, getSquadAdd
|
||||
, getSquadTeam
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1412,3 +1415,53 @@ getResourceTeams resourceID =
|
|||
, ra
|
||||
, squad E.^. SquadId
|
||||
)
|
||||
|
||||
getSquadAdd
|
||||
:: MonadIO m
|
||||
=> SquadId
|
||||
-> ReaderT SqlBackend m
|
||||
(Either
|
||||
(LocalActorBy Key, OutboxItemId)
|
||||
FedURI
|
||||
)
|
||||
getSquadAdd squadID = do
|
||||
usOrThem <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniqueSquadOriginUs squadID)
|
||||
(getKeyBy $ UniqueSquadOriginThem squadID)
|
||||
"Neither us nor them"
|
||||
"Both us and them"
|
||||
add <-
|
||||
case usOrThem of
|
||||
Left _usID ->
|
||||
requireEitherAlt
|
||||
(fmap squadUsGestureLocalActivity <$> getValBy (UniqueSquadUsGestureLocal squadID))
|
||||
(fmap squadUsGestureRemoteActivity <$> getValBy (UniqueSquadUsGestureRemote squadID))
|
||||
"Neither local not remote"
|
||||
"Both local and remote"
|
||||
Right themID ->
|
||||
requireEitherAlt
|
||||
(fmap squadThemGestureLocalAdd <$> getValBy (UniqueSquadThemGestureLocal themID))
|
||||
(fmap squadThemGestureRemoteAdd <$> getValBy (UniqueSquadThemGestureRemote themID))
|
||||
"Neither local not remote"
|
||||
"Both local and remote"
|
||||
getActivityIdent add
|
||||
|
||||
getSquadTeam
|
||||
:: MonadIO m
|
||||
=> SquadId
|
||||
-> ReaderT SqlBackend m
|
||||
(Either
|
||||
(SquadTopicLocalId, GroupId)
|
||||
(SquadTopicRemoteId, RemoteActorId)
|
||||
)
|
||||
getSquadTeam squadID =
|
||||
bimap
|
||||
(\ (Entity k v) -> (k, squadTopicLocalGroup v))
|
||||
(\ (Entity k v) -> (k, squadTopicRemoteTopic v))
|
||||
<$>
|
||||
requireEitherAlt
|
||||
(getBy $ UniqueSquadTopicLocal squadID)
|
||||
(getBy $ UniqueSquadTopicRemote squadID)
|
||||
"Found Squad without topic"
|
||||
"Found Squad with both local and remote topic"
|
||||
|
|
|
|||
12
th/routes
12
th/routes
|
|
@ -236,6 +236,10 @@
|
|||
|
||||
/repos/#RepoKeyHashid/teams RepoTeamsR GET
|
||||
|
||||
/repos/#RepoKeyHashid/add-team RepoAddTeamR POST
|
||||
/repos/#RepoKeyHashid/approve-team/#SquadId RepoApproveTeamR POST
|
||||
/repos/#RepoKeyHashid/remove-team/#SquadId RepoRemoveTeamR POST
|
||||
|
||||
---- Deck --------------------------------------------------------------------
|
||||
|
||||
/decks/#DeckKeyHashid DeckR GET
|
||||
|
|
@ -270,6 +274,10 @@
|
|||
|
||||
/decks/#DeckKeyHashid/teams DeckTeamsR GET
|
||||
|
||||
/decks/#DeckKeyHashid/add-team DeckAddTeamR POST
|
||||
/decks/#DeckKeyHashid/approve-team/#SquadId DeckApproveTeamR POST
|
||||
/decks/#DeckKeyHashid/remove-team/#SquadId DeckRemoveTeamR POST
|
||||
|
||||
---- Ticket ------------------------------------------------------------------
|
||||
|
||||
/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid TicketR GET
|
||||
|
|
@ -325,6 +333,10 @@
|
|||
|
||||
/looms/#LoomKeyHashid/teams LoomTeamsR GET
|
||||
|
||||
/looms/#LoomKeyHashid/add-team LoomAddTeamR POST
|
||||
/looms/#LoomKeyHashid/approve-team/#SquadId LoomApproveTeamR POST
|
||||
/looms/#LoomKeyHashid/remove-team/#SquadId LoomRemoveTeamR POST
|
||||
|
||||
---- Cloth -------------------------------------------------------------------
|
||||
|
||||
/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid ClothR GET
|
||||
|
|
|
|||
Loading…
Reference in a new issue