From 581838e5503da740b2944d61d06f794bdf862c51 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 17 Jun 2023 21:35:00 +0300 Subject: [PATCH] Support the 6 ForgeFed roles + launch repo/deck/loom actor upon creation --- src/Vervis/API.hs | 62 ++++++++++++++++-------- src/Vervis/Access.hs | 31 +++--------- src/Vervis/Actor/Common.hs | 37 ++++++++------ src/Vervis/Actor/Deck.hs | 1 + src/Vervis/Actor/Person.hs | 6 +-- src/Vervis/Actor/Person/Client.hs | 2 +- src/Vervis/Client.hs | 7 +-- src/Vervis/Data/Collab.hs | 35 +++++++------- src/Vervis/Federation/Ticket.hs | 1 - src/Vervis/Fetch.hs | 1 - src/Vervis/Handler/Client.hs | 42 +++++++++------- src/Vervis/Handler/Deck.hs | 15 +++--- src/Vervis/Migration.hs | 16 ++++++ src/Vervis/Model.hs | 9 +--- src/Vervis/Model/Role.hs | 7 ++- src/Vervis/Persist/Collab.hs | 57 ++++++++++++++-------- src/Vervis/Persist/Ticket.hs | 4 +- src/Vervis/Query.hs | 78 ------------------------------ src/Vervis/Role.hs | 59 ---------------------- src/Web/ActivityPub.hs | 46 +++++++++++------- templates/deck/collab/list.hamlet | 12 ++--- templates/personal-overview.hamlet | 15 ++++-- th/models | 44 +---------------- vervis.cabal | 2 - 24 files changed, 239 insertions(+), 350 deletions(-) delete mode 100644 src/Vervis/Query.hs delete mode 100644 src/Vervis/Role.hs diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 14636a8..bb443a3 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -99,6 +99,9 @@ import qualified Darcs.Local.Repository as D (createRepo) import Vervis.ActivityPub import Vervis.Actor hiding (hashLocalActor) +import Vervis.Actor.Deck +import Vervis.Actor.Loom +import Vervis.Actor.Repo import Vervis.Cloth import Vervis.Darcs import Vervis.Data.Actor @@ -124,7 +127,6 @@ import Vervis.Persist.Ticket import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings -import Vervis.Query import Vervis.Ticket import Vervis.Web.Delivery import Vervis.Web.Repo @@ -392,7 +394,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re , actionAudience = Audience recips [] [] [] [] [] , actionFulfills = [AP.acceptObject accept] , actionSpecific = GrantActivity Grant - { grantObject = Left RoleAdmin + { grantObject = RoleAdmin , grantContext = encodeRouteLocal $ renderLocalActor topicHash , grantTarget = encodeRouteHome $ PersonR recipHash , grantResult = Nothing @@ -1010,7 +1012,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips now <- liftIO getCurrentTime verifyNothingE muTarget "'target' not supported in Create PatchTracker" - (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do + (loomID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do -- Find the specified repo in DB _ <- getE repoID "No such repo in DB" @@ -1097,13 +1099,21 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA -- Return instructions for HTTP delivery to remote recipients - return (obiidCreate, deliverHttpCreate, deliverHttpGrant) + return (loomID, obiidCreate, deliverHttpCreate, deliverHttpGrant) -- Launch asynchronous HTTP delivery of Create and Grant lift $ do forkWorker "createPatchTrackerC: async HTTP Create delivery" deliverHttpCreate forkWorker "createPatchTrackerC: async HTTP Grant delivery" deliverHttpGrant + -- Spawn new Loom actor + success <- do + theater <- asksSite appTheater + env <- asksSite appEnv + liftIO $ launchActorIO theater env LocalActorLoom loomID + unless success $ + error "Failed to spawn new Loom, somehow ID already in Theater" + return obiid where @@ -1162,7 +1172,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips return action { actionSpecific = specific } insertCollab loomID obiidGrant = do - cid <- insert Collab + cid <- insert $ Collab RoleAdmin insert_ $ CollabTopicLoom cid loomID insert_ $ CollabEnable cid obiidGrant insert_ $ CollabRecipLocal cid pidUser @@ -1183,7 +1193,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips , actionFulfills = [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant - { grantObject = Left RoleAdmin + { grantObject = RoleAdmin , grantContext = encodeRouteLocal $ LoomR loomHash , grantTarget = encodeRouteHome $ PersonR adminHash , grantResult = Nothing @@ -1269,7 +1279,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r now <- liftIO getCurrentTime verifyNothingE muTarget "'target' not supported in Create Repository" - (obiid, newRepoHash, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do + (repoID, obiid, newRepoHash, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do -- Insert new repo to DB obiidCreate <- @@ -1331,7 +1341,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA -- Return instructions for HTTP delivery to remote recipients - return (obiidCreate, repoHash, deliverHttpCreate, deliverHttpGrant) + return (repoID, obiidCreate, repoHash, deliverHttpCreate, deliverHttpGrant) -- Insert new repo to filesystem lift $ createRepo newRepoHash @@ -1341,6 +1351,14 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r forkWorker "createRepositoryC: async HTTP Create delivery" deliverHttpCreate forkWorker "createRepositoryC: async HTTP Grant delivery" deliverHttpGrant + -- Spawn new Repo actor + success <- do + theater <- asksSite appTheater + env <- asksSite appEnv + liftIO $ launchActorIO theater env LocalActorRepo repoID + unless success $ + error "Failed to spawn new Repo, somehow ID already in Theater" + return obiid where @@ -1359,8 +1377,6 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r { repoVcs = vcs , repoProject = Nothing , repoMainBranch = "main" - , repoCollabUser = Nothing - , repoCollabAnon = Nothing , repoActor = actorID , repoCreate = createID , repoLoom = Nothing @@ -1392,7 +1408,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r return action { actionSpecific = specific } insertCollab repoID grantID = do - collabID <- insert Collab + collabID <- insert $ Collab RoleAdmin insert_ $ CollabTopicRepo collabID repoID insert_ $ CollabEnable collabID grantID insert_ $ CollabRecipLocal collabID pidUser @@ -1413,7 +1429,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r , actionFulfills = [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant - { grantObject = Left RoleAdmin + { grantObject = RoleAdmin , grantContext = encodeRouteLocal $ RepoR repoHash , grantTarget = encodeRouteHome $ PersonR adminHash , grantResult = Nothing @@ -1520,7 +1536,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip now <- liftIO getCurrentTime verifyNothingE muTarget "'target' not supported in Create TicketTracker" - (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do + (deckID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do -- Insert new deck to DB obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now @@ -1580,13 +1596,21 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA -- Return instructions for HTTP delivery to remote recipients - return (obiidCreate, deliverHttpCreate, deliverHttpGrant) + return (jid, obiidCreate, deliverHttpCreate, deliverHttpGrant) -- Launch asynchronous HTTP delivery of Create and Grant lift $ do forkWorker "createTicketTrackerC: async HTTP Create delivery" deliverHttpCreate forkWorker "createTicketTrackerC: async HTTP Grant delivery" deliverHttpGrant + -- Spawn new Deck actor + success <- do + theater <- asksSite appTheater + env <- asksSite appEnv + liftIO $ launchActorIO theater env LocalActorDeck deckID + unless success $ + error "Failed to spawn new Deck, somehow ID already in Theater" + return obiid where parseTracker (AP.ActorDetail typ muser mname msummary) = do @@ -1617,8 +1641,6 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip , deckWorkflow = wid , deckNextTicket = 1 , deckWiki = Nothing - , deckCollabAnon = Nothing - , deckCollabUser = Nothing , deckCreate = obiidCreate } return (did, obid, ibid, aid, fsid) @@ -1648,7 +1670,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip return action { actionSpecific = specific } insertCollab did obiidGrant = do - cid <- insert Collab + cid <- insert $ Collab RoleAdmin insert_ $ CollabTopicDeck cid did insert_ $ CollabEnable cid obiidGrant insert_ $ CollabRecipLocal cid pidUser @@ -1669,7 +1691,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip , actionFulfills = [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant - { grantObject = Left RoleAdmin + { grantObject = RoleAdmin , grantContext = encodeRouteLocal $ DeckR deckHash , grantTarget = encodeRouteHome $ PersonR adminHash , grantResult = Nothing @@ -2604,7 +2626,7 @@ resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips r case capID of Left (capActor, _, capItem) -> return (capActor, capItem) Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker" - verifyCapability capability (Left senderPersonID) resource + verifyCapability capability (Left senderPersonID) resource RoleTriage return (wi, actor, ticketID) @@ -2819,7 +2841,7 @@ undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remo case capID of Left (capActor, _, capItem) -> return (capActor, capItem) Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker" - verifyCapability capability (Left senderPersonID) resource + verifyCapability capability (Left senderPersonID) resource RoleTriage lift updateDB actorID <- do maybeActor <- lift $ getLocalActorEntity actorByKey diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index 111b731..ed6751f 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -97,14 +97,13 @@ import Vervis.Foundation import Vervis.Model import Vervis.Model.Role import Vervis.Persist.Actor -import Vervis.Query import Vervis.Recipient data ObjectAccessStatus = NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed deriving Eq -data PersonRole = Developer | User | Guest | RoleID RoleId +data PersonRole = Developer | User | Guest {- data RepoAuthorization @@ -138,12 +137,6 @@ roleHasAccess User op = pure $ userAccess op userAccess ProjOpPush = False userAccess ProjOpApplyPatch = False roleHasAccess Guest _ = pure False -roleHasAccess (RoleID rlid) op = - fmap isJust . runMaybeT $ - MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op) - where - roleHas role operation = getBy $ UniqueRoleAccess role operation - ancestorHas = flip getProjectRoleAncestorWithOpQ status :: Bool -> ObjectAccessStatus status True = ObjectAccessAllowed @@ -164,9 +157,8 @@ checkRepoAccess' mpid op repoID = do Just (Entity rid repo) -> do role <- do case mpid of - Just pid -> - fromMaybe User . (<|> asUser repo) <$> asCollab rid pid - Nothing -> pure $ fromMaybe Guest $ asAnon repo + Just pid -> fromMaybe User <$> asCollab rid pid + Nothing -> pure Guest status <$> roleHasAccess role op where asCollab rid pid = do @@ -179,8 +171,6 @@ checkRepoAccess' mpid op repoID = do recip E.^. CollabRecipLocalPerson E.==. E.val pid E.limit 1 return $ topic E.^. CollabTopicRepoCollab - asUser = fmap RoleID . repoCollabUser - asAnon = fmap RoleID . repoCollabAnon checkRepoAccess :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m)) @@ -198,9 +188,8 @@ checkRepoAccess mpid op repoHash = do Just (Entity rid repo) -> do role <- do case mpid of - Just pid -> - fromMaybe User . (<|> asUser repo) <$> asCollab rid pid - Nothing -> pure $ fromMaybe Guest $ asAnon repo + Just pid -> fromMaybe User <$> asCollab rid pid + Nothing -> pure Guest status <$> roleHasAccess role op where asCollab rid pid = do @@ -213,8 +202,6 @@ checkRepoAccess mpid op repoHash = do recip E.^. CollabRecipLocalPerson E.==. E.val pid E.limit 1 return $ topic E.^. CollabTopicRepoCollab - asUser = fmap RoleID . repoCollabUser - asAnon = fmap RoleID . repoCollabAnon checkProjectAccess :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m)) @@ -232,10 +219,8 @@ checkProjectAccess mpid op deckHash = do Just (Entity jid project) -> do role <- do case mpid of - Just pid -> - fromMaybe User . (<|> asUser project) <$> - asCollab jid pid - Nothing -> pure $ fromMaybe Guest $ asAnon project + Just pid -> fromMaybe User <$> asCollab jid pid + Nothing -> pure Guest status <$> roleHasAccess role op where asCollab jid pid = do @@ -248,5 +233,3 @@ checkProjectAccess mpid op deckHash = do recip E.^. CollabRecipLocalPerson E.==. E.val pid E.limit 1 return $ topic E.^. CollabTopicDeckCollab - asUser = fmap RoleID . deckCollabUser - asAnon = fmap RoleID . deckCollabAnon diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 2717302..ca41a42 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -280,6 +280,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce capability authorIdMsig (topicResource recipKey) + AP.RoleAdmin return fulfillsID -- Verify the Collab isn't already validated @@ -323,8 +324,9 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce -- Prepare a Grant activity and insert to my outbox let inviterOrJoiner = either snd snd collab isInvite = isLeft collab - grant@(actionGrant, _, _, _) <- - lift $ prepareGrant isInvite inviterOrJoiner + grant@(actionGrant, _, _, _) <- do + Collab role <- lift $ getJust collabID + lift $ prepareGrant isInvite inviterOrJoiner role let recipByKey = grantResourceLocalActor $ topicResource recipKey _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant return (grantID, grant) @@ -368,7 +370,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor return (fulfillsID, Right joiner) - prepareGrant isInvite sender = do + prepareGrant isInvite sender role = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal @@ -410,7 +412,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce , AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionFulfills = [AP.acceptObject accept] , AP.actionSpecific = AP.GrantActivity AP.Grant - { AP.grantObject = Left AP.RoleAdmin + { AP.grantObject = role , AP.grantContext = encodeRouteLocal $ renderLocalActor topicByHash , AP.grantTarget = @@ -518,6 +520,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje capability authorIdMsig (topicResource recipKey) + AP.RoleAdmin return (fulfillsID, deleteRecipJoin, deleteRecip) -- Verify the Collab isn't already validated @@ -699,12 +702,12 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor _ -> throwE "Capability is remote i.e. definitely not by me" -- Check invite - targetByKey <- do + (role, targetByKey) <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (resource, recipient) <- parseInvite author invite + (role, resource, recipient) <- parseInvite author invite unless (Left (topicResource topicKey) == resource) $ throwE "Invite topic isn't me" - return recipient + return (role, recipient) -- If target is local, find it in our DB -- If target is remote, HTTP GET it, verify it's an actor, and store in @@ -741,7 +744,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor (actorID,) <$> getJust actorID -- Verify the specified capability gives relevant access - verifyCapability' capability authorIdMsig (topicResource topicKey) + verifyCapability' + capability authorIdMsig (topicResource topicKey) AP.RoleAdmin -- Verify that target doesn't already have a Collab for me existingCollabIDs <- @@ -773,7 +777,7 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor lift $ for maybeInviteDB $ \ inviteDB -> do -- Insert Collab record to DB - insertCollab targetDB inviteDB + insertCollab role targetDB inviteDB -- Prepare forwarding Invite to my followers sieve <- do @@ -792,8 +796,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor where - insertCollab recipient inviteDB = do - collabID <- insert Collab + insertCollab role recipient inviteDB = do + collabID <- insert $ Collab role fulfillsID <- insert $ CollabFulfillsInvite collabID insert_ $ collabTopicCtor collabID topicKey case inviteDB of @@ -872,7 +876,8 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve (actorID,) <$> getJust actorID -- Verify the specified capability gives relevant access - verifyCapability' capability authorIdMsig (topicResource topicKey) + verifyCapability' + capability authorIdMsig (topicResource topicKey) AP.RoleAdmin -- Find the collab that the member already has for me existingCollabIDs <- @@ -1048,7 +1053,7 @@ topicJoin topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) join = do -- Check input - resource <- parseJoin join + (role, resource) <- parseJoin join unless (resource == Left (topicResource topicKey)) $ throwE "Join's object isn't me, don't need this Join" @@ -1101,7 +1106,7 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no ) pure joinDB - lift $ insertCollab joinDB' + lift $ insertCollab role joinDB' -- Prepare forwarding Join to my followers sieve <- lift $ do @@ -1120,8 +1125,8 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no where - insertCollab joinDB = do - collabID <- insert Collab + insertCollab role joinDB = do + collabID <- insert $ Collab role fulfillsID <- insert $ CollabFulfillsJoin collabID insert_ $ collabTopicCtor collabID topicKey case joinDB of diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index fa91bc1..139cb90 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -360,6 +360,7 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do capability authorIdMsig (GrantResourceDeck recipDeckID) + AP.RoleTriage lift $ lift deleteFromDB diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 4459943..f47f856 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -440,7 +440,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do -- Check input recipient <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (_resource, target) <- parseInvite author invite + (_role, _resource, target) <- parseInvite author invite return target maybeNew <- withDBExcept $ do @@ -538,7 +538,7 @@ personJoin personJoin now recipPersonID (Verse authorIdMsig body) join = do -- Check input - _resource <- parseJoin join + (_role, _resource) <- parseJoin join maybeJoinID <- lift $ withDB $ do @@ -567,7 +567,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do -- Check input target <- do h <- lift $ objUriAuthority <$> getActorURI authorIdMsig - (resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant + (_role, resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant case (recip, authorIdMsig) of (Left (GrantRecipPerson p), Left (LocalActorPerson p', _, _)) | p == p' -> diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 3885029..7ee2bb0 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -130,7 +130,7 @@ clientInvite clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do -- Check input - (resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite + (_role, resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite _capID <- fromMaybeE maybeCap "No capability provided" -- If resource is remote, HTTP GET it and its managing actor, and insert to diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 206a745..c52f183 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -953,14 +953,15 @@ invite :: PersonId -> FedURI -> FedURI + -> AP.Role -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Invite URIMode) -invite personID uRecipient uResource = do +invite personID uRecipient uResource role = do theater <- asksSite appTheater env <- asksSite appEnv - let activity = AP.Invite (Left RoleAdmin) uRecipient uResource - (resource, recipient) <- + let activity = AP.Invite role uRecipient uResource + (_role, resource, recipient) <- runActE $ parseInvite (Left $ LocalActorPerson personID) activity -- If resource is remote, we need to get it from DB/HTTP to determine its diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 211848d..24cdddf 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -117,9 +117,7 @@ unhashGrantRecipEOld resource e = unhashGrantRecipE resource e = ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource -verifyRole (Left AP.RoleAdmin) = pure () -verifyRole (Right _) = - throwE "ForgeFed Admin is the only role allowed currently" +verifyRole = pure parseTopic :: StageRoute Env ~ Route App @@ -168,41 +166,45 @@ parseInvite => Either (LocalActorBy Key) FedURI -> AP.Invite URIMode -> ActE - ( Either (GrantResourceBy Key) FedURI + ( AP.Role + , Either (GrantResourceBy Key) FedURI , Either (GrantRecipBy Key) FedURI ) -parseInvite sender (AP.Invite instrument object target) = do - verifyRole instrument - (,) <$> nameExceptT "Invite target" (parseTopic target) +parseInvite sender (AP.Invite instrument object target) = + (,,) + <$> verifyRole instrument + <*> nameExceptT "Invite target" (parseTopic target) <*> nameExceptT "Invite object" (parseRecipient sender object) parseJoin :: StageRoute Env ~ Route App - => AP.Join URIMode -> ActE (Either (GrantResourceBy Key) FedURI) -parseJoin (AP.Join instrument object) = do - verifyRole instrument - nameExceptT "Join object" (parseTopic object) + => AP.Join URIMode + -> ActE (AP.Role, Either (GrantResourceBy Key) FedURI) +parseJoin (AP.Join instrument object) = + (,) <$> verifyRole instrument + <*> nameExceptT "Join object" (parseTopic object) parseGrant :: Host -> AP.Grant URIMode -> ActE - ( Either (GrantResourceBy Key) LocalURI + ( AP.Role + , Either (GrantResourceBy Key) LocalURI , Either (GrantRecipBy Key) FedURI , Maybe (LocalURI, Maybe Int) , Maybe UTCTime , Maybe UTCTime ) parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) = do - verifyRole object case allows of AP.Invoke -> pure () _ -> throwE "Grant.allows isn't invoke" case deleg of Nothing -> pure () Just _ -> throwE "Grant.delegates is specified" - (,,,,) - <$> parseContext context + (,,,,,) + <$> verifyRole object + <*> parseContext context <*> parseTarget target <*> pure (fmap @@ -212,9 +214,6 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) = <*> pure mstart <*> pure mend where - verifyRole (Left AP.RoleAdmin) = pure () - verifyRole (Right _) = - throwE "ForgeFed Admin is the only role allowed currently" parseContext lu = do hl <- hostIsLocal h if hl diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 7a759e2..68de873 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -114,7 +114,6 @@ import Vervis.Model.Ticket import Vervis.Path import Vervis.Persist.Actor import Vervis.Persist.Ticket -import Vervis.Query import Vervis.Recipient import Vervis.Ticket import Vervis.Web.Repo diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs index e7553f4..db555cd 100644 --- a/src/Vervis/Fetch.hs +++ b/src/Vervis/Fetch.hs @@ -100,7 +100,6 @@ import Vervis.Persist.Collab import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings -import Vervis.Query import Vervis.Ticket data Result diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index edcdbcf..b6b5ead 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -123,32 +123,35 @@ getHomeR = do personalOverview :: Entity Person -> Handler Html personalOverview (Entity pid _person) = do (repos, decks, looms) <- runDB $ (,,) - <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do + <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId - E.on $ collab E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId - E.on $ collab E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicRepoCollab + E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId + E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab + E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicRepoCollab + E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid E.orderBy [E.asc $ repo E.^. RepoId] - return (repo, actor) + return (repo, actor, collab) ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do + <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId - E.on $ collab E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId - E.on $ collab E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicDeckCollab + E.on $ topic E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId + E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab + E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab + E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid E.orderBy [E.asc $ deck E.^. DeckId] - return (deck, actor) + return (deck, actor, collab) ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do + <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId - E.on $ collab E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId - E.on $ collab E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicLoomCollab + E.on $ topic E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId + E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab + E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLoomCollab + E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid E.orderBy [E.asc $ loom E.^. LoomId] - return (loom, actor) + return (loom, actor, collab) ) hashRepo <- getEncodeKeyHashid hashDeck <- getEncodeKeyHashid @@ -1163,10 +1166,13 @@ postPublishMergeR = do setMessage "Apply activity sent" redirect HomeR -inviteForm = renderDivs $ (,,) +inviteForm = renderDivs $ (,,,) <$> areq fedUriField "(URI) Whom to invite" Nothing <*> areq fedUriField "(URI) Resource" Nothing + <*> areq roleField "Role" Nothing <*> areq capField "(URI) Grant activity to use for authorization" Nothing + where + roleField = selectField optionsEnum :: Field Handler AP.Role getPublishInviteR :: Handler Html getPublishInviteR = do @@ -1184,14 +1190,14 @@ postPublishInviteR = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod - (uRecipient, uResource, (uCap, cap)) <- + (uRecipient, uResource, role, (uCap, cap)) <- runFormPostRedirect PublishInviteR inviteForm (ep@(Entity pid _), a) <- getSender senderHash <- encodeKeyHashid pid result <- runExceptT $ do - (maybeSummary, audience, inv) <- invite pid uRecipient uResource + (maybeSummary, audience, inv) <- invite pid uRecipient uResource role (localRecips, remoteRecips, fwdHosts, action) <- makeServerInput (Just uCap) maybeSummary audience (AP.InviteActivity inv) handleViaActor pid (Just cap) localRecips remoteRecips fwdHosts action diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 69fbdce..e2f8e87 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -412,20 +412,21 @@ getDeckCollabsR deckHash = do collabs <- do grants <- getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID - for grants $ \ (actor, ct, time) -> - (,ct,time) <$> getPersonWidgetInfo actor + for grants $ \ (role, actor, ct, time) -> + (,role,ct,time) <$> getPersonWidgetInfo actor invites <- do invites' <- getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID - for invites' $ \ (inviter, recip, time) -> (,,) + for invites' $ \ (inviter, recip, time, role) -> (,,,) <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) <*> getPersonWidgetInfo recip <*> pure time + <*> pure role joins <- do joins' <- getTopicJoins CollabTopicDeckCollab CollabTopicDeckDeck deckID - for joins' $ \ (recip, time) -> - (,time) <$> getPersonWidgetInfo recip + for joins' $ \ (recip, time, role) -> + (,time,role) <$> getPersonWidgetInfo recip return (deck, actor, collabs, invites, joins) defaultLayout $(widgetFile "deck/collab/list") where @@ -444,7 +445,7 @@ getDeckInviteR deckHash = do postDeckInviteR :: KeyHashid Deck -> Handler Html postDeckInviteR deckHash = do deckID <- decodeKeyHashid404 deckHash - DeckInvite recipPersonID AP.RoleAdmin <- + DeckInvite recipPersonID role <- runFormPostRedirect (DeckInviteR deckHash) $ deckInviteForm deckID personEntity@(Entity personID person) <- requireAuth @@ -456,7 +457,7 @@ postDeckInviteR deckHash = do (maybeSummary, audience, invite) <- do let uRecipient = encodeRouteHome $ PersonR recipPersonHash uResource = encodeRouteHome $ DeckR deckHash - C.invite personID uRecipient uResource + C.invite personID uRecipient uResource role grantID <- do maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID fromMaybeE maybeItem "You need to be a collaborator in the Deck to invite people" diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index e54b266..8b9000c 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -2938,6 +2938,22 @@ changes hLocal ctx = , addEntities model_530_join -- 531 , addEntities model_531_follow_request + -- 532 + , removeEntity "RoleInherit" + -- 533 + , removeEntity "RoleAccess" + -- 534 + , removeField "Deck" "collabUser" + -- 535 + , removeField "Deck" "collabAnon" + -- 536 + , removeField "Repo" "collabUser" + -- 537 + , removeField "Repo" "collabAnon" + -- 538 + , removeEntity "Role" + -- 539 + , addFieldPrimRequired "Collab" ("RoleAdmin" :: String) "role" ] migrateDB diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 4b30af8..f3156d7 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2022 + - Written in 2016, 2018, 2019, 2020, 2022, 2023 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -39,7 +39,7 @@ import Database.Persist.JSON import Development.PatchMediaType import Development.PatchMediaType.Persist import Network.FedURI -import Web.ActivityPub (Doc, Activity) +import Web.ActivityPub (Doc, Activity, Role) import Web.Text (HTML, PandocMarkdown) import Vervis.FedURI @@ -80,11 +80,6 @@ instance Hashable MessageId where hashWithSalt salt = hashWithSalt salt . fromSqlKey hash = hash . fromSqlKey --- "Vervis.Role" uses a 'HashMap' where the key type is 'ProjectRoleId' -instance Hashable RoleId where - hashWithSalt salt = hashWithSalt salt . fromSqlKey - hash = hash . fromSqlKey - instance Hashable PersonId where hashWithSalt salt = hashWithSalt salt . fromSqlKey hash = hash . fromSqlKey diff --git a/src/Vervis/Model/Role.hs b/src/Vervis/Model/Role.hs index 72921ed..060d438 100644 --- a/src/Vervis/Model/Role.hs +++ b/src/Vervis/Model/Role.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2021 by fr33domlover . + - Written in 2016, 2018, 2019, 2021, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -20,6 +21,8 @@ where import Database.Persist.TH +import Web.ActivityPub (Role (..)) + data ProjectOperation = ProjOpOpenTicket | ProjOpAcceptTicket @@ -37,3 +40,5 @@ data ProjectOperation deriving (Eq, Show, Read, Enum, Bounded) derivePersistField "ProjectOperation" + +derivePersistField "Role" diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 2165882..457837d 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -36,14 +36,18 @@ import Control.Monad.Trans.Reader import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) +import Data.List (sortOn) import Data.Text (Text) import Data.Time.Clock import Database.Persist.Sql +import Optics.Core import qualified Database.Esqueleto as E import Network.FedURI +import qualified Web.ActivityPub as AP + import Control.Monad.Trans.Except.Local import Data.Either.Local import Database.Persist.Local @@ -97,25 +101,28 @@ getTopicGrants => EntityField topic CollabId -> EntityField topic (Key resource) -> Key resource - -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, Key topic, UTCTime)] + -> ReaderT SqlBackend m [(AP.Role, Either PersonId RemoteActorId, Key topic, UTCTime)] getTopicGrants topicCollabField topicActorField resourceID = - fmap (map adapt) $ - E.select $ E.from $ \ (topic `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do + fmap (reverse . sortOn (view _1) . map adapt) $ + E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipR E.?. CollabRecipRemoteCollab E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipL E.?. CollabRecipLocalCollab E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId E.on $ topic E.^. topicCollabField E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId E.where_ $ topic E.^. topicActorField E.==. E.val resourceID - E.orderBy [E.asc $ enable E.^. CollabEnableId] + E.orderBy [E.desc $ enable E.^. CollabEnableId] return - ( recipL E.?. CollabRecipLocalPerson + ( collab E.^. CollabRole + , recipL E.?. CollabRecipLocalPerson , recipR E.?. CollabRecipRemoteActor , topic E.^. persistIdField , grant E.^. OutboxItemPublished ) where - adapt (E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value ctID, E.Value time) = - ( case (maybePersonID, maybeRemoteActorID) of + adapt (E.Value role, E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value ctID, E.Value time) = + ( role + , case (maybePersonID, maybeRemoteActorID) of (Nothing, Nothing) -> error "No recip" (Just personID, Nothing) -> Left personID (Nothing, Just remoteActorID) -> Right remoteActorID @@ -132,11 +139,11 @@ getTopicInvites => EntityField topic CollabId -> EntityField topic (Key resource) -> Key resource - -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime)] + -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime, AP.Role)] getTopicInvites topicCollabField topicActorField resourceID = fmap (map adapt) $ E.select $ E.from $ - \ (topic `E.LeftOuterJoin` enable `E.InnerJoin` fulfills + \ (topic `E.InnerJoin` collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR `E.LeftOuterJoin` (inviterL `E.InnerJoin` item `E.InnerJoin` actor) `E.LeftOuterJoin` (inviterR `E.InnerJoin` activity) @@ -150,6 +157,7 @@ getTopicInvites topicCollabField topicActorField resourceID = E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipL E.?. CollabRecipLocalCollab E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsInviteCollab E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab + E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId E.where_ $ topic E.^. topicActorField E.==. E.val resourceID E.&&. E.isNothing (enable E.?. CollabEnableId) @@ -161,9 +169,10 @@ getTopicInvites topicCollabField topicActorField resourceID = , activity E.?. RemoteActivityReceived , recipL E.?. CollabRecipLocalPerson , recipR E.?. CollabRecipRemoteActor + , collab E.^. CollabRole ) where - adapt (E.Value inviterL, E.Value timeL, E.Value inviterR, E.Value timeR, E.Value recipL, E.Value recipR) = + adapt (E.Value inviterL, E.Value timeL, E.Value inviterR, E.Value timeR, E.Value recipL, E.Value recipR, E.Value role) = let l = case (inviterL, timeL) of (Nothing, Nothing) -> Nothing (Just i, Just t) -> Just (i, t) @@ -187,6 +196,7 @@ getTopicInvites topicCollabField topicActorField resourceID = (Nothing, Just remoteActorID) -> Right remoteActorID (Just _, Just _) -> error "Multi recip" , time + , role ) getTopicJoins @@ -197,11 +207,11 @@ getTopicJoins => EntityField topic CollabId -> EntityField topic (Key resource) -> Key resource - -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime)] + -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime, AP.Role)] getTopicJoins topicCollabField topicActorField resourceID = fmap (map adapt) $ E.select $ E.from $ - \ (topic `E.LeftOuterJoin` enable `E.InnerJoin` fulfills + \ (topic `E.InnerJoin` collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.LeftOuterJoin` (joinL `E.InnerJoin` recipL `E.InnerJoin` item) `E.LeftOuterJoin` (joinR `E.InnerJoin` recipR `E.InnerJoin` activity) ) -> do @@ -213,6 +223,7 @@ getTopicJoins topicCollabField topicActorField resourceID = E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinL E.?. CollabRecipLocalJoinFulfills E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsJoinCollab E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab + E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId E.where_ $ topic E.^. topicActorField E.==. E.val resourceID E.&&. E.isNothing (enable E.?. CollabEnableId) @@ -222,9 +233,10 @@ getTopicJoins topicCollabField topicActorField resourceID = , item E.?. OutboxItemPublished , recipR E.?. CollabRecipRemoteActor , activity E.?. RemoteActivityReceived + , collab E.^. CollabRole ) where - adapt (E.Value recipL, E.Value timeL, E.Value recipR, E.Value timeR) = + adapt (E.Value recipL, E.Value timeL, E.Value recipR, E.Value timeR, E.Value role) = let l = case (recipL, timeL) of (Nothing, Nothing) -> Nothing (Just r, Just t) -> Just (r, t) @@ -235,8 +247,8 @@ getTopicJoins topicCollabField topicActorField resourceID = _ -> error "Impossible" in case (l, r) of (Nothing, Nothing) -> error "No recip" - (Just (personID, time), Nothing) -> (Left personID, time) - (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time) + (Just (personID, time), Nothing) -> (Left personID, time, role) + (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time, role) (Just _, Just _) -> error "Multi recip" verifyCapability @@ -244,8 +256,9 @@ verifyCapability => (LocalActorBy Key, OutboxItemId) -> Either PersonId RemoteActorId -> GrantResourceBy Key + -> AP.Role -> ExceptT Text (ReaderT SqlBackend m) () -verifyCapability (capActor, capItem) actor resource = do +verifyCapability (capActor, capItem) actor resource requiredRole = do -- Find the activity itself by URI in the DB nameExceptT "Capability activity not found" $ @@ -293,9 +306,10 @@ verifyCapability (capActor, capItem) actor resource = do unless (topic == resource) $ throwE "Capability topic is some other local resource" - -- Since there are currently no roles, and grants allow only the "Admin" - -- role that supports every operation, we don't need to check role access - return () + -- Verify that the granted role is equal or greater than the required role + Collab givenRole <- lift $ getJust collabID + unless (givenRole >= requiredRole) $ + throwE "The granted role doesn't allow the requested operation" verifyCapability' :: MonadIO m @@ -304,10 +318,11 @@ verifyCapability' (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString) -> GrantResourceBy Key + -> AP.Role -> ExceptT Text (ReaderT SqlBackend m) () -verifyCapability' cap actor resource = do +verifyCapability' cap actor resource role = do actorP <- processActor actor - verifyCapability cap actorP resource + verifyCapability cap actorP resource role where processActor = bitraverse processLocal processRemote where diff --git a/src/Vervis/Persist/Ticket.hs b/src/Vervis/Persist/Ticket.hs index 62d740b..d912faf 100644 --- a/src/Vervis/Persist/Ticket.hs +++ b/src/Vervis/Persist/Ticket.hs @@ -41,6 +41,8 @@ import qualified Data.List.NonEmpty as NE import Development.PatchMediaType import Yesod.Hashids +import qualified Web.ActivityPub as AP + import Control.Monad.Trans.Except.Local import Data.Either.Local import Database.Persist.Local @@ -177,7 +179,7 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do case capID of Left (capActor, _, capItem) -> return (capActor, capItem) Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom" - verifyCapability capability actor (GrantResourceLoom loomID) + verifyCapability capability actor (GrantResourceLoom loomID) AP.RoleWrite -- Get the patches from DB, verify VCS match just in case diffs <- do diff --git a/src/Vervis/Query.hs b/src/Vervis/Query.hs deleted file mode 100644 index 644dc87..0000000 --- a/src/Vervis/Query.hs +++ /dev/null @@ -1,78 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016, 2019 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 - - . - -} - --- | DB actions for long, complicated or unsafe queries. All the non-trivial --- usage of raw SQL and so on goes into this module. Hopefully, this module --- helps identify patterns and commonly needed but missing tools, which can --- then be implemented and simplify the queries. -module Vervis.Query - ( getProjectRoleAncestorWithOpQ - ) -where - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT, ask) -import Data.Maybe (listToMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sql.Util - -import qualified Data.Text as T (intercalate) - -import Database.Persist.Graph.Class -import Database.Persist.Graph.SQL -import Vervis.Model -import Vervis.Model.Role - --- | Given a project role and a project operation, find an ancestor role which --- has access to the operation. -getProjectRoleAncestorWithOpQ - :: MonadIO m - => ProjectOperation - -> RoleId - -> ReaderT SqlBackend m (Maybe (Entity RoleAccess)) -getProjectRoleAncestorWithOpQ op role = do - conn <- ask - let dbname = connEscapeName conn - eAcc = entityDef $ dummyFromField RoleAccessId - tAcc = dbname $ entityDB eAcc - qcols = - T.intercalate ", " $ - map ((tAcc <>) . ("." <>)) $ - entityColumnNames eAcc conn - field :: PersistEntity record => EntityField record typ -> Text - field = dbname . fieldDB . persistFieldDef - listToMaybe <$> - rawSqlWithGraph - Ancestors - role - RoleInheritParent - RoleInheritChild - (\ temp -> mconcat - [ "SELECT ??" - , " FROM ", dbname temp, " INNER JOIN ", tAcc - , " ON " - , dbname temp, ".", field RoleInheritParent - , " = " - , tAcc, ".", field RoleAccessRole - , " WHERE " - , tAcc, ".", field RoleAccessOp - , " = ?" - , " LIMIT 1" - ] - ) - [toPersistValue op] diff --git a/src/Vervis/Role.hs b/src/Vervis/Role.hs deleted file mode 100644 index 5c5445a..0000000 --- a/src/Vervis/Role.hs +++ /dev/null @@ -1,59 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016, 2019 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 - - . - -} - -module Vervis.Role - ( getProjectRoleGraph - ) -where - -import Control.Arrow (second, (&&&), (***)) -import Data.Graph.Inductive.Graph (mkGraph) -import Data.Graph.Inductive.PatriciaTree (Gr) -import Data.Tuple (swap) -import Database.Esqueleto -import Yesod.Persist.Core (runDB) - -import qualified Data.HashMap.Lazy as M (fromList, lookup) -import qualified Database.Persist as P - -import Vervis.Foundation -import Vervis.Model -import Vervis.Model.Ident - -getProjectRoleGraph :: SharerId -> AppDB (Gr RlIdent ()) -getProjectRoleGraph sid = do - (roles, inhs) <- do - prs <- P.selectList [RoleSharer P.==. sid] [] - prhs <- select $ from $ \ (pr `InnerJoin` prh) -> do - on $ pr ^. RoleId ==. prh ^. RoleInheritParent - where_ $ pr ^. RoleSharer ==. val sid - return prh - return (prs, prhs) - let numbered = zip [1..] roles - nodes = map (second $ roleIdent . entityVal) numbered - nodeMap = M.fromList $ map (swap . second entityKey) numbered - pridToNode prid = - case M.lookup prid nodeMap of - Nothing -> error "Role graph: Node not found in node map" - Just n -> n - edges = - map - ( (\ (c, p) -> (c, p, ())) - . (pridToNode *** pridToNode) - . (roleInheritChild &&& roleInheritParent) - . entityVal - ) - inhs - return $ mkGraph nodes edges diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 07be975..e07273a 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1518,19 +1518,31 @@ instance ActivityPub Branch where <> "ref" .= ref <> "context" .= ObjURI authority repo -data Role = RoleAdmin deriving (Show, Eq, Enum, Bounded) +data Role + = RoleVisit | RoleReport | RoleTriage | RoleWrite | RoleMaintain | RoleAdmin + deriving (Show, Read, Eq, Ord, Enum, Bounded) instance FromJSON Role where parseJSON = withText "Role" parse where - parse "https://forgefed.org/ns#admin" = pure RoleAdmin + parse "visit" = pure RoleVisit + parse "report" = pure RoleReport + parse "triage" = pure RoleTriage + parse "write" = pure RoleWrite + parse "maintain" = pure RoleMaintain + parse "admin" = pure RoleAdmin parse t = fail $ "Unknown role: " ++ T.unpack t instance ToJSON Role where toJSON = error "toJSON Role" toEncoding r = toEncoding $ case r of - RoleAdmin -> "https://forgefed.org/ns#admin" :: Text + RoleVisit -> "visit" :: Text + RoleReport -> "report" + RoleTriage -> "triage" + RoleWrite -> "write" + RoleMaintain -> "maintain" + RoleAdmin -> "admin" data Duration = Duration Int @@ -1726,7 +1738,7 @@ encodeFollow (Follow obj mcontext hide) <> "hide" .= hide data Grant u = Grant - { grantObject :: Either Role (ObjURI u) + { grantObject :: Role , grantContext :: LocalURI , grantTarget :: ObjURI u , grantResult :: Maybe (LocalURI, Maybe Duration) @@ -1739,7 +1751,7 @@ data Grant u = Grant parseGrant :: UriMode u => Authority u -> Object -> Parser (Grant u) parseGrant h o = Grant - <$> o .:+ "object" + <$> o .: "object" <*> withAuthorityO h (o .: "context") <*> o .: "target" <*> (do mres <- o .:+? "result" @@ -1755,7 +1767,7 @@ parseGrant h o = encodeGrant :: UriMode u => Authority u -> Grant u -> Series encodeGrant h (Grant obj context target mresult mstart mend allows mdelegates) - = "object" .=+ obj + = "object" .= obj <> "context" .= ObjURI h context <> "target" .= target <> (case mresult of @@ -1772,7 +1784,7 @@ encodeGrant h (Grant obj context target mresult mstart mend allows mdelegates) <> "delegates" .=? mdelegates data Invite u = Invite - { inviteInstrument :: Either Role (ObjURI u) + { inviteInstrument :: Role , inviteObject :: ObjURI u , inviteTarget :: ObjURI u } @@ -1780,31 +1792,31 @@ data Invite u = Invite parseInvite :: UriMode u => Object -> Parser (Invite u) parseInvite o = Invite - <$> o .:+ "instrument" + <$> o .: "instrument" <*> o .: "object" <*> o .: "target" encodeInvite :: UriMode u => Invite u -> Series -encodeInvite (Invite obj context target) - = "object" .=+ obj - <> "context" .= context - <> "target" .= target +encodeInvite (Invite ins obj target) + = "instrument" .= ins + <> "object" .= obj + <> "target" .= target data Join u = Join - { joinInstrument :: Either Role (ObjURI u) + { joinInstrument :: Role , joinObject :: ObjURI u } parseJoin :: UriMode u => Object -> Parser (Join u) parseJoin o = Join - <$> o .:+ "instrument" + <$> o .: "instrument" <*> o .: "object" encodeJoin :: UriMode u => Join u -> Series -encodeJoin (Join obj context) - = "object" .=+ obj - <> "context" .= context +encodeJoin (Join ins obj) + = "instrument" .= ins + <> "object" .= obj data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u) diff --git a/templates/deck/collab/list.hamlet b/templates/deck/collab/list.hamlet index 6c6ae0b..c0283c7 100644 --- a/templates/deck/collab/list.hamlet +++ b/templates/deck/collab/list.hamlet @@ -21,10 +21,10 @@ $# . Collaborator Role Since - $forall (person, ctID, since) <- collabs + $forall (person, role, ctID, since) <- collabs + #{show role} ^{personLinkFedW person} - Admin #{showDate since} ^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)} @@ -36,11 +36,11 @@ $# . Invitee Role Time - $forall (inviter, invitee, time) <- invites + $forall (inviter, invitee, time, role) <- invites ^{personLinkFedW inviter} ^{personLinkFedW invitee} - Admin + #{show role} #{showDate time} Invite… @@ -52,8 +52,8 @@ $# . Joiner Role Time - $forall (joiner, time) <- joins + $forall (joiner, time, role) <- joins ^{personLinkFedW joiner} - Admin + #{show role} #{showDate time} diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index 72d7412..dd469ae 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -56,23 +56,32 @@ $# Comment on a ticket or merge request

Your repos