diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index 7d264d5..858e7d5 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.hs @@ -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 diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 9f739ad..2464d43 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -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) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 7b0bed9..a36aee1 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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) diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index c141c0a..47326ec 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -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 diff --git a/templates/deck/projects.hamlet b/templates/deck/projects.hamlet index 436f1d9..9e8b1ed 100644 --- a/templates/deck/projects.hamlet +++ b/templates/deck/projects.hamlet @@ -21,7 +21,8 @@ $# . Role Project Enabled - $forall (project, role, enabled) <- stems + Approve + $forall (project, role, enabled, gestured, stemHash) <- stems #{show role} ^{projectLinkFedW project} @@ -30,4 +31,6 @@ $# . [x] $else [_] + $if not gestured + ^{buttonW POST "Approve" (DeckApproveCompR deckHash stemHash)} $# ^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)} diff --git a/th/routes b/th/routes index 40c9dfa..f52d89f 100644 --- a/th/routes +++ b/th/routes @@ -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