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

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)

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.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
-                E.on $ E.just (stem E.^. StemId) E.==. gestr E.?. StemComponentGestureRemoteStem
+                E.on $ deleg E.^. StemDelegateLocalGrant E.==. grant E.^. OutboxItemId
-                E.on $ E.just (stem E.^. StemId) E.==. gestl E.?. StemComponentGestureLocalStem
+                E.on $ accept E.^. StemComponentAcceptId E.==. deleg E.^. StemDelegateLocalStem
-                E.on $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem
+                E.on $ stem E.^. StemId E.==. accept E.^. StemComponentAcceptStem
-                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
-                return (stem, deleg, gestl, gestr)
+                return
-        stems' <- for stems $ \ (Entity stemID stem, deleg, gestl, gestr) -> do
+                    ( 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
+                    getRemoteActorData
-                        remoteActor <- getJust remoteActorID
-                        remoteObject <- getJust $ remoteActorIdent remoteActor
-                        inztance <- getJust $ remoteObjectInstance remoteObject
-                        return (inztance, remoteObject, remoteActor)
-                    )
                     j
-            stemHash <- encodeKeyHashid stemID
+            return (projectView, stemRole stem, time)
-            return (projectView, stemRole stem, isJust deleg, isJust gestl || isJust gestr, stemHash)
+        drafts <-
-        return (deck, actor, stems')
+            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
+postDeckApproveProjectR :: KeyHashid Deck -> StemId -> Handler Html
-postDeckApproveCompR deckHash stemHash = do
+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
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
-            _ <- get404 deckID
+            deck <- MaybeT $ get deckID
-            _ <- get404 stemID
+            _ <- MaybeT $ get stemID
-            Entity _ (StemIdentDeck _ deckID') <- getBy404 $ UniqueStemIdentDeck stemID
+            StemIdentDeck _ d <- MaybeT $ getValBy $ UniqueStemIdentDeck stemID
-            unless (deckID' == deckID) notFound
+            guard $ deckID == d
-            uInvite <- do
+
-                Entity originID _ <- getBy404 $ UniqueStemOriginInvite stemID
+            uAdd <- lift $ do
-                i <-
+                add <- getStemAdd stemID
-                    requireEitherAlt
+                renderActivityURI add
-                        (getValBy $ UniqueStemProjectGestureLocal originID)
+
-                        (getValBy $ UniqueStemProjectGestureRemote originID)
+            topic <- lift $ getStemProject stemID
-                        "Invite gesture not found"
+            lift $
-                        "Multiple invites"
+                (deckResource deck,uAdd,) <$>
-                case i of
+                bitraverse
-                    Left g -> do
+                    pure
-                        let k = stemProjectGestureLocalInvite g
+                    (getRemoteActorURI <=< getJust)
-                        oi <- getJust k
+                    topic
-                        a <- getKeyByJust $ UniqueActorOutbox $ outboxItemOutbox oi
+        (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
-                        p <- getKeyByJust $ UniquePersonActor a
+        (maybeSummary, audience, accept) <- do
-                        ph <- encodeKeyHashid p
+            uProject <-
-                        kh <- encodeKeyHashid k
+                case pidOrU of
-                        return $ encodeRouteHome $ PersonOutboxItemR ph kh
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
-                    Right g -> do
+                    Right u -> pure u
-                        a <- getJust $ stemProjectGestureRemoteInvite g
+            let uDeck = encodeRouteHome $ DeckR deckHash
-                        o <- getJust $ remoteActivityIdent a
+            C.acceptParentChild personID uAdd uProject uDeck
-                        h <- getJust $ remoteObjectInstance o
+        cap <- do
-                        return $ ObjURI (instanceHost h) (remoteObjectIdent o)
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
-            project <- getStemProject stemID
+            fromMaybeE maybeItem "You need to be have Admin access to the Deck to approve projects"
-            (uInvite,) <$> bitraverse pure (getRemoteActorURI <=< getJust) project
+        uCap <- lift $ renderActivityURI cap
-        (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
         (localRecips, remoteRecips, fwdHosts, action) <-
             C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
-        let cap =
+        let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
-                Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
         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

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
+        )

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
+    getActivityIdent add
-        (\ addID -> do
-            OutboxItem outboxID _ time <- getJust addID
-            Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
-            (,addID) <$> getLocalActor actorID
-        )
-        (\ addID -> do
-            add <- getJust addID
-            getRemoteActivityURI add
-        )
-        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
+    getActivityIdent add
-        (\ addID -> do
-            OutboxItem outboxID _ time <- getJust addID
-            Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
-            (,addID) <$> getLocalActor actorID
-        )
-        (\ addID -> do
-            add <- getJust addID
-            getRemoteActivityURI add
-        )
-        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
+    getActivityIdent add
-        (\ addID -> do
-            OutboxItem outboxID _ time <- getJust addID
-            Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID
-            (,addID) <$> getLocalActor actorID
-        )
-        (\ addID -> do
-            add <- getJust addID
-            getRemoteActivityURI add
-        )
-        add
 
 checkExistingStems
     :: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE ()

templates/deck/projects.hamlet

@@ -21,19 +21,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <tr>
     <th>Role
     <th>Project
-    <th>Enabled
+    <th>Since
-    <th>Approve
+  $forall (project, role, since) <- stems
-  $forall (project, role, enabled, gestured, stemHash) <- stems
     <tr>
       <td>#{show role}
       <td>^{projectLinkFedW project}
-      <td>
+      <td>#{showDate since}
-        $if enabled
-          [x]
-        $else
-          [_]
-      $if not gestured
-        <td>^{buttonW POST "Approve" (DeckApproveCompR deckHash stemHash)}
 $#    <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)}

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 ------------------------------------------------------------------