diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 6071b3b..55149fd 100644 --- 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) diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 2c84687..ccdcc94 100644 --- 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 diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index ad5ed42..fd31657 100644 --- 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 diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index c7c44f5..a595ac7 100644 --- 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| - - $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 diff --git a/templates/project/components.hamlet b/templates/project/components.hamlet index 1242d48..15c8689 100644 --- a/templates/project/components.hamlet +++ b/templates/project/components.hamlet @@ -39,9 +39,29 @@ $if haveAdmin
Inviter + | Via + | Invited component + | Component accepted? | Role - | Component - $forall (comp, role) <- drafts + | Time + $if haveAdmin + | Approve + $forall (inviter, us, component, accept, time, role, componentID) <- drafts |
---|---|---|---|---|---|---|---|
^{actorLinkFedW inviter} + | + $if us + Us + $else + Them + | ^{componentLinkFedW component} + | + $if accept + [x] + $else + [_] | #{show role} - | ^{componentLinkFedW comp} + | #{showDate time} + $if haveAdmin && (accept && not us) + | ^{buttonW POST "Approve" (ProjectApproveComponentR projectHash componentID)} diff --git a/th/routes b/th/routes index c720b7c..cda927b 100644 --- a/th/routes +++ b/th/routes @@ -373,5 +373,6 @@ /projects/#ProjectKeyHashid/child/add ProjectAddChildR POST /projects/#ProjectKeyHashid/parent/add ProjectAddParentR POST -/projects/#ProjectKeyHashid/child/approve/#SourceId ProjectApproveChildR POST -/projects/#ProjectKeyHashid/parent/approve/#DestId ProjectApproveParentR POST +/projects/#ProjectKeyHashid/component/approve/#ComponentId ProjectApproveComponentR POST +/projects/#ProjectKeyHashid/child/approve/#SourceId ProjectApproveChildR POST +/projects/#ProjectKeyHashid/parent/approve/#DestId ProjectApproveParentR POST |