UI: Deck: Projects: More detailed table + button for approving

2024-04-29 11:01:33 +03:00 · 2024-04-29 11:01:33 +03:00 · 12ea0c021e
commit 12ea0c021e
parent ca6aa718f6
6 changed files with 195 additions and 131 deletions
--- 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)
--- 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
--- 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
+        )
--- 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 ()
--- a/templates/deck/projects.hamlet
+++ b/templates/deck/projects.hamlet
@ -21,19 +21,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
  <tr>
    <th>Role
    <th>Project
-    <th>Enabled
-    <th>Approve
-  $forall (project, role, enabled, gestured, stemHash) <- stems
+    <th>Since
+  $forall (project, role, since) <- stems
    <tr>
      <td>#{show role}
      <td>^{projectLinkFedW project}
-      <td>
-        $if enabled
-          [x]
-        $else
-          [_]
-      $if not gestured
-        <td>^{buttonW POST "Approve" (DeckApproveCompR deckHash stemHash)}
+      <td>#{showDate since}
 $#    <td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}

 $if haveAdmin
@ -41,3 +34,34 @@ $if haveAdmin
  <form method=POST action=@{DeckAddProjectR deckHash} enctype=#{enctypeAP}>
    ^{widgetAP}
    <input type="submit">
+
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Via
+    <th>Invited project
+    <th>I accepted?
+    <th>Role
+    <th>Time
+    $if haveAdmin
+      <th>Approve
+  $forall (inviter, us, project, accept, time, role, stemID) <- drafts
+    <tr>
+      <td>^{actorLinkFedW inviter}
+      <td>
+        $if us
+          Us
+        $else
+          Them
+      <td>^{projectLinkFedW project}
+      <td>
+        $if accept
+          [x]
+        $else
+          [_]
+      <td>#{show role}
+      <td>#{showDate time}
+      $if haveAdmin && (not accept && not us)
+        <td>^{buttonW POST "Approve" (DeckApproveProjectR deckHash stemID)}
--- 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 ------------------------------------------------------------------