mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 19:24:52 +09:00
UI: Deck: 'Approve' button for accepting invites-to-projects
This commit is contained in:
Pere Lev
parent
47f993d63f
commit
df6ece2889
6 changed files with 151 additions and 5 deletions
|
|
@ -23,6 +23,9 @@ module Database.Persist.Local
|
|||
, insertByEntity'
|
||||
, getE
|
||||
, getEntityE
|
||||
, getByJust
|
||||
, getKeyByJust
|
||||
, getValByJust
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -119,3 +122,21 @@ getEntityE
|
|||
)
|
||||
=> Key record -> e -> ExceptT e (ReaderT backend m) (Entity record)
|
||||
getEntityE key msg = Entity key <$> getE key msg
|
||||
|
||||
getByJust u = do
|
||||
me <- getBy u
|
||||
case me of
|
||||
Nothing -> error "getByJust"
|
||||
Just e -> pure e
|
||||
|
||||
getKeyByJust u = do
|
||||
me <- getKeyBy u
|
||||
case me of
|
||||
Nothing -> error "getKeyByJust"
|
||||
Just e -> pure e
|
||||
|
||||
getValByJust u = do
|
||||
me <- getValBy u
|
||||
case me of
|
||||
Nothing -> error "getValByJust"
|
||||
Just e -> pure e
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ module Vervis.Client
|
|||
, invite
|
||||
, remove
|
||||
, inviteComponent
|
||||
, acceptProjectInvite
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1271,3 +1272,57 @@ inviteComponent personID projectID uComp = do
|
|||
)
|
||||
pure
|
||||
routeOrRemote
|
||||
|
||||
acceptProjectInvite
|
||||
:: PersonId
|
||||
-> LocalActorBy Key
|
||||
-> Either ProjectId FedURI
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Accept URIMode)
|
||||
acceptProjectInvite personID component project uInvite = do
|
||||
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
theater <- asksSite appTheater
|
||||
env <- asksSite appEnv
|
||||
component' <- Vervis.Recipient.hashLocalActor component
|
||||
project' <- bitraverse encodeKeyHashid pure project
|
||||
|
||||
let activity = AP.Accept uInvite Nothing
|
||||
|
||||
-- If project is remote, get it via HTTP/DB to determine its followers
|
||||
-- collection
|
||||
projectDB <-
|
||||
bitraverse
|
||||
pure
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor instanceID h lu
|
||||
case result of
|
||||
Left Nothing -> throwE "Project @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Project isn't an actor"
|
||||
Right (Just actor) -> return (entityVal actor, u)
|
||||
)
|
||||
project'
|
||||
|
||||
senderHash <- encodeKeyHashid personID
|
||||
|
||||
let audProject =
|
||||
case projectDB of
|
||||
Left j ->
|
||||
AudLocal [LocalActorProject j] [LocalStageProjectFollowers j]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
audComp =
|
||||
AudLocal [component'] [localActorFollowers component']
|
||||
audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
audience = [audComp, audProject, audAuthor]
|
||||
|
||||
return (Nothing, audience, activity)
|
||||
|
|
|
|||
|
|
@ -159,6 +159,7 @@ type TicketLoomKeyHashid = KeyHashid TicketLoom
|
|||
type SigKeyKeyHashid = KeyHashid SigKey
|
||||
type ProjectKeyHashid = KeyHashid Project
|
||||
type CollabEnableKeyHashid = KeyHashid CollabEnable
|
||||
type StemKeyHashid = KeyHashid Stem
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- explanation of the syntax, please see:
|
||||
|
|
@ -939,6 +940,7 @@ instance YesodBreadcrumbs App where
|
|||
DeckRemoveR _ _ -> ("", Nothing)
|
||||
|
||||
DeckProjectsR d -> ("Projects", Just $ DeckR d)
|
||||
DeckApproveCompR d c -> ("", Nothing)
|
||||
|
||||
TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
|
||||
TicketDiscussionR d t -> ("Discussion", Just $ TicketR d t)
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ module Vervis.Handler.Deck
|
|||
, postDeckInviteR
|
||||
, postDeckRemoveR
|
||||
, getDeckProjectsR
|
||||
, postDeckApproveCompR
|
||||
|
||||
|
||||
|
||||
|
|
@ -537,13 +538,15 @@ getDeckProjectsR deckHash = do
|
|||
deck <- get404 deckID
|
||||
actor <- getJust $ deckActor deck
|
||||
stems <-
|
||||
E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.LeftOuterJoin` deleg) -> do
|
||||
E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.LeftOuterJoin` deleg `E.LeftOuterJoin` gestl `E.LeftOuterJoin` gestr) -> do
|
||||
E.on $ E.just (stem E.^. StemId) E.==. gestr E.?. StemComponentGestureRemoteStem
|
||||
E.on $ E.just (stem E.^. StemId) E.==. gestl E.?. StemComponentGestureLocalStem
|
||||
E.on $ E.just (accept E.^. StemComponentAcceptId) E.==. deleg E.?. StemDelegateLocalStem
|
||||
E.on $ stem E.^. StemId E.==. accept E.^. StemComponentAcceptStem
|
||||
E.on $ ident E.^. StemIdentDeckStem E.==. stem E.^. StemId
|
||||
E.where_ $ ident E.^. StemIdentDeckDeck E.==. E.val deckID
|
||||
return (stem, deleg)
|
||||
stems' <- for stems $ \ (Entity stemID stem, deleg) -> do
|
||||
return (stem, deleg, gestl, gestr)
|
||||
stems' <- for stems $ \ (Entity stemID stem, deleg, gestl, gestr) -> do
|
||||
j <- getStemProject stemID
|
||||
projectView <-
|
||||
bitraverse
|
||||
|
|
@ -559,10 +562,70 @@ getDeckProjectsR deckHash = do
|
|||
return (inztance, remoteObject, remoteActor)
|
||||
)
|
||||
j
|
||||
return (projectView, stemRole stem, isJust deleg)
|
||||
stemHash <- encodeKeyHashid stemID
|
||||
return (projectView, stemRole stem, isJust deleg, isJust gestl || isJust gestr, stemHash)
|
||||
return (deck, actor, stems')
|
||||
defaultLayout $(widgetFile "deck/projects")
|
||||
|
||||
postDeckApproveCompR :: KeyHashid Deck -> KeyHashid Stem -> Handler Html
|
||||
postDeckApproveCompR deckHash stemHash = do
|
||||
deckID <- decodeKeyHashid404 deckHash
|
||||
stemID <- decodeKeyHashid404 stemHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
(uInvite, jidOrURI) <- lift $ runDB $ do
|
||||
_ <- get404 deckID
|
||||
_ <- get404 stemID
|
||||
Entity _ (StemIdentDeck _ deckID') <- getBy404 $ UniqueStemIdentDeck stemID
|
||||
unless (deckID' == deckID) notFound
|
||||
uInvite <- do
|
||||
Entity originID _ <- getBy404 $ UniqueStemOriginInvite stemID
|
||||
i <-
|
||||
requireEitherAlt
|
||||
(getValBy $ UniqueStemProjectGestureLocal originID)
|
||||
(getValBy $ UniqueStemProjectGestureRemote originID)
|
||||
"Invite gesture not found"
|
||||
"Multiple invites"
|
||||
case i of
|
||||
Left g -> do
|
||||
let k = stemProjectGestureLocalInvite g
|
||||
oi <- getJust k
|
||||
a <- getKeyByJust $ UniqueActorOutbox $ outboxItemOutbox oi
|
||||
p <- getKeyByJust $ UniquePersonActor a
|
||||
ph <- encodeKeyHashid p
|
||||
kh <- encodeKeyHashid k
|
||||
return $ encodeRouteHome $ PersonOutboxItemR ph kh
|
||||
Right g -> do
|
||||
a <- getJust $ stemProjectGestureRemoteInvite g
|
||||
o <- getJust $ remoteActivityIdent a
|
||||
h <- getJust $ remoteObjectInstance o
|
||||
return $ ObjURI (instanceHost h) (remoteObjectIdent o)
|
||||
project <- getStemProject stemID
|
||||
(uInvite,) <$> bitraverse pure (getRemoteActorURI <=< getJust) project
|
||||
(maybeSummary, audience, accept) <-
|
||||
C.acceptProjectInvite personID (LocalActorDeck deckID) jidOrURI uInvite
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
|
||||
fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people"
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
|
||||
let cap =
|
||||
Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
|
||||
handleViaActor
|
||||
personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID -> do
|
||||
setMessage "Remove sent"
|
||||
redirect $ DeckProjectsR deckHash
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -21,7 +21,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<th>Role
|
||||
<th>Project
|
||||
<th>Enabled
|
||||
$forall (project, role, enabled) <- stems
|
||||
<th>Approve
|
||||
$forall (project, role, enabled, gestured, stemHash) <- stems
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>^{projectLinkFedW project}
|
||||
|
|
@ -30,4 +31,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
[x]
|
||||
$else
|
||||
[_]
|
||||
$if not gestured
|
||||
<td>^{buttonW POST "Approve" (DeckApproveCompR deckHash stemHash)}
|
||||
$# <td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}
|
||||
|
|
|
|||
|
|
@ -225,6 +225,8 @@
|
|||
/decks/#DeckKeyHashid/remove/#CollabTopicDeckId DeckRemoveR POST
|
||||
/decks/#DeckKeyHashid/projects DeckProjectsR GET
|
||||
|
||||
/decks/#DeckKeyHashid/projects/approve/#StemKeyHashid DeckApproveCompR POST
|
||||
|
||||
---- Ticket ------------------------------------------------------------------
|
||||
|
||||
/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid TicketR GET
|
||||
|
|
|
|||
Loading…
Reference in a new issue