UI: Project: Components: More detailed table + button for approving

src/Vervis/Foundation.hs

@@ -1044,6 +1044,7 @@ instance YesodBreadcrumbs App where
         ProjectAddChildR _ -> ("", Nothing)
         ProjectAddParentR _ -> ("", Nothing)
 
+        ProjectApproveComponentR _ _ -> ("", Nothing)
         ProjectApproveChildR _ _ -> ("", Nothing)
         ProjectApproveParentR _ _ -> ("", Nothing)
 

src/Vervis/Handler/Project.hs

@@ -50,6 +50,7 @@ module Vervis.Handler.Project
     , postProjectAddChildR
     , postProjectAddParentR
 
+    , postProjectApproveComponentR
     , postProjectApproveChildR
     , postProjectApproveParentR
     )
@@ -527,10 +528,14 @@ getProjectComponentsR projectHash = do
                         E.isNothing (enable E.?. ComponentEnableId)
                     return comp
             ds' <- for ds $ \ (Entity cid c) -> do
-                byKeyOrRaid <- bimap snd snd <$> getComponentIdent cid
+                (component, accept) <- do
-                identView <-
+                    ident <- getComponentIdent cid
-                    bitraverse
+                    accept <-
-                        (\ byKey -> do
+                        case bimap fst fst ident of
+                            Left localID -> isJust <$> getBy (UniqueComponentAcceptLocal localID)
+                            Right remoteID -> isJust <$> getBy (UniqueComponentAcceptRemote remoteID)
+                    (,accept) <$> bitraverse
+                        (\ (_, byKey) -> do
                             actorID <-
                                 case byKey of
                                     ComponentRepo k -> repoActor <$> getJust k
@@ -539,16 +544,46 @@ getProjectComponentsR projectHash = do
                             actor <- getJust actorID
                             return (byKey, actor)
                         )
-                        (\ remoteActorID -> do
+                        (\ (_, actorID) -> getRemoteActorData actorID)
-                            remoteActor <- getJust remoteActorID
+                        ident
-                            remoteObject <- getJust $ remoteActorIdent remoteActor
+                ((inviter, time), us) <- do
-                            inztance <- getJust $ remoteObjectInstance remoteObject
+                    usOrThem <-
-                            return (inztance, remoteObject, remoteActor)
+                        requireEitherAlt
-                        )
+                            (getKeyBy $ UniqueComponentOriginInvite cid)
-                        byKeyOrRaid
+                            (getKeyBy $ UniqueComponentOriginAdd cid)
-                return (identView, componentRole c)
+                            "Neither us nor them"
+                            "Both us and them"
+                    (addOrActor, us) <-
+                        case usOrThem of
+                            Left _usID -> (,True) <$>
+                                requireEitherAlt
+                                    (fmap componentProjectGestureLocalActivity <$> getValBy (UniqueComponentProjectGestureLocal cid))
+                                    (fmap (componentProjectGestureRemoteActor &&& componentProjectGestureRemoteActivity) <$> getValBy (UniqueComponentProjectGestureRemote cid))
+                                    "Neither local not remote"
+                                    "Both local and remote"
+                            Right themID -> (,False) <$>
+                                requireEitherAlt
+                                    (fmap componentGestureLocalAdd <$> getValBy (UniqueComponentGestureLocal themID))
+                                    (fmap (componentGestureRemoteActor &&& componentGestureRemoteAdd) <$> getValBy (UniqueComponentGestureRemote 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, component, accept, time, componentRole c, cid)
             return (project, actor, cs', ds')
         $(widgetFile "project/components")
+        where
+        getRemoteActorData actorID = do
+            actor <- getJust actorID
+            object <- getJust $ remoteActorIdent actor
+            inztance <- getJust $ remoteObjectInstance object
+            return (inztance, object, actor)
 
 getProjectCollabLiveR
     :: KeyHashid Project -> KeyHashid CollabEnable -> Handler ()
@@ -1118,6 +1153,56 @@ postProjectAddParentR projectHash = do
             setMessage "Add sent"
     redirect $ ProjectChildrenR projectHash
 
+postProjectApproveComponentR :: KeyHashid Project -> ComponentId -> Handler Html
+postProjectApproveComponentR projectHash compID = do
+    projectID <- decodeKeyHashid404 projectHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            project <- MaybeT $ get projectID
+            Component j _ <- MaybeT $ get compID
+            guard $ projectID == j
+
+            uAdd <- lift $ do
+                add <- getComponentAdd compID
+                renderActivityURI add
+
+            topic <- lift $ bimap snd snd <$> getComponentIdent compID
+            lift $
+                (projectResource project,uAdd,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, accept) <- do
+            uComponent <-
+                case pidOrU of
+                    Left c -> encodeRouteHome . renderLocalResource <$> hashLocalResource (componentResource c)
+                    Right u -> pure u
+            let uProject = encodeRouteHome $ ProjectR projectHash
+            C.acceptParentChild personID uAdd uProject uComponent
+        cap <- do
+            maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+            fromMaybeE maybeItem "You need to be have Admin access to the Project to approve components"
+        uCap <- lift $ renderActivityURI cap
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
+        let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
+        handleViaActor
+            personID (Just cap') localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+        Right removeID ->
+            setMessage "Accept sent"
+    redirect $ ProjectComponentsR projectHash
+
 postProjectApproveChildR :: KeyHashid Project -> SourceId -> Handler Html
 postProjectApproveChildR projectHash sourceID = do
     projectID <- decodeKeyHashid404 projectHash

src/Vervis/Persist/Collab.hs

@@ -32,6 +32,7 @@ module Vervis.Persist.Collab
     , getGrant
 
     , getComponentIdent
+    , getComponentAdd
     , getSourceTopic
     , getSourceAdd
     , getDestTopic
@@ -437,6 +438,47 @@ getComponentIdent componentID = do
         (\ (Entity k v) -> pure (k, componentRemoteActor v))
         ident
 
+getComponentAdd
+    :: MonadIO m
+    => ComponentId
+    -> ReaderT SqlBackend m
+        (Either
+            (LocalActorBy Key, OutboxItemId)
+            FedURI
+        )
+getComponentAdd componentID = do
+    usOrThem <-
+        requireEitherAlt
+            (getKeyBy $ UniqueComponentOriginInvite componentID)
+            (getKeyBy $ UniqueComponentOriginAdd componentID)
+            "Neither us nor them"
+            "Both us and them"
+    add <-
+        case usOrThem of
+            Left _usID ->
+                requireEitherAlt
+                    (fmap componentProjectGestureLocalActivity <$> getValBy (UniqueComponentProjectGestureLocal componentID))
+                    (fmap componentProjectGestureRemoteActivity <$> getValBy (UniqueComponentProjectGestureRemote componentID))
+                    "Neither local not remote"
+                    "Both local and remote"
+            Right themID ->
+                requireEitherAlt
+                    (fmap componentGestureLocalAdd <$> getValBy (UniqueComponentGestureLocal themID))
+                    (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
+
 getSourceTopic
     :: MonadIO m
     => SourceId

src/Vervis/Widget/Tracker.hs

@@ -97,16 +97,7 @@ componentLinkFedW
     :: Either (ComponentBy Key, Actor) (Instance, RemoteObject, RemoteActor)
     -> Widget
 componentLinkFedW (Left (c, a)) = componentLinkW c a
-componentLinkFedW (Right (inztance, object, actor)) =
+componentLinkFedW (Right a) = remoteActorLinkW a
-    [whamlet|
-        <a href="#{renderObjURI uActor}">
-          $maybe name <- remoteActorName actor
-            #{name}
-          $nothing
-            #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
-    |]
-    where
-    uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
 
 projectLinkFedW
     :: Either (ProjectId, Actor) (Instance, RemoteObject, RemoteActor)
@@ -161,7 +152,9 @@ actorLinkFedW
     :: Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor)
     -> Widget
 actorLinkFedW (Left (c, a)) = actorLinkW c a
-actorLinkFedW (Right (inztance, object, actor)) = do
+actorLinkFedW (Right a) = remoteActorLinkW a
+
+remoteActorLinkW (inztance, object, actor) = do
     maybeID <-
         handlerToWidget $ runDB $
             getKeyBy $ UniqueRemoteActor $ remoteActorIdent actor

templates/project/components.hamlet

@@ -39,9 +39,29 @@ $if haveAdmin
 
 <table>
   <tr>
+    <th>Inviter
+    <th>Via
+    <th>Invited component
+    <th>Component accepted?
     <th>Role
-    <th>Component
+    <th>Time
-  $forall (comp, role) <- drafts
+    $if haveAdmin
+      <th>Approve
+  $forall (inviter, us, component, accept, time, role, componentID) <- drafts
     <tr>
+      <td>^{actorLinkFedW inviter}
+      <td>
+        $if us
+          Us
+        $else
+          Them
+      <td>^{componentLinkFedW component}
+      <td>
+        $if accept
+          [x]
+        $else
+          [_]
       <td>#{show role}
-      <td>^{componentLinkFedW comp}
+      <td>#{showDate time}
+      $if haveAdmin && (accept && not us)
+        <td>^{buttonW POST "Approve" (ProjectApproveComponentR projectHash componentID)}

th/routes

@@ -373,5 +373,6 @@
 /projects/#ProjectKeyHashid/child/add ProjectAddChildR POST
 /projects/#ProjectKeyHashid/parent/add ProjectAddParentR POST
 
+/projects/#ProjectKeyHashid/component/approve/#ComponentId ProjectApproveComponentR POST
 /projects/#ProjectKeyHashid/child/approve/#SourceId        ProjectApproveChildR     POST
 /projects/#ProjectKeyHashid/parent/approve/#DestId         ProjectApproveParentR    POST