From f864274ff05df4e5fb07e65ce15104d85ff02eca Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 11 May 2024 22:25:50 +0300 Subject: [PATCH] S2S: Component: Implement Add-based version of inviteComponent --- src/Vervis/Actor/Common.hs | 466 ++++++++++++++++++----------- src/Vervis/Data/Collab.hs | 22 ++ src/Vervis/Foundation.hs | 2 + src/Vervis/Handler/Deck.hs | 83 +---- src/Vervis/Handler/Loom.hs | 26 ++ src/Vervis/Handler/Repo.hs | 28 ++ src/Vervis/Persist/Actor.hs | 7 + src/Vervis/Persist/Collab.hs | 81 +++++ src/Web/ActivityPub.hs | 12 +- templates/loom/projects.hamlet | 70 +++++ templates/loom/widget/nav.hamlet | 3 + templates/repo/projects.hamlet | 100 +++++++ templates/repo/source-darcs.hamlet | 3 + templates/repo/source-git.hamlet | 3 + th/routes | 2 + 15 files changed, 653 insertions(+), 255 deletions(-) create mode 100644 templates/loom/projects.hamlet create mode 100644 templates/repo/projects.hamlet diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 10678aa..242c95f 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -1891,9 +1891,8 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body -- Meaning: An actor is adding some object to some target -- Behavior: --- * If the object is me: --- * Verify that the object is me --- * Verify the target is some project's components collection URI +-- * If target is my context (i.e. parents) collection: +-- * Verify the object is a project -- * Verify the Add is authorized -- * For all the Stem records I have for this project: -- * Verify I'm not yet a member of the project @@ -1911,6 +1910,19 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body -- * Author's followers -- * Project's followers -- * My followers +-- +-- * If the object is me: +-- * Verify the target is some project's components collection URI +-- * For each Stem record I have for this project: +-- * Verify it's not enabled yet, i.e. I'm not already a component +-- of this project +-- * Verify it's not in them-Invite-Accept state, already got the +-- project's Accept and waiting for my approval +-- * Verify it's not in us-Add-Accept state, has my approval and +-- waiting for the project's side +-- * Create a Stem record in DB +-- * Insert the Add to my inbox +-- * Forward the Add to my followers componentAdd :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> KomponentId) @@ -1922,183 +1934,293 @@ componentAdd -> ActE (Text, Act (), Next) componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add = do - let meComponent = toComponent meID - meResource = componentResource meComponent - meActor = resourceToActor meResource - - -- Check capability - capability <- do - - -- Verify that a capability is provided - uCap <- do - let muCap = AP.activityCapability $ actbActivity body - fromMaybeE muCap "No capability provided" - - -- Verify the capability URI is one of: - -- * Outbox item URI of a local actor, i.e. a local activity - -- * A remote URI - cap <- nameExceptT "Add capability" $ parseActivityURI' uCap - - -- Verify the capability is local - case cap of - Left (actorByKey, _, outboxItemID) -> - return (actorByKey, outboxItemID) - _ -> throwE "Capability is remote i.e. definitely not by me" - - -- Check input - projectComps <- do - let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (component, projectComps, role) <- parseAdd author add - unless (component == Left meActor) $ - throwE "Add object isn't me" - unless (role == AP.RoleAdmin) $ - throwE "Add role isn't admin" - case projectComps of - Left (ATProjectComponents j) -> return $ Left j - Right u -> return $ Right u - _ -> throwE "I'm being added somewhere invalid" - - -- If project is local, find it in our DB - -- If project is remote, HTTP GET it and store in our DB (if it's already - -- there, no need for HTTP) - -- - -- NOTE: This is a blocking HTTP GET done right here in the handler, - -- which is NOT a good idea. Ideally, it would be done async, and the - -- handler result would be sent later in a separate (e.g. Accept) activity. - -- But for the PoC level, the current situation will hopefully do. - projectDB <- - bitraverse - (withDBExcept . flip getEntityE "Project not found in DB") - (\ u@(ObjURI h luComps) -> do - manager <- asksEnv envHttpManager - collection <- - ExceptT $ first T.pack <$> - AP.fetchAPID - manager - (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) - h - luComps - luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context" + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (object, target, role) <- parseAdd author add + unless (role == AP.RoleAdmin) $ + throwE "Add role isn't admin" + case (target, object) of + (Left at, _) + | addTargetComponentProjects at == Just (toComponent meID) -> do project <- - ExceptT $ first T.pack <$> - AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject - unless (AP.projectComponents project == luComps) $ - throwE "The collection isn't the project's components collection" - - instanceID <- - lift $ withDB $ either entityKey id <$> insertBy' (Instance h) - result <- - ExceptT $ first (T.pack . displayException) <$> - fetchRemoteActor' instanceID h luProject - case result of - Left Nothing -> throwE "Target @id mismatch" - Left (Just err) -> throwE $ T.pack $ displayException err - Right Nothing -> throwE "Target isn't an actor" - Right (Just actor) -> do - unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $ - throwE "Remote project type isn't Project" - return $ entityKey actor - ) - projectComps - - meHash <- encodeKeyHashid meID - let meComponentHash = toComponent meHash - meResourceHash = componentResource meComponentHash - meActorHash = resourceToActor meResourceHash - - maybeNew <- withDBExcept $ do - - -- Grab me from DB - komponentID <- lift $ grabKomponent <$> getJust meID - Komponent resourceID <- lift $ getJust komponentID - Resource meActorID <- lift $ getJust resourceID - actor <- lift $ getJust meActorID - - -- Find existing Stem records I have for this project - -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept - -- mode - checkExistingStems komponentID projectDB - - -- Verify the specified capability gives relevant access - verifyCapability' capability authorIdMsig meResource AP.RoleAdmin - - -- Insert the Add to my inbox - mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False - lift $ for mractid $ \ (inboxItemID, addDB) -> do - - -- Create a Stem record in DB - acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now - insertStem komponentID projectDB addDB acceptID - - -- Prepare forwarding Add to my followers - let sieve = makeRecipientSet [] [localActorFollowers meActorHash] - - -- Prepare an Accept activity and insert to my outbox - accept@(actionAccept, _, _, _) <- prepareAccept projectDB - _luAccept <- updateOutboxItem' meActor acceptID actionAccept - - return (meActorID, sieve, acceptID, accept, inboxItemID) - - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do - forwardActivity authorIdMsig body meActor actorID sieve - lift $ sendActivity - meActor actorID localRecipsAccept - remoteRecipsAccept fwdHostsAccept acceptID actionAccept - doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept" + bitraverse + (\case + LocalActorProject j -> pure j + _ -> throwE "Adding me to a local non-project" + ) + pure + object + addProjectActive role project + (_, Left la) + | resourceToActor (componentResource $ toComponent meID) == la -> do + case target of + Left (ATProjectComponents j) -> + addProjectPassive role $ Left j + Right (ObjURI h luColl) -> do + -- NOTE this is HTTP GET done synchronously in the activity + -- handler + manager <- asksEnv envHttpManager + c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl + lu <- fromMaybeE (AP.collectionContext c) "No context" + j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu + if luColl == AP.projectComponents j + then addProjectPassive role $ Right $ ObjURI h lu + else throwE "Non-components collection" + _ -> throwE "I'm being added somewhere irrelevant" + _ -> throwE "This Add isn't for me" where - insertStem komponentID projectDB addDB acceptID = do - stemID <- insert $ Stem AP.RoleAdmin komponentID - case projectDB of - Left (Entity projectID _) -> - insert_ $ StemProjectLocal stemID projectID - Right remoteActorID -> - insert_ $ StemProjectRemote stemID remoteActorID - insert_ $ StemOriginAdd stemID - case addDB of - Left (_, _, addID) -> - insert_ $ StemComponentGestureLocal stemID addID - Right (author, _, addID) -> - insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID - insert_ $ StemComponentAccept stemID acceptID + addProjectActive role project = do - prepareAccept projectDB = do - encodeRouteHome <- getEncodeRouteHome + let meComponent = toComponent meID + meResource = componentResource meComponent + meActor = resourceToActor meResource - audAdder <- makeAudSenderWithFollowers authorIdMsig - audProject <- + -- Check capability + capability <- do + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + cap <- nameExceptT "Add capability" $ parseActivityURI' uCap + + -- Verify the capability is local + case cap of + Left (actorByKey, _, outboxItemID) -> + return (actorByKey, outboxItemID) + _ -> throwE "Capability is remote i.e. definitely not by me" + + -- Check input + unless (role == AP.RoleAdmin) $ throwE "Add role isn't admin" + + -- If project is local, find it in our DB + -- If project is remote, HTTP GET it and store in our DB (if it's already + -- there, no need for HTTP) + -- + -- NOTE: This is a blocking HTTP GET done right here in the handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result would be sent later in a separate (e.g. Accept) activity. + -- But for the PoC level, the current situation will hopefully do. + projectDB <- + bitraverse + (withDBExcept . flip getEntityE "Project not found in DB") + (\ u@(ObjURI h luProject) -> do + manager <- asksEnv envHttpManager + project <- + ExceptT $ first T.pack <$> + AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor' instanceID h luProject + case result of + Left Nothing -> throwE "Target @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Target isn't an actor" + Right (Just actor) -> do + unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $ + throwE "Remote project type isn't Project" + return $ entityKey actor + ) + project + + meHash <- encodeKeyHashid meID + let meComponentHash = toComponent meHash + meResourceHash = componentResource meComponentHash + meActorHash = resourceToActor meResourceHash + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + komponentID <- lift $ grabKomponent <$> getJust meID + Komponent resourceID <- lift $ getJust komponentID + Resource meActorID <- lift $ getJust resourceID + actor <- lift $ getJust meActorID + + -- Find existing Stem records I have for this project + -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept + -- mode + checkExistingStems komponentID projectDB + + -- Verify the specified capability gives relevant access + verifyCapability' capability authorIdMsig meResource AP.RoleAdmin + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Stem record in DB + acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now + insertStem komponentID projectDB addDB acceptID + + -- Prepare forwarding Add to my followers + let sieve = makeRecipientSet [] [localActorFollowers meActorHash] + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- prepareAccept projectDB + _luAccept <- updateOutboxItem' meActor acceptID actionAccept + + return (meActorID, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + forwardActivity authorIdMsig body meActor actorID sieve + lift $ sendActivity + meActor actorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "[Add-project-active] Recorded and forwarded the Add, sent an Accept" + + where + + insertStem komponentID projectDB addDB acceptID = do + stemID <- insert $ Stem AP.RoleAdmin komponentID case projectDB of - Left (Entity j _) -> do - jh <- encodeKeyHashid j - return $ - AudLocal - [LocalActorProject jh] - [LocalStageProjectFollowers jh] - Right remoteActorID -> do - ra <- getJust remoteActorID - ObjURI h lu <- getRemoteActorURI ra - return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) - audComponent <- - AudLocal [] . pure . localActorFollowers <$> - hashLocalActor (resourceToActor $ componentResource $ toComponent meID) - uAdd <- lift $ getActivityURI authorIdMsig + Left (Entity projectID _) -> + insert_ $ StemProjectLocal stemID projectID + Right remoteActorID -> + insert_ $ StemProjectRemote stemID remoteActorID + insert_ $ StemOriginAdd stemID + case addDB of + Left (_, _, addID) -> + insert_ $ StemComponentGestureLocal stemID addID + Right (author, _, addID) -> + insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID + insert_ $ StemComponentAccept stemID acceptID - let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audAdder, audProject, audComponent] + prepareAccept projectDB = do + encodeRouteHome <- getEncodeRouteHome - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [uAdd] - , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = uAdd - , AP.acceptResult = Nothing + audAdder <- makeAudSenderWithFollowers authorIdMsig + audProject <- + case projectDB of + Left (Entity j _) -> do + jh <- encodeKeyHashid j + return $ + AudLocal + [LocalActorProject jh] + [LocalStageProjectFollowers jh] + Right remoteActorID -> do + ra <- getJust remoteActorID + ObjURI h lu <- getRemoteActorURI ra + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audComponent <- + AudLocal [] . pure . localActorFollowers <$> + hashLocalActor (resourceToActor $ componentResource $ toComponent meID) + uAdd <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audAdder, audProject, audComponent] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uAdd] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uAdd + , AP.acceptResult = Nothing + } } - } - return (action, recipientSet, remoteActors, fwdHosts) + return (action, recipientSet, remoteActors, fwdHosts) + + addProjectPassive role project = do + + let meComponent = toComponent meID + meResource = componentResource meComponent + meActor = resourceToActor meResource + + -- Check input + unless (role == AP.RoleAdmin) $ throwE "Add role isn't admin" + + -- If project is local, find it in our DB + -- If project is remote, HTTP GET it and store in our DB (if it's already + -- there, no need for HTTP) + -- + -- NOTE: This is a blocking HTTP GET done right here in the handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result would be sent later in a separate (e.g. Accept) activity. + -- But for the PoC level, the current situation will hopefully do. + projectDB <- + bitraverse + (withDBExcept . flip getEntityE "Project not found in DB") + (\ u@(ObjURI h luProject) -> do + manager <- asksEnv envHttpManager + project <- + ExceptT $ first T.pack <$> + AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor' instanceID h luProject + case result of + Left Nothing -> throwE "Target @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Target isn't an actor" + Right (Just actor) -> do + unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $ + throwE "Remote project type isn't Project" + return $ entityKey actor + ) + project + + meHash <- encodeKeyHashid meID + let meComponentHash = toComponent meHash + meResourceHash = componentResource meComponentHash + meActorHash = resourceToActor meResourceHash + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + komponentID <- lift $ grabKomponent <$> getJust meID + Komponent resourceID <- lift $ getJust komponentID + Resource meActorID <- lift $ getJust resourceID + actor <- lift $ getJust meActorID + + -- Find existing Stem records I have for this project + -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept + -- mode + checkExistingStems komponentID projectDB + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create a Stem record in DB + insertStem komponentID projectDB addDB + + -- Prepare forwarding Add to my followers + let sieve = makeRecipientSet [] [localActorFollowers meActorHash] + + return (meActorID, sieve, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorID, sieve, inboxItemID) -> do + forwardActivity authorIdMsig body meActor actorID sieve + doneDB inboxItemID "[Add-parent-passive] Recorded and forwarded the Add" + + where + + insertStem komponentID projectDB addDB = do + stemID <- insert $ Stem AP.RoleAdmin komponentID + case projectDB of + Left (Entity projectID _) -> + insert_ $ StemProjectLocal stemID projectID + Right remoteActorID -> + insert_ $ StemProjectRemote stemID remoteActorID + originID <- insert $ StemOriginInvite stemID + case addDB of + Left (_, _, addID) -> + insert_ $ StemProjectGestureLocal originID addID + Right (author, _, addID) -> + insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) addID diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 3a17226..aea108f 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -31,6 +31,7 @@ module Vervis.Data.Collab , parseRemove , AddTarget (..) , addTargetResource + , addTargetComponentProjects , parseAdd , ComponentBy (..) @@ -421,6 +422,9 @@ data AddTarget | ATProjectChildren ProjectId | ATGroupParents GroupId | ATGroupChildren GroupId + | ATRepoProjects RepoId + | ATDeckProjects DeckId + | ATLoomProjects LoomId deriving Eq addTargetResource :: AddTarget -> LocalResourceBy Key @@ -430,6 +434,15 @@ addTargetResource = \case ATProjectChildren j -> LocalResourceProject j ATGroupParents g -> LocalResourceGroup g ATGroupChildren g -> LocalResourceGroup g + ATRepoProjects r -> LocalResourceRepo r + ATDeckProjects d -> LocalResourceDeck d + ATLoomProjects l -> LocalResourceLoom l + +addTargetComponentProjects = \case + ATRepoProjects r -> Just $ ComponentRepo r + ATDeckProjects d -> Just $ ComponentDeck d + ATLoomProjects l -> Just $ ComponentLoom l + _ -> Nothing parseAdd :: StageRoute Env ~ Route App @@ -478,6 +491,15 @@ parseAdd sender (AP.Add object target role _context) = do GroupChildrenR g -> ATGroupChildren <$> WAP.decodeKeyHashidE g "Inavlid team children hashid" + RepoProjectsR r -> + ATRepoProjects <$> + WAP.decodeKeyHashidE r "Inavlid repo projects hashid" + DeckProjectsR d -> + ATDeckProjects <$> + WAP.decodeKeyHashidE d "Inavlid deck projects hashid" + LoomProjectsR l -> + ATLoomProjects <$> + WAP.decodeKeyHashidE l "Inavlid loom projects hashid" _ -> throwE "Not an Add target collection route" ) pure diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index fcb3ef7..d2de4da 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -930,6 +930,7 @@ instance YesodBreadcrumbs App where RepoStampR r k -> ("Stamp #" <> keyHashidText k, Just $ RepoR r) RepoCollabsR r -> ("Collaborators", Just $ RepoR r) + RepoProjectsR r -> ("Projects", Just $ RepoR r) DeckR d -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR) DeckInboxR d -> ("Inbox", Just $ DeckR d) @@ -993,6 +994,7 @@ instance YesodBreadcrumbs App where LoomStampR l k -> ("Stamp #" <> keyHashidText k, Just $ LoomR l) LoomCollabsR l -> ("Collaborators", Just $ LoomR l) + LoomProjectsR l -> ("Projects", Just $ LoomR l) ClothR l c -> ("#" <> keyHashidText c, Just $ LoomClothsR l) ClothDiscussionR l c -> ("Discussion", Just $ ClothR l c) diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index fff2952..602b200 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -594,87 +594,10 @@ getDeckProjectsR deckHash = do (deck, actor, stems, drafts) <- runDB $ do deck <- get404 deckID actor <- getJust $ deckActor deck - stems <- - E.select $ E.from $ \ (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.where_ $ stem E.^. StemHolder E.==. E.val (deckKomponent deck) - return - ( stem - , grant E.^. OutboxItemPublished - ) - stems' <- for stems $ \ (Entity stemID stem, E.Value time) -> do - j <- getStemProject stemID - projectView <- - bitraverse - (\ projectID -> do - actorID <- projectActor <$> getJust projectID - actor <- getJust actorID - return (projectID, actor) - ) - getRemoteActorData - j - return (projectView, stemRole stem, time, stemID) - drafts <- - E.select $ E.from $ \ (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.where_ $ - stem E.^. StemHolder E.==. E.val (deckKomponent deck) 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') + stems <- getStems $ deckKomponent deck + drafts <- getStemDrafts $ deckKomponent deck + 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 diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index bed6eb9..231d2df 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -33,6 +33,7 @@ module Vervis.Handler.Loom , getLoomStampR , getLoomCollabsR + , getLoomProjectsR ) where @@ -54,6 +55,7 @@ import Yesod.Core import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Form.Functions (runFormPost, runFormGet) import Yesod.Form.Types (FormResult (..)) +import Yesod.Form import Yesod.Persist.Core (runDB, get404, getBy404) import qualified Data.ByteString.Lazy as BL @@ -88,11 +90,13 @@ import Vervis.Form.Tracker import Vervis.Foundation import Vervis.Model import Vervis.Paginate +import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Recipient import Vervis.Settings import Vervis.Ticket import Vervis.TicketFilter +import Vervis.Time import Vervis.Web.Actor import Vervis.Widget.Person import Vervis.Widget.Ticket @@ -138,6 +142,8 @@ getLoomR loomHash = do } , AP.patchTrackerCollaborators = encodeRouteLocal $ LoomCollabsR loomHash + , AP.patchTrackerProjects = + encodeRouteLocal $ LoomProjectsR loomHash } provideHtmlAndAP loomAP $ redirect $ LoomClothsR loomHash @@ -358,3 +364,23 @@ getLoomStampR = servePerActorKey loomActor LocalActorLoom getLoomCollabsR :: KeyHashid Loom -> Handler TypedContent getLoomCollabsR loomHash = error "TODO getLoomCollabsR" + +getLoomProjectsR :: KeyHashid Loom -> Handler Html +getLoomProjectsR loomHash = do + loomID <- decodeKeyHashid404 loomHash + mp <- maybeAuthId + haveAdmin <- fmap isJust $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + loom <- lift $ get404 loomID + MaybeT $ getCapability personID (Left $ loomResource loom) AP.RoleAdmin + ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm + (loom, actor, stems, drafts) <- runDB $ do + loom <- get404 loomID + actor <- getJust $ loomActor loom + stems <- getStems $ loomKomponent loom + drafts <- getStemDrafts $ loomKomponent loom + return (loom, actor, stems, drafts) + defaultLayout $(widgetFile "loom/projects") + +addProjectForm = renderDivs $ + areq fedUriField "(URI) Project" Nothing diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index f2f4642..92c94e5 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -50,6 +50,7 @@ module Vervis.Handler.Repo , getRepoStampR , getRepoCollabsR + , getRepoProjectsR @@ -124,6 +125,7 @@ import Yesod.Core.Content import Yesod.Core.Handler import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) +import Yesod.Form import Yesod.Persist.Core import qualified Data.ByteString as B @@ -168,6 +170,7 @@ import Vervis.API import Vervis.Federation.Auth import Vervis.Federation.Offer import Vervis.FedURI +import Vervis.Field.Person import Vervis.Form.Repo import Vervis.Foundation import Vervis.Path @@ -175,15 +178,18 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Paginate import Vervis.Persist.Actor +import Vervis.Persist.Collab import Vervis.Readme import Vervis.Recipient import Vervis.Settings import Vervis.SourceTree import Vervis.Style +import Vervis.Time import Vervis.Web.Actor import Vervis.Web.Darcs import Vervis.Web.Delivery import Vervis.Web.Git +import Vervis.Widget.Tracker import qualified Vervis.Client as C import qualified Vervis.Formatting as F @@ -233,6 +239,7 @@ getRepoR repoHash = do encodeRouteLocal . LoomR . hashLoom <$> repoLoom repo , AP.repoClone = encodeRouteLocal (RepoR repoHash) :| [] , AP.repoCollaborators = encodeRouteLocal $ RepoCollabsR repoHash + , AP.repoProjects = encodeRouteLocal $ RepoProjectsR repoHash } next = @@ -781,6 +788,27 @@ getRepoStampR = servePerActorKey repoActor LocalActorRepo getRepoCollabsR :: KeyHashid Repo -> Handler TypedContent getRepoCollabsR repoHash = error "TODO getRepoCollabsR" +addProjectForm = renderDivs $ + areq fedUriField "(URI) Project" Nothing + +getRepoProjectsR :: KeyHashid Repo -> Handler Html +getRepoProjectsR repoHash = do + repoID <- decodeKeyHashid404 repoHash + mp <- maybeAuthId + haveAdmin <- fmap isJust $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + repo <- lift $ get404 repoID + MaybeT $ getCapability personID (Left $ repoResource repo) AP.RoleAdmin + ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm + (repo, actor, stems, drafts) <- runDB $ do + repo <- get404 repoID + actor <- getJust $ repoActor repo + stems <- getStems $ repoKomponent repo + drafts <- getStemDrafts $ repoKomponent repo + return (repo, actor, stems, drafts) + hashLoom <- getEncodeKeyHashid + defaultLayout $(widgetFile "repo/projects") + diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 3a306ff..4548442 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -47,6 +47,7 @@ module Vervis.Persist.Actor , insertToInbox , adaptErrbox , getActivityIdent + , getRemoteActorData ) where @@ -450,3 +451,9 @@ getActivityIdent = act <- getJust actID getRemoteActivityURI act ) + +getRemoteActorData actorID = do + actor <- getJust actorID + object <- getJust $ remoteActorIdent actor + inztance <- getJust $ remoteObjectInstance object + return (inztance, object, actor) diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index d03d329..4fb4699 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -57,10 +57,14 @@ module Vervis.Persist.Collab , getPermitsForResource , getCapability + + , getStems + , getStemDrafts ) where import Control.Applicative +import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -1269,3 +1273,80 @@ getCapability personID actor role = do u <- getRemoteActivityURI grant return $ Right u return $ maybeDirect' <|> maybeExt' + +getStems komponentID = do + stems <- + E.select $ E.from $ \ (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.where_ $ stem E.^. StemHolder E.==. E.val komponentID + return + ( stem + , grant E.^. OutboxItemPublished + ) + for stems $ \ (Entity stemID stem, E.Value time) -> do + j <- getStemProject stemID + projectView <- + bitraverse + (\ projectID -> do + actorID <- projectActor <$> getJust projectID + actor <- getJust actorID + return (projectID, actor) + ) + getRemoteActorData + j + return (projectView, stemRole stem, time, stemID) + +getStemDrafts komponentID = do + drafts <- + E.select $ E.from $ \ (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.where_ $ + stem E.^. StemHolder E.==. E.val komponentID E.&&. + E.isNothing (deleg E.?. StemDelegateLocalId) + return stem + 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) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index eba86ad..d5df4c3 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -651,6 +651,7 @@ data Repo u = Repo , repoLoom :: Maybe LocalURI , repoClone :: NonEmpty LocalURI , repoCollaborators :: LocalURI + , repoProjects :: LocalURI } instance ActivityPub Repo where @@ -666,13 +667,15 @@ instance ActivityPub Repo where <*> withAuthorityMaybeO h (o .:? "sendPatchesTo") <*> (traverse (withAuthorityO h . pure) =<< o .:*+ "cloneUri") <*> withAuthorityO h (o .: "collaborators") - toSeries h (Repo actor team vcs loom clone collabs) + <*> withAuthorityO h (o .: "context") + toSeries h (Repo actor team vcs loom clone collabs projects) = toSeries h actor <> "team" .= (ObjURI h <$> team) <> "versionControlSystem" .= vcs <> "sendPatchesTo" .=? (ObjURI h <$> loom) <> "cloneUri" .=*+ (ObjURI h <$> clone) <> "collaborators" .= ObjURI h collabs + <> "context" .= ObjURI h projects data TicketTracker u = TicketTracker { ticketTrackerActor :: Actor u @@ -701,6 +704,7 @@ instance ActivityPub TicketTracker where data PatchTracker u = PatchTracker { patchTrackerActor :: Actor u , patchTrackerCollaborators :: LocalURI + , patchTrackerProjects :: LocalURI } instance ActivityPub PatchTracker where @@ -712,9 +716,11 @@ instance ActivityPub PatchTracker where fmap (h,) $ PatchTracker a <$> withAuthorityO h (o .: "collaborators") - toSeries h (PatchTracker actor collabs) + <*> withAuthorityO h (o .: "context") + toSeries h (PatchTracker actor collabs projects) = toSeries h actor - <> "collaborators" .= ObjURI h collabs + <> "collaborators" .= ObjURI h collabs + <> "context" .= ObjURI h projects data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered diff --git a/templates/loom/projects.hamlet b/templates/loom/projects.hamlet new file mode 100644 index 0000000..1b301ff --- /dev/null +++ b/templates/loom/projects.hamlet @@ -0,0 +1,70 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019, 2022, 2023, 2024 +$# by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +^{loomNavW (Entity loomID loom) actor} + +

Projects + + + + +
Role + Project + Since + $if haveAdmin + Remove + $forall (project, role, since, stemID) <- stems +
#{show role} + ^{projectLinkFedW project} + #{showDate since} +$# $if haveAdmin +$# ^{buttonW POST "Remove" (LoomRemoveProjectR loomHash stemID)} + +$#$if haveAdmin +$#

Add loom to a project: +$#

+$# ^{widgetAP} +$# + +

Invites + + + + +
Inviter + Via + Invited project + I accepted? + Role + Time + $if haveAdmin + Approve + $forall (inviter, us, project, accept, time, role, stemID) <- drafts +
^{actorLinkFedW inviter} + + $if us + Us + $else + Them + ^{projectLinkFedW project} + + $if accept + [x] + $else + [_] + #{show role} + #{showDate time} +$# $if haveAdmin && (not accept && not us) +$# ^{buttonW POST "Approve" (LoomApproveProjectR loomHash stemID)} diff --git a/templates/loom/widget/nav.hamlet b/templates/loom/widget/nav.hamlet index ba7e005..b957665 100644 --- a/templates/loom/widget/nav.hamlet +++ b/templates/loom/widget/nav.hamlet @@ -33,6 +33,9 @@ $# . [🤝 Collaborators] + + + [🏗 Projects] [🥂 Merge Requests] diff --git a/templates/repo/projects.hamlet b/templates/repo/projects.hamlet new file mode 100644 index 0000000..b4e85e7 --- /dev/null +++ b/templates/repo/projects.hamlet @@ -0,0 +1,100 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019, 2022, 2023, 2024 +$# by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +
+ + [[ 🗃 + + ^#{keyHashidText repoHash} #{actorName actor} + ]] :: + + + [📥 Inbox] + + + [📤 Outbox] + + + [💥 Errbox] + + + [🐤 Followers] + + + [🤝 Collaborators] + + + [🏗 Projects] + + + [🛠 Commits] + $maybe loomID <- repoLoom repo + + + [🧩 Merge Requests] + +

Projects + + + + +
Role + Project + Since + $if haveAdmin + Remove + $forall (project, role, since, stemID) <- stems +
#{show role} + ^{projectLinkFedW project} + #{showDate since} +$# $if haveAdmin +$# ^{buttonW POST "Remove" (RepoRemoveProjectR repoHash stemID)} + +$#$if haveAdmin +$#

Add repo to a project: +$# +$# ^{widgetAP} +$# + +

Invites + + + + +
Inviter + Via + Invited project + I accepted? + Role + Time + $if haveAdmin + Approve + $forall (inviter, us, project, accept, time, role, stemID) <- drafts +
^{actorLinkFedW inviter} + + $if us + Us + $else + Them + ^{projectLinkFedW project} + + $if accept + [x] + $else + [_] + #{show role} + #{showDate time} +$# $if haveAdmin && (not accept && not us) +$# ^{buttonW POST "Approve" (RepoApproveProjectR repoHash stemID)} diff --git a/templates/repo/source-darcs.hamlet b/templates/repo/source-darcs.hamlet index 6ade20e..3cfbafe 100644 --- a/templates/repo/source-darcs.hamlet +++ b/templates/repo/source-darcs.hamlet @@ -51,6 +51,9 @@ $# ^{personNavW user} [🤝 Collaborators] + + + [🏗 Projects] [🛠 Changes] diff --git a/templates/repo/source-git.hamlet b/templates/repo/source-git.hamlet index 7c0318f..37fc70e 100644 --- a/templates/repo/source-git.hamlet +++ b/templates/repo/source-git.hamlet @@ -51,6 +51,9 @@ $# ^{personNavW user} [🤝 Collaborators] + + + [🏗 Projects] [🛠 Commits] diff --git a/th/routes b/th/routes index 0a86b2c..afbecf9 100644 --- a/th/routes +++ b/th/routes @@ -221,6 +221,7 @@ /repos/#RepoKeyHashid/stamps/#SigKeyKeyHashid RepoStampR GET /repos/#RepoKeyHashid/collabs RepoCollabsR GET +/repos/#RepoKeyHashid/projects RepoProjectsR GET ---- Deck -------------------------------------------------------------------- @@ -305,6 +306,7 @@ /looms/#LoomKeyHashid/stamps/#SigKeyKeyHashid LoomStampR GET /looms/#LoomKeyHashid/collabs LoomCollabsR GET +/looms/#LoomKeyHashid/projects LoomProjectsR GET ---- Cloth -------------------------------------------------------------------