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

2024-04-29 09:58:04 +03:00 · 2024-04-29 09:58:04 +03:00 · ca6aa718f6
commit ca6aa718f6
parent ffe1c39fd3
6 changed files with 170 additions and 28 deletions
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@ -1044,6 +1044,7 @@ instance YesodBreadcrumbs App where
        ProjectAddChildR _ -> ("", Nothing)
        ProjectAddParentR _ -> ("", Nothing)

+        ProjectApproveComponentR _ _ -> ("", Nothing)
        ProjectApproveChildR _ _ -> ("", Nothing)
        ProjectApproveParentR _ _ -> ("", Nothing)

--- a/src/Vervis/Handler/Project.hs
+++ b/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
-                identView <-
-                    bitraverse
-                        (\ byKey -> do
+                (component, accept) <- do
+                    ident <- getComponentIdent cid
+                    accept <-
+                        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
-                            remoteActor <- getJust remoteActorID
-                            remoteObject <- getJust $ remoteActorIdent remoteActor
-                            inztance <- getJust $ remoteObjectInstance remoteObject
-                            return (inztance, remoteObject, remoteActor)
-                        )
-                        byKeyOrRaid
-                return (identView, componentRole c)
+                        (\ (_, actorID) -> getRemoteActorData actorID)
+                        ident
+                ((inviter, time), us) <- do
+                    usOrThem <-
+                        requireEitherAlt
+                            (getKeyBy $ UniqueComponentOriginInvite cid)
+                            (getKeyBy $ UniqueComponentOriginAdd cid)
+                            "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
--- a/src/Vervis/Persist/Collab.hs
+++ b/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
--- a/src/Vervis/Widget/Tracker.hs
+++ b/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)) =
-    [whamlet|
-        <a href="#{renderObjURI uActor}">
-          $maybe name <- remoteActorName actor
-            #{name}
-          $nothing
-            #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
-    |]
-    where
-    uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
+componentLinkFedW (Right a) = remoteActorLinkW a

 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
--- a/templates/project/components.hamlet
+++ b/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
-  $forall (comp, role) <- drafts
+    <th>Time
+    $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)}
--- a/th/routes
+++ b/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