forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Support the 6 ForgeFed roles + launch repo/deck/loom actor upon creation

Browse source
This commit is contained in:
Pere Lev 2023-06-17 21:35:00 +03:00
parent c8c2106eab
commit 581838e550
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
24 changed files with 239 additions and 350 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

62
src/Vervis/API.hs
View file

@ -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

31
src/Vervis/Access.hs
View file

@ -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

37
src/Vervis/Actor/Common.hs
View file

@ -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

1
src/Vervis/Actor/Deck.hs
View file

@ -360,6 +360,7 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
capability
authorIdMsig
(GrantResourceDeck recipDeckID)
AP.RoleTriage
lift $ lift deleteFromDB

6
src/Vervis/Actor/Person.hs
View file

@ -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' ->

2
src/Vervis/Actor/Person/Client.hs
View file

@ -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

7
src/Vervis/Client.hs
View file

@ -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

35
src/Vervis/Data/Collab.hs
View file

@ -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

1
src/Vervis/Federation/Ticket.hs
View file

@ -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

1
src/Vervis/Fetch.hs
View file

@ -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

42
src/Vervis/Handler/Client.hs
View file

@ -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

15
src/Vervis/Handler/Deck.hs
View file

@ -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"

16
src/Vervis/Migration.hs
View file

@ -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

9
src/Vervis/Model.hs
View file

@ -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 <fr33domlover@riseup.net>.
-
- ♡ 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

7
src/Vervis/Model/Role.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis.
-
- Written in 2016, 2018, 2019, 2021 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2018, 2019, 2021, 2023
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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"

57
src/Vervis/Persist/Collab.hs
View file

@ -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

4
src/Vervis/Persist/Ticket.hs
View file

@ -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

78
src/Vervis/Query.hs
View file

@ -1,78 +0,0 @@
{- This file is part of Vervis.
-
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- | 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]

59
src/Vervis/Role.hs
View file

@ -1,59 +0,0 @@
{- This file is part of Vervis.
-
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
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

46
src/Web/ActivityPub.hs
View file

@ -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)

12
templates/deck/collab/list.hamlet
View file

@ -21,10 +21,10 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Collaborator
<th>Role
<th>Since
$forall (person, ctID, since) <- collabs
$forall (person, role, ctID, since) <- collabs
<tr>
<td>#{show role}
<td>^{personLinkFedW person}
<td>Admin
<td>#{showDate since}
<td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}
@ -36,11 +36,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Invitee
<th>Role
<th>Time
$forall (inviter, invitee, time) <- invites
$forall (inviter, invitee, time, role) <- invites
<tr>
<td>^{personLinkFedW inviter}
<td>^{personLinkFedW invitee}
<td>Admin
<td>#{show role}
<td>#{showDate time}
<a href=@{DeckInviteR deckHash}>Invite…
@ -52,8 +52,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Joiner
<th>Role
<th>Time
$forall (joiner, time) <- joins
$forall (joiner, time, role) <- joins
<tr>
<td>^{personLinkFedW joiner}
<td>Admin
<td>#{show role}
<td>#{showDate time}

15
templates/personal-overview.hamlet
View file

@ -56,23 +56,32 @@ $# Comment on a ticket or merge request
<h2>Your repos
<ul>
$forall (Entity repoID _, Entity _ actor) <- repos
$forall (Entity repoID _, Entity _ actor, Entity _ (Collab role)) <- repos
<li>
[
#{show role}
]
<a href=@{RepoR $ hashRepo repoID}>
^#{keyHashidText $ hashRepo repoID} #{actorName actor}
<h2>Your ticket trackers
<ul>
$forall (Entity deckID _, Entity _ actor) <- decks
$forall (Entity deckID _, Entity _ actor, Entity _ (Collab role)) <- decks
<li>
[
#{show role}
]
<a href=@{DeckR $ hashDeck deckID}>
=#{keyHashidText $ hashDeck deckID} #{actorName actor}
<h2>Your patch trackers
<ul>
$forall (Entity loomID _, Entity _ actor) <- looms
$forall (Entity loomID _, Entity _ actor, Entity _ (Collab role)) <- looms
<li>
[
#{show role}
]
<a href=@{LoomR $ hashLoom loomID}>
+#{keyHashidText $ hashLoom loomID} #{actorName actor}

44
th/models
View file

@ -280,24 +280,6 @@ GroupMember
UniqueGroupMember person group
-- I'm removing the 'sharer' field, so all roles are now public for everyone to
-- use! This is temporary, until I figure out a sane plan for federated roles
Role
ident RlIdent
desc Text
RoleInherit
parent RoleId
child RoleId
UniqueRoleInherit parent child
RoleAccess
role RoleId
op ProjectOperation
UniqueRoleAccess role op
-------------------------------------------------------------------------------
-- Projects
-------------------------------------------------------------------------------
@ -307,8 +289,6 @@ Deck
workflow WorkflowId
nextTicket Int
wiki RepoId Maybe
collabUser RoleId Maybe
collabAnon RoleId Maybe
create OutboxItemId
UniqueDeckActor actor
@ -328,8 +308,6 @@ Repo
vcs VersionControlSystem
project DeckId Maybe
mainBranch Text
collabUser RoleId Maybe
collabAnon RoleId Maybe
actor ActorId
create OutboxItemId
loom LoomId Maybe
@ -592,6 +570,7 @@ RemoteMessage
------------------------------------------------------------------------------
Collab
role Role
-------------------------------- Collab reason -------------------------------
@ -723,24 +702,3 @@ CollabRecipRemoteAccept
UniqueCollabRecipRemoteAcceptCollab collab
UniqueCollabRecipRemoteAcceptInvite invite
UniqueCollabRecipRemoteAcceptAccept accept
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--RepoRemoteCollab
-- repo RepoId
-- collab RemoteActorId
-- role RoleId Maybe
-- cap Text
--
-- UniqueRepoRemoteCollab repo collab
-- UniqueRepoRemoteCollabCap cap
--
--ProjectRemoteCollab
-- project DeckId
-- collab RemoteActorId
-- role RoleId Maybe
-- cap Text
--
-- UniqueProjectRemoteCollab project person
-- UniqueProjectRemoteCollabCap cap

2
vervis.cabal
View file

@ -237,13 +237,11 @@ library
Vervis.Persist.Follow
Vervis.Persist.Ticket
Vervis.Query
Vervis.Readme
Vervis.Recipient
Vervis.RemoteActorStore
Vervis.RemoteActorStore.Types
--Vervis.Repo
--Vervis.Role
Vervis.Secure
Vervis.Settings
Vervis.Settings.StaticFiles