From 12ea0c021e2032dc39c0447e8f28dfa8f6c069f7 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 29 Apr 2024 11:01:33 +0300 Subject: [PATCH] UI: Deck: Projects: More detailed table + button for approving --- src/Vervis/Foundation.hs | 2 +- src/Vervis/Handler/Deck.hs | 193 ++++++++++++++++++--------------- src/Vervis/Persist/Actor.hs | 17 +++ src/Vervis/Persist/Collab.hs | 68 ++++++------ templates/deck/projects.hamlet | 44 ++++++-- th/routes | 2 +- 6 files changed, 195 insertions(+), 131 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 55149fd..3d5dcf5 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -956,7 +956,7 @@ instance YesodBreadcrumbs App where DeckRemoveR _ _ -> ("", Nothing) DeckProjectsR d -> ("Projects", Just $ DeckR d) - DeckApproveCompR d c -> ("", Nothing) + DeckApproveProjectR d c -> ("", Nothing) DeckAddProjectR d -> ("", Nothing) TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d) diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index be3d8ea..00f4bdc 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -44,7 +44,7 @@ module Vervis.Handler.Deck , postDeckRemoveR , getDeckProjectsR , postDeckAddProjectR - , postDeckApproveCompR + , postDeckApproveProjectR @@ -66,6 +66,7 @@ module Vervis.Handler.Deck where import Control.Applicative +import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe @@ -589,19 +590,21 @@ getDeckProjectsR deckHash = do deck <- lift $ get404 deckID MaybeT $ getCapability personID (Left $ deckResource deck) AP.RoleAdmin ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm - (deck, actor, stems) <- runDB $ do + (deck, actor, stems, drafts) <- runDB $ do deck <- get404 deckID actor <- getJust $ deckActor deck stems <- - E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.LeftOuterJoin` 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 $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem - E.on $ E.just (stem E.^. StemId) E.==. accept E.?. StemComponentAcceptStem + E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do + E.on $ deleg E.^. StemDelegateLocalGrant E.==. grant E.^. OutboxItemId + E.on $ 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, gestl, gestr) - stems' <- for stems $ \ (Entity stemID stem, deleg, gestl, gestr) -> do + return + ( stem + , grant E.^. OutboxItemPublished + ) + stems' <- for stems $ \ (Entity stemID stem, E.Value time) -> do j <- getStemProject stemID projectView <- bitraverse @@ -610,17 +613,69 @@ getDeckProjectsR deckHash = do actor <- getJust actorID return (projectID, actor) ) - (\ remoteActorID -> do - remoteActor <- getJust remoteActorID - remoteObject <- getJust $ remoteActorIdent remoteActor - inztance <- getJust $ remoteObjectInstance remoteObject - return (inztance, remoteObject, remoteActor) - ) + getRemoteActorData j - stemHash <- encodeKeyHashid stemID - return (projectView, stemRole stem, isJust deleg, isJust gestl || isJust gestr, stemHash) - return (deck, actor, stems') + return (projectView, stemRole stem, time) + drafts <- + E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg) -> do + E.on $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem + E.on $ E.just (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 E.&&. + E.isNothing (deleg E.?. StemDelegateLocalId) + return stem + drafts' <- for drafts $ \ (Entity stemID (Stem role)) -> do + (project, accept) <- do + project <- getStemProject stemID + accept <- isJust <$> getBy (UniqueStemComponentAccept stemID) + (,accept) <$> bitraverse + (\ j -> do + resourceID <- projectResource <$> getJust j + Resource actorID <- getJust resourceID + actor <- getJust actorID + return (j, actor) + ) + getRemoteActorData + project + ((inviter, time), us) <- do + usOrThem <- + requireEitherAlt + (getKeyBy $ UniqueStemOriginAdd stemID) + (getKeyBy $ UniqueStemOriginInvite stemID) + "Neither us nor them" + "Both us and them" + (addOrActor, us) <- + case usOrThem of + Left _usID -> (,True) <$> + requireEitherAlt + (fmap stemComponentGestureLocalActivity <$> getValBy (UniqueStemComponentGestureLocal stemID)) + (fmap (stemComponentGestureRemoteActor &&& stemComponentGestureRemoteActivity) <$> getValBy (UniqueStemComponentGestureRemote stemID)) + "Neither local not remote" + "Both local and remote" + Right themID -> (,False) <$> + requireEitherAlt + (fmap stemProjectGestureLocalInvite <$> getValBy (UniqueStemProjectGestureLocal themID)) + (fmap (stemProjectGestureRemoteActor &&& stemProjectGestureRemoteInvite) <$> getValBy (UniqueStemProjectGestureRemote themID)) + "Neither local not remote" + "Both local and remote" + (,us) <$> case addOrActor of + Left addID -> do + OutboxItem outboxID _ time <- getJust addID + Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID + (,time) . Left . (,actor) <$> getLocalActor actorID + Right (actorID, addID) -> do + RemoteActivity _ _ time <- getJust addID + (,time) . Right <$> getRemoteActorData actorID + return (inviter, us, project, accept, time, role, stemID) + return (deck, actor, stems', drafts') defaultLayout $(widgetFile "deck/projects") + where + getRemoteActorData actorID = do + actor <- getJust actorID + object <- getJust $ remoteActorIdent actor + inztance <- getJust $ remoteObjectInstance object + return (inztance, object, actor) addProjectForm = renderDivs $ areq fedUriField "(URI) Project" Nothing @@ -669,91 +724,57 @@ postDeckAddProjectR deckHash = do Right inviteID -> setMessage "Add sent" redirect $ DeckProjectsR deckHash -postDeckApproveCompR :: KeyHashid Deck -> KeyHashid Stem -> Handler Html -postDeckApproveCompR deckHash stemHash = do +postDeckApproveProjectR :: KeyHashid Deck -> StemId -> Handler Html +postDeckApproveProjectR deckHash stemID = 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 $ do - resourceID <- deckResource <$> get404 deckID - getGrant resourceID personID - fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people" - grantHash <- encodeKeyHashid grantID - let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash + mpidOrU <- lift $ runDB $ runMaybeT $ do + deck <- MaybeT $ get deckID + _ <- MaybeT $ get stemID + StemIdentDeck _ d <- MaybeT $ getValBy $ UniqueStemIdentDeck stemID + guard $ deckID == d + + uAdd <- lift $ do + add <- getStemAdd stemID + renderActivityURI add + + topic <- lift $ getStemProject stemID + lift $ + (deckResource deck,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 uDeck = encodeRouteHome $ DeckR deckHash + C.acceptParentChild personID uAdd uProject 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 projects" + uCap <- lift $ renderActivityURI cap (localRecips, remoteRecips, fwdHosts, action) <- C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept - let cap = - Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID) + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap handleViaActor - personID (Just cap) localRecips remoteRecips fwdHosts action + personID (Just cap') localRecips remoteRecips fwdHosts action case result of Left e -> do setMessage $ toHtml e - Right removeID -> do + Right removeID -> setMessage "Accept sent" redirect $ DeckProjectsR deckHash - - - - - - - - - - - - - - - - - - - - - - - {- getProjectsR :: ShrIdent -> Handler Html getProjectsR ident = do diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 6debea3..8d50a7a 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -41,6 +41,7 @@ module Vervis.Persist.Actor , doneDB , insertToInbox , adaptErrbox + , getActivityIdent ) where @@ -388,3 +389,19 @@ adaptErrbox inboxID unread behavior now key ve@(Left (VA.Verse authorIdMsig body (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread lift $ update itemID [InboxItemResult =. err] throwE err + +getActivityIdent + :: MonadIO m + => Either OutboxItemId RemoteActivityId + -> ReaderT SqlBackend m (Either (LocalActorBy Key, OutboxItemId) FedURI) +getActivityIdent = + bitraverse + (\ itemID -> do + OutboxItem outboxID _ time <- getJust itemID + Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID + (,itemID) <$> getLocalActor actorID + ) + (\ actID -> do + act <- getJust actID + getRemoteActivityURI act + ) diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index fd31657..92fb609 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -20,6 +20,7 @@ module Vervis.Persist.Collab , getPermitTopic , getStemIdent , getStemProject + , getStemAdd , getGrantRecip , getComponentE , getTopicGrants @@ -168,6 +169,37 @@ getStemProject stemID = "Found Stem without project" "Found Stem with multiple projects" +getStemAdd + :: MonadIO m + => StemId + -> ReaderT SqlBackend m + (Either + (LocalActorBy Key, OutboxItemId) + FedURI + ) +getStemAdd stemID = do + usOrThem <- + requireEitherAlt + (getKeyBy $ UniqueStemOriginAdd stemID) + (getKeyBy $ UniqueStemOriginInvite stemID) + "Neither us nor them" + "Both us and them" + add <- + case usOrThem of + Left _usID -> + requireEitherAlt + (fmap stemComponentGestureLocalActivity <$> getValBy (UniqueStemComponentGestureLocal stemID)) + (fmap stemComponentGestureRemoteActivity <$> getValBy (UniqueStemComponentGestureRemote stemID)) + "Neither local not remote" + "Both local and remote" + Right themID -> + requireEitherAlt + (fmap stemProjectGestureLocalInvite <$> getValBy (UniqueStemProjectGestureLocal themID)) + (fmap stemProjectGestureRemoteInvite <$> getValBy (UniqueStemProjectGestureRemote themID)) + "Neither local not remote" + "Both local and remote" + getActivityIdent add + getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e getComponentE (ComponentRepo k) e = ComponentRepo <$> getEntityE k e @@ -467,17 +499,7 @@ getComponentAdd componentID = do (fmap componentGestureRemoteAdd <$> getValBy (UniqueComponentGestureRemote themID)) "Neither local not remote" "Both local and remote" - bitraverse - (\ addID -> do - OutboxItem outboxID _ time <- getJust addID - Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID - (,addID) <$> getLocalActor actorID - ) - (\ addID -> do - add <- getJust addID - getRemoteActivityURI add - ) - add + getActivityIdent add getSourceTopic :: MonadIO m @@ -534,17 +556,7 @@ getSourceAdd sourceID = do (fmap sourceThemGestureRemoteAdd <$> getValBy (UniqueSourceThemGestureRemote themID)) "Neither local not remote" "Both local and remote" - bitraverse - (\ addID -> do - OutboxItem outboxID _ time <- getJust addID - Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID - (,addID) <$> getLocalActor actorID - ) - (\ addID -> do - add <- getJust addID - getRemoteActivityURI add - ) - add + getActivityIdent add getDestTopic :: MonadIO m @@ -620,17 +632,7 @@ getDestAdd destID = do (fmap destThemGestureRemoteAdd <$> getValBy (UniqueDestThemGestureRemote themID)) "Neither local not remote" "Both local and remote" - bitraverse - (\ addID -> do - OutboxItem outboxID _ time <- getJust addID - Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID - (,addID) <$> getLocalActor actorID - ) - (\ addID -> do - add <- getJust addID - getRemoteActivityURI add - ) - add + getActivityIdent add checkExistingStems :: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE () diff --git a/templates/deck/projects.hamlet b/templates/deck/projects.hamlet index c6da0a7..5c6c813 100644 --- a/templates/deck/projects.hamlet +++ b/templates/deck/projects.hamlet @@ -21,19 +21,12 @@ $# . Role Project - Enabled - Approve - $forall (project, role, enabled, gestured, stemHash) <- stems + Since + $forall (project, role, since) <- stems #{show role} ^{projectLinkFedW project} - - $if enabled - [x] - $else - [_] - $if not gestured - ^{buttonW POST "Approve" (DeckApproveCompR deckHash stemHash)} + #{showDate since} $# ^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)} $if haveAdmin @@ -41,3 +34,34 @@ $if haveAdmin
^{widgetAP} + +

Invites + + + + +
Inviter + Via + Invited project + I accepted? + Role + Time + $if haveAdmin + Approve + $forall (inviter, us, project, accept, time, role, stemID) <- drafts +
^{actorLinkFedW inviter} + + $if us + Us + $else + Them + ^{projectLinkFedW project} + + $if accept + [x] + $else + [_] + #{show role} + #{showDate time} + $if haveAdmin && (not accept && not us) + ^{buttonW POST "Approve" (DeckApproveProjectR deckHash stemID)} diff --git a/th/routes b/th/routes index cda927b..659deb0 100644 --- a/th/routes +++ b/th/routes @@ -251,7 +251,7 @@ /decks/#DeckKeyHashid/add-project DeckAddProjectR POST -/decks/#DeckKeyHashid/projects/approve/#StemKeyHashid DeckApproveCompR POST +/decks/#DeckKeyHashid/project/approve/#StemId DeckApproveProjectR POST ---- Ticket ------------------------------------------------------------------