forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Switch to factory-based creation of Deck, Project and Group

Browse source 
- UI for creating a Factory
- UI for specifying a Factory when creating resource actors
- Old way of creation doesn't work anymore, except for Factory itself
- UI indicates whether you're an admin user
- Settings allow to choose "resident" factories, i.e. ones automatically
  offered to every newly verified user

Caveats:

- Factories are all-in-one, no mechanism yet for choosing actor types
- No UI/logic for auto-offering a Factory to all users of a different
  instance, and signaling other instances about newly verified local
  users
This commit is contained in:
Pere Lev 2024-08-06 12:33:02 +03:00
parent 66870458b7
commit e196ee6f34
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
34 changed files with 1607 additions and 816 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
config/settings-default.yaml
View file

@ -110,6 +110,13 @@ max-accounts: 3
# Person usernames who are allowed to create Factory actors # Person usernames who are allowed to create Factory actors
can-create-factories: [] can-create-factories: []
# KeyHashids of local Factory actors who will auto-send a develop-Grant to
# every newly created account
#
# If empty or unset, and there's exactly 1 local factory in DB, it will
# automatically become the resident
resident-factories: []
############################################################################### ###############################################################################
# Mail # Mail
############################################################################### ###############################################################################

24
migrations/650_2024-08-03_fulfills_resident.model Normal file
View file

@ -0,0 +1,24 @@
CollabFulfillsResidentFactory
collab CollabId
UniqueCollabFulfillsResidentFactory collab
PermitFulfillsResidentFactory
permit PermitId
UniquePermitFulfillsResidentFactory permit
ActorCreateLocal
actor ActorId
create OutboxItemId
UniqueActorCreateLocalActor actor
UniqueActorCreateLocalCreate create
ActorCreateRemote
actor ActorId
create RemoteActivityId
sender RemoteActorId
UniqueActorCreateRemoteActor actor
UniqueActorCreateRemoteCreate create

114
migrations/651_2024-08-03_actor_create.model Normal file
View file

@ -0,0 +1,114 @@
Komponent
Workflow
Outbox
OutboxItem
outbox OutboxId
activity PersistJSONObject
published UTCTime
Inbox
FollowerSet
Actor
name Text
desc Text
createdAt UTCTime
inbox InboxId
outbox OutboxId
followers FollowerSetId
justCreatedBy ActorId Maybe
errbox InboxId
UniqueActorInbox inbox
UniqueActorOutbox outbox
UniqueActorFollowers followers
ActorCreateLocal
actor ActorId
create OutboxItemId
Person
username Username
login Text
passphraseHash ByteString
email EmailAddress
verified Bool
verifiedKey Text
verifiedKeyCreated UTCTime
resetPassKey Text
resetPassKeyCreated UTCTime
actor ActorId
-- reviewFollow Bool
UniquePersonUsername username
UniquePersonLogin login
UniquePersonEmail email
UniquePersonActor actor
Resource
actor ActorId
UniqueResource actor
Factory
resource ResourceId
create OutboxItemId
UniqueFactory resource
UniqueFactoryCreate create
Group
actor ActorId
resource ResourceId
create OutboxItemId
UniqueGroupActor actor
UniqueGroupCreate create
Project
actor ActorId
resource ResourceId
create OutboxItemId
UniqueProjectActor actor
UniqueProjectCreate create
Deck
actor ActorId
resource ResourceId
komponent KomponentId
workflow WorkflowId
nextTicket Int
wiki RepoId Maybe
create OutboxItemId
UniqueDeckActor actor
UniqueDeckCreate create
Loom
nextTicket Int
actor ActorId
resource ResourceId
komponent KomponentId
repo RepoId
create OutboxItemId
UniqueLoomActor actor
UniqueLoomRepo repo
UniqueLoomCreate create
Repo
vcs VersionControlSystem
project DeckId Maybe
mainBranch Text
actor ActorId
resource ResourceId
komponent KomponentId
create OutboxItemId
loom LoomId Maybe
UniqueRepoActor actor
UniqueRepoCreate create

9
src/Control/Concurrent/Actor.hs
View file

@ -486,9 +486,10 @@ hSendTo
:: ( Actor a :: ( Actor a
, Eq (ActorKey a), Hashable (ActorKey a) , Eq (ActorKey a), Hashable (ActorKey a)
) )
=> (TVar (ActorRefMap a), (HashSet (ActorKey a), ActorMessage a)) => (TVar (ActorRefMap a), Maybe (HashSet (ActorKey a), ActorMessage a))
-> IO () -> IO ()
hSendTo (tvar, (recips, msg)) = do hSendTo (_ , Nothing) = pure ()
hSendTo (tvar, Just (recips, msg)) = do
allActors <- readTVarIO tvar allActors <- readTVarIO tvar
for_ (HM.intersection allActors (HS.toMap recips)) $ for_ (HM.intersection allActors (HS.toMap recips)) $
\ actor -> sendIO' actor msg \ actor -> sendIO' actor msg
@ -497,7 +498,7 @@ data HSendTo = HSendTo
instance instance
( Actor a ( Actor a
, Eq (ActorKey a), Hashable (ActorKey a) , Eq (ActorKey a), Hashable (ActorKey a)
, i ~ (TVar (ActorRefMap a), (HashSet (ActorKey a), ActorMessage a)) , i ~ (TVar (ActorRefMap a), Maybe (HashSet (ActorKey a), ActorMessage a))
) => ) =>
H.ApplyAB HSendTo i (IO ()) where H.ApplyAB HSendTo i (IO ()) where
applyAB _ a = hSendTo a applyAB _ a = hSendTo a
@ -509,7 +510,7 @@ type instance Eval (B_ a) =
) )
data Set_ :: Type -> Exp Type data Set_ :: Type -> Exp Type
type instance Eval (Set_ a) = (HashSet (ActorKey a), ActorMessage a) type instance Eval (Set_ a) = Maybe (HashSet (ActorKey a), ActorMessage a)
data Pair__ :: Type -> Exp Type data Pair__ :: Type -> Exp Type
type instance Eval (Pair__ a) = (Eval (Item_ a), Eval (Set_ a)) type instance Eval (Pair__ a) = (Eval (Item_ a), Eval (Set_ a))

14
src/Vervis/API.hs
View file

@ -147,7 +147,7 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap
msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action
maybeResult <- maybeResult <-
liftIO $ callIO theater personID (MsgP $ Right msg) liftIO $ callIO theater personID (PersonMsgClient msg)
itemText <- itemText <-
case maybeResult of case maybeResult of
Nothing -> error "Person not found in theater" Nothing -> error "Person not found in theater"
@ -1150,7 +1150,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
insertLoom now name msummary obiidCreate repoID = do insertLoom now name msummary obiidCreate repoID = do
actor@(Entity actorID _) <- actor@(Entity actorID _) <-
insertActor now name (fromMaybe "" msummary) (Just $ personActor personUser) insertActor now name (fromMaybe "" msummary) $ Left (error "insertLoom1", error "insertLoom2", obiidCreate)
resourceID <- insert $ Resource actorID resourceID <- insert $ Resource actorID
komponentID <- insert $ Komponent resourceID komponentID <- insert $ Komponent resourceID
loomID <- insert Loom loomID <- insert Loom
@ -1159,7 +1159,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
, loomResource = resourceID , loomResource = resourceID
, loomKomponent = komponentID , loomKomponent = komponentID
, loomRepo = repoID , loomRepo = repoID
, loomCreate = obiidCreate --, loomCreate = obiidCreate
} }
return (loomID, resourceID, actor) return (loomID, resourceID, actor)
@ -1185,7 +1185,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
repo = encodeRouteHome $ RepoR repoHash repo = encodeRouteHome $ RepoR repoHash
specific = CreateActivity Create specific = CreateActivity Create
{ createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal)) { createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal))
, createTarget = Nothing , createOrigin = Nothing
} }
return action { actionSpecific = specific } return action { actionSpecific = specific }
@ -1395,7 +1395,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
insertRepo now name msummary createID = do insertRepo now name msummary createID = do
actor@(Entity actorID _) <- actor@(Entity actorID _) <-
insertActor now name (fromMaybe "" msummary) (Just $ personActor personUser) insertActor now name (fromMaybe "" msummary) $ Left (error "insertRepo1", error "insertRepo2", createID)
resourceID <- insert $ Resource actorID resourceID <- insert $ Resource actorID
komponentID <- insert $ Komponent resourceID komponentID <- insert $ Komponent resourceID
repoID <- insert Repo repoID <- insert Repo
@ -1405,7 +1405,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
, repoActor = actorID , repoActor = actorID
, repoResource = resourceID , repoResource = resourceID
, repoKomponent = komponentID , repoKomponent = komponentID
, repoCreate = createID --, repoCreate = createID
, repoLoom = Nothing , repoLoom = Nothing
} }
return (repoID, resourceID, actor) return (repoID, resourceID, actor)
@ -1430,7 +1430,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
} }
specific = CreateActivity Create specific = CreateActivity Create
{ createObject = CreateRepository rdetail vcs (Just (hLocal, rlocal)) { createObject = CreateRepository rdetail vcs (Just (hLocal, rlocal))
, createTarget = Nothing , createOrigin = Nothing
} }
return action { actionSpecific = specific } return action { actionSpecific = specific }

97
src/Vervis/Actor.hs
View file

@ -506,12 +506,17 @@ instance Actor Person where
type ActorStage Person = Staje type ActorStage Person = Staje
type ActorKey Person = PersonId type ActorKey Person = PersonId
type ActorReturn Person = Either Text Text type ActorReturn Person = Either Text Text
data ActorMessage Person = MsgP (Either Verse ClientMsg) data ActorMessage Person
= PersonMsgVerse Verse
| PersonMsgClient ClientMsg
| PersonMsgInit
instance Actor Deck where instance Actor Deck where
type ActorStage Deck = Staje type ActorStage Deck = Staje
type ActorKey Deck = DeckId type ActorKey Deck = DeckId
type ActorReturn Deck = Either Text Text type ActorReturn Deck = Either Text Text
data ActorMessage Deck = MsgD Verse data ActorMessage Deck
= DeckMsgVerse Verse
| DeckMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
instance Actor Loom where instance Actor Loom where
type ActorStage Loom = Staje type ActorStage Loom = Staje
type ActorKey Loom = LoomId type ActorKey Loom = LoomId
@ -526,33 +531,40 @@ instance Actor Project where
type ActorStage Project = Staje type ActorStage Project = Staje
type ActorKey Project = ProjectId type ActorKey Project = ProjectId
type ActorReturn Project = Either Text Text type ActorReturn Project = Either Text Text
data ActorMessage Project = MsgJ Verse data ActorMessage Project
= ProjectMsgVerse Verse
| ProjectMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
instance Actor Group where instance Actor Group where
type ActorStage Group = Staje type ActorStage Group = Staje
type ActorKey Group = GroupId type ActorKey Group = GroupId
type ActorReturn Group = Either Text Text type ActorReturn Group = Either Text Text
data ActorMessage Group = MsgG Verse data ActorMessage Group
= TeamMsgVerse Verse
| TeamMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
instance Actor Factory where instance Actor Factory where
type ActorStage Factory = Staje type ActorStage Factory = Staje
type ActorKey Factory = FactoryId type ActorKey Factory = FactoryId
type ActorReturn Factory = Either Text Text type ActorReturn Factory = Either Text Text
data ActorMessage Factory = MsgF Verse data ActorMessage Factory
= FactoryMsgVerse Verse
| FactoryMsgVerified PersonId
instance VervisActor Person where instance VervisActor Person where
actorVerse = MsgP . Left actorVerse = PersonMsgVerse
toVerse (MsgP e) = toVerse (PersonMsgVerse v) = Just v
case e of toVerse _ = Nothing
Left v -> Just v
Right _ -> Nothing
instance VervisActor Project where instance VervisActor Project where
actorVerse = MsgJ actorVerse = ProjectMsgVerse
toVerse (MsgJ v) = Just v toVerse (ProjectMsgVerse v) = Just v
toVerse _ = Nothing
instance VervisActor Group where instance VervisActor Group where
actorVerse = MsgG actorVerse = TeamMsgVerse
toVerse (MsgG v) = Just v toVerse (TeamMsgVerse v) = Just v
toVerse _ = Nothing
instance VervisActor Deck where instance VervisActor Deck where
actorVerse = MsgD actorVerse = DeckMsgVerse
toVerse (MsgD v) = Just v toVerse (DeckMsgVerse v) = Just v
toVerse _ = Nothing
instance VervisActor Loom where instance VervisActor Loom where
actorVerse = MsgL actorVerse = MsgL
toVerse (MsgL v) = Just v toVerse (MsgL v) = Just v
@ -563,8 +575,9 @@ instance VervisActor Repo where
Left v -> Just v Left v -> Just v
Right _ -> Nothing Right _ -> Nothing
instance VervisActor Factory where instance VervisActor Factory where
actorVerse = MsgF actorVerse = FactoryMsgVerse
toVerse (MsgF v) = Just v toVerse (FactoryMsgVerse v) = Just v
toVerse _ = Nothing
instance Stage Staje where instance Stage Staje where
data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env
@ -594,13 +607,17 @@ instance Stage Staje where
type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo, Factory] type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo, Factory]
instance Message (ActorMessage Person) where instance Message (ActorMessage Person) where
summarize (MsgP (Left verse)) = summarizeVerse verse summarize (PersonMsgVerse verse) = summarizeVerse verse
summarize (MsgP (Right _)) = "ClientMsg" summarize (PersonMsgClient _) = "PersonMsgClient"
refer (MsgP (Left verse)) = referVerse verse summarize PersonMsgInit = "PersonMsgInit"
refer (MsgP (Right _)) = "ClientMsg" refer (PersonMsgVerse verse) = referVerse verse
refer (PersonMsgClient _) = "PersonMsgClient"
refer PersonMsgInit = "PersonMsgInit"
instance Message (ActorMessage Deck) where instance Message (ActorMessage Deck) where
summarize (MsgD verse) = summarizeVerse verse summarize (DeckMsgVerse verse) = summarizeVerse verse
refer (MsgD verse) = referVerse verse summarize (DeckMsgInit _) = "DeckMsgInit"
refer (DeckMsgVerse verse) = referVerse verse
refer (DeckMsgInit _) = "DeckMsgInit"
instance Message (ActorMessage Loom) where instance Message (ActorMessage Loom) where
summarize (MsgL verse) = summarizeVerse verse summarize (MsgL verse) = summarizeVerse verse
refer (MsgL verse) = referVerse verse refer (MsgL verse) = referVerse verse
@ -610,14 +627,20 @@ instance Message (ActorMessage Repo) where
refer (MsgR (Left verse)) = referVerse verse refer (MsgR (Left verse)) = referVerse verse
refer (MsgR (Right _)) = "WaitPushCompletion" refer (MsgR (Right _)) = "WaitPushCompletion"
instance Message (ActorMessage Project) where instance Message (ActorMessage Project) where
summarize (MsgJ verse) = summarizeVerse verse summarize (ProjectMsgVerse verse) = summarizeVerse verse
refer (MsgJ verse) = referVerse verse summarize (ProjectMsgInit _) = "ProjectMsgInit"
refer (ProjectMsgVerse verse) = referVerse verse
refer (ProjectMsgInit _) = "ProjectMsgInit"
instance Message (ActorMessage Group) where instance Message (ActorMessage Group) where
summarize (MsgG verse) = summarizeVerse verse summarize (TeamMsgVerse verse) = summarizeVerse verse
refer (MsgG verse) = referVerse verse summarize (TeamMsgInit _) = "TeamMsgInit"
refer (TeamMsgVerse verse) = referVerse verse
refer (TeamMsgInit _) = "TeamMsgInit"
instance Message (ActorMessage Factory) where instance Message (ActorMessage Factory) where
summarize (MsgF verse) = summarizeVerse verse summarize (FactoryMsgVerse verse) = summarizeVerse verse
refer (MsgF verse) = referVerse verse summarize (FactoryMsgVerified _) = "FactoryMsgVerified"
refer (FactoryMsgVerse verse) = referVerse verse
refer (FactoryMsgVerified _) = "FactoryMsgVerified"
type YesodRender y = Route y -> [(Text, Text)] -> Text type YesodRender y = Route y -> [(Text, Text)] -> Text
@ -935,13 +958,13 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
partitionByActor liveRecips partitionByActor liveRecips
verse = Verse authorAndId' body verse = Verse authorAndId' body
sendMany $ sendMany $
(liveRecipsP, actorVerse verse) `H.HCons` (Just (liveRecipsP, actorVerse verse)) `H.HCons`
(liveRecipsJ, actorVerse verse) `H.HCons` (Just (liveRecipsJ, actorVerse verse)) `H.HCons`
(liveRecipsG, actorVerse verse) `H.HCons` (Just (liveRecipsG, actorVerse verse)) `H.HCons`
(liveRecipsD, actorVerse verse) `H.HCons` (Just (liveRecipsD, actorVerse verse)) `H.HCons`
(liveRecipsL, actorVerse verse) `H.HCons` (Just (liveRecipsL, actorVerse verse)) `H.HCons`
(liveRecipsR, actorVerse verse) `H.HCons` (Just (liveRecipsR, actorVerse verse)) `H.HCons`
(liveRecipsF, actorVerse verse) `H.HCons` H.HNil (Just (liveRecipsF, actorVerse verse)) `H.HCons` H.HNil
-- Return remote followers, to whom we need to deliver via HTTP -- Return remote followers, to whom we need to deliver via HTTP
return remoteFollowers return remoteFollowers

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

@ -19,12 +19,14 @@
module Vervis.Actor.Common module Vervis.Actor.Common
( actorFollow ( actorFollow
, actorFollow'
, topicAccept , topicAccept
, topicReject , topicReject
, componentInvite , componentInvite
, componentRemove , componentRemove
, topicJoin , topicJoin
, topicCreateMe , topicCreateMe
, topicInit
, componentGrant , componentGrant
, componentAdd , componentAdd
, componentRevoke , componentRevoke
@ -86,11 +88,13 @@ import Vervis.Data.Actor
import Vervis.Data.Collab import Vervis.Data.Collab
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Persist.Actor import Vervis.Persist.Actor
import Vervis.Persist.Collab import Vervis.Persist.Collab
import Vervis.Persist.Discussion import Vervis.Persist.Discussion
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor) import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Settings
import Vervis.Ticket import Vervis.Ticket
import Vervis.Web.Collab import Vervis.Web.Collab
@ -113,7 +117,24 @@ actorFollow
-> Verse -> Verse
-> AP.Follow URIMode -> AP.Follow URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID (Verse authorIdMsig body) (AP.Follow uObject _ hide) = do actorFollow parseFollowee grabActor =
actorFollow' parseFollowee (pure . grabActor)
actorFollow'
:: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
=> (Route App -> ActE a)
-> (r -> ActDB ActorId)
-> Bool
-> (Actor -> a -> ActDBE FollowerSetId)
-> (a -> ActDB RecipientRoutes)
-> (forall f. f r -> LocalActorBy f)
-> (a -> Act [Aud URIMode])
-> UTCTime
-> Key r
-> Verse
-> AP.Follow URIMode
-> ActE (Text, Act (), Next)
actorFollow' parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID (Verse authorIdMsig body) (AP.Follow uObject _ hide) = do
-- Check input -- Check input
followee <- nameExceptT "Follow object" $ do followee <- nameExceptT "Follow object" $ do
@ -132,7 +153,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
-- Find me in DB -- Find me in DB
recip <- lift $ getJust recipID recip <- lift $ getJust recipID
let recipActorID = grabActor recip recipActorID <- lift $ grabActor recip
recipActor <- lift $ getJust recipActorID recipActor <- lift $ getJust recipActorID
-- Insert the Follow to my inbox -- Insert the Follow to my inbox
@ -2248,82 +2269,148 @@ topicJoin grabResource topicResource now topicKey (Verse authorIdMsig body) join
recipID <- insert $ CollabRecipRemote collabID authorID recipID <- insert $ CollabRecipRemote collabID authorID
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
-- Meaning: Someone has created an actor with my ID URI
-- Behavior:
-- * Verify I have no Collab records, implying just-been-created state
-- * Verify my (local!) creator and the Create sender are the same actor
-- * Possibly: Verify the creator is in the can-create-factories list
-- * Possibly:
-- If I'm the first in my table and listed as resident (or no
-- residents are listed),
-- send out develop-Grants (and create Collab records) to all verified
-- local Persons
-- * Create an admin Collab record in DB
-- * Send an admin Grant to the creator
topicCreateMe topicCreateMe
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ResourceId) => Bool
-> Bool
-> (topic -> ResourceId)
-> (forall f. f topic -> LocalResourceBy f) -> (forall f. f topic -> LocalResourceBy f)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body) = do topicCreateMe checkCan sendGrants grabResource meToResource now meID (Verse authorIdMsig body) = do
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
resourceID <- lift $ grabResource <$> getJust recipKey resourceMeID <- lift $ grabResource <$> getJust meID
Resource recipActorID <- lift $ getJust resourceID Resource actorMeID <- lift $ getJust resourceMeID
recipActor <- lift $ getJust recipActorID actorMe <- lift $ getJust actorMeID
-- Verify I'm in the initial just-been-created state -- Verify I'm in initial state
creatorActorID <- creatorActorID <- do
fromMaybeE create <-
(actorJustCreatedBy recipActor) lift $
"I already sent the initial Grant, why am I receiving this Create?" requireEitherAlt
(getValBy $ UniqueActorCreateLocalActor actorMeID)
(getValBy $ UniqueActorCreateRemoteActor actorMeID)
"Neither local nor remote"
"Both local and remote"
case create of
Left (ActorCreateLocal _ createID) -> do
OutboxItem outboxID _ _ <- lift $ getJust createID
mk <- lift $ getKeyBy $ UniqueActorOutbox outboxID
fromMaybeE mk "Creator actor not found"
Right _ -> error "topicCreateMe used on a remotely-created actor"
creatorPersonID <- do creatorPersonID <- do
mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID
fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently" fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently"
existingCollabIDs <- existingCollabIDs <-
lift $ selectList [CollabTopic ==. resourceID] [] lift $ selectList [CollabTopic ==. resourceMeID] []
unless (null existingCollabIDs) $ unless (null existingCollabIDs) $
error "Just-been-created but I somehow already have Collabs" throwE "I already have Collab records"
-- Verify the Create author is my creator indeed -- Verify the Create author is my creator indeed
case authorIdMsig of case authorIdMsig of
Left (_, actorID, _) | actorID == creatorActorID -> pure () Left (_, actorID, _) | actorID == creatorActorID -> pure ()
_ -> throwE "Create author isn't why I believe my creator is - is this Create fake?" _ -> throwE "Create author isn't why I believe my creator is - is this Create fake?"
maybeCreateDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False -- Verify creator is in can-create-factories list
when checkCan $ do
u <- lift $ personUsername <$> getJust creatorPersonID
cans <- asksEnv $ appCanCreateFactories . envSettings
unless (u `elem` map text2username cans) $
throwE "Creator person isn't in can-create-factories list"
maybeCreateDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False
lift $ for maybeCreateDB $ \ (inboxItemID, _createDB) -> do lift $ for maybeCreateDB $ \ (inboxItemID, _createDB) -> do
-- Create a Collab record and exit just-been-created state -- Create a Collab record
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now grantID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
insertCollab resourceID creatorPersonID grantID insertCollab resourceMeID creatorPersonID grantID
update creatorActorID [ActorJustCreatedBy =. Nothing]
-- Prepare a Grant activity and insert to my outbox -- Prepare a Grant activity and insert to my outbox
grant@(actionGrant, _, _, _) <- lift prepareGrant grant@(actionGrant, _, _, _) <- lift prepareGrant
let recipByKey = resourceToActor $ topicResource recipKey let recipByKey = resourceToActor $ meToResource meID
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
return (recipActorID, grantID, grant, inboxItemID) writes <-
if sendGrants
then do
residents <- asksEnv $ appResidentFactories . envSettings
meHash <- encodeKeyHashid meID
let meHashText = keyHashidText meHash
ids <- selectKeysList [] []
let meResident =
null residents || meHashText `elem` residents
if meResident && ids == [meID]
then do
ps <- selectList [PersonId !=. creatorPersonID, PersonVerified ==. True] []
for ps $ \ p@(Entity personID _) -> do
writeID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
insertResidentCollab resourceMeID personID writeID
write@(actionWrite, _, _, _) <- prepareResidentGrant p
let recipByKey = resourceToActor $ meToResource meID
_luWrite <- updateOutboxItem' recipByKey writeID actionWrite
return (writeID, write)
else pure []
else pure []
return (actorMeID, grantID, grant, writes, inboxItemID)
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), inboxItemID) -> do Just (actorMeID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), writes, inboxItemID) -> do
let recipByID = resourceToActor $ topicResource recipKey let recipByID = resourceToActor $ meToResource meID
lift $ sendActivity lift $ do
recipByID recipActorID localRecipsGrant sendActivity
remoteRecipsGrant fwdHostsGrant grantID actionGrant recipByID actorMeID localRecipsGrant
doneDB inboxItemID "Created a Collab record and published a Grant" remoteRecipsGrant fwdHostsGrant grantID actionGrant
for_ writes $ \ (writeID, (actionWrite, localRecipsWrite, remoteRecipsWrite, fwdHostsWrite)) ->
sendActivity
recipByID actorMeID localRecipsWrite
remoteRecipsWrite fwdHostsWrite writeID actionWrite
doneDB inboxItemID "Created a Collab record and published a Grant, possibly sent write-Grants"
where where
insertCollab resourceID personID grantID = do insertCollab resourceMeID personID grantID = do
collabID <- insert $ Collab AP.RoleAdmin resourceID collabID <- insert $ Collab AP.RoleAdmin resourceMeID
insert_ $ CollabEnable collabID grantID insert_ $ CollabEnable collabID grantID
insert_ $ CollabRecipLocal collabID personID insert_ $ CollabRecipLocal collabID personID
insert_ $ CollabFulfillsLocalTopicCreation collabID insert_ $ CollabFulfillsLocalTopicCreation collabID
insertResidentCollab resourceMeID personID grantID = do
collabID <- insert $ Collab AP.RoleWrite resourceMeID
insert_ $ CollabEnable collabID grantID
insert_ $ CollabRecipLocal collabID personID
insert_ $ CollabFulfillsResidentFactory collabID
prepareGrant = do prepareGrant = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
audCreator <- makeAudSenderOnly authorIdMsig audCreator <- makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey recipHash <- encodeKeyHashid meID
uCreator <- getActorURI authorIdMsig uCreator <- getActorURI authorIdMsig
uCreate <- getActivityURI authorIdMsig uCreate <- getActivityURI authorIdMsig
let topicByHash = resourceToActor $ topicResource recipHash let topicByHash = resourceToActor $ meToResource recipHash
audience = audience =
let audTopic = AudLocal [] [localActorFollowers topicByHash] let audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audCreator, audTopic] in [audCreator, audTopic]
@ -2352,6 +2439,167 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body)
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
prepareResidentGrant (Entity personID person) = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
personHash <- encodeKeyHashid personID
let audPerson = AudLocal [LocalActorPerson personHash] []
meHash <- encodeKeyHashid meID
uCreate <- do
selfCreateID <- do
mc <- getValBy $ UniqueActorCreateLocalActor $ personActor person
case mc of
Nothing -> error "Person doesn't have an ActorCreateLocal record"
Just c -> pure $ actorCreateLocalCreate c
createHash <- encodeKeyHashid selfCreateID
return $ encodeRouteHome $ PersonOutboxItemR personHash createHash
let topicByHash = resourceToActor $ meToResource meHash
audience =
let audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audPerson, audTopic]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience audience
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uCreate]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = AP.RXRole AP.RoleWrite
, AP.grantContext =
encodeRouteHome $ renderLocalActor topicByHash
, AP.grantTarget = encodeRouteHome $ PersonR personHash
, AP.grantResult = Nothing
, AP.grantStart = Just now
, AP.grantEnd = Nothing
, AP.grantAllows = AP.Invoke
, AP.grantDelegates = Nothing
}
}
return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: I've just been created
-- Behavior:
-- * Verify my creator and the Create sender are the same actor
-- * Create an admin Collab record in DB
-- * Send an admin Grant to the creator
topicInit
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ActDB ResourceId)
-> (forall f. f topic -> LocalResourceBy f)
-> UTCTime
-> Key topic
-> Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)
-> ActE (Text, Act (), Next)
topicInit grabResource meToResource now meID creator = do
(actorMeID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) <- withDBExcept $ do
-- Grab me from DB
resourceMeID <- lift $ grabResource =<< getJust meID
Resource actorMeID <- lift $ getJust resourceMeID
actorMe <- lift $ getJust actorMeID
-- Verify I don't have any Collab records
collabIDs <- lift $ selectKeysList [CollabTopic ==. resourceMeID] []
unless (null collabIDs) $
throwE "I already have Collab records"
-- Verify my creator in DB and the one passed to me are the same actor
create <-
lift $
requireEitherAlt
(getValBy $ UniqueActorCreateLocalActor actorMeID)
(getValBy $ UniqueActorCreateRemoteActor actorMeID)
"Neither local nor remote"
"Both local and remote"
let create' =
bimap actorCreateLocalCreate actorCreateRemoteSender create
creator' =
bimap (view _3) (remoteAuthorId . fst) creator
unless (create' == creator') $
throwE "Creator in DB and in argument aren't the same"
-- If creator is local, verify it's a Person, because the DB schema
-- currently allows only Person to be the recipient of a Collab
let verifyIsPerson = \case
LocalActorPerson p -> pure p
_ -> throwE "Local creator isn't a Person"
creatorPerson <-
traverseOf _Left (traverseOf _1 verifyIsPerson) creator
-- Create a Collab record
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
lift $ insertCollab resourceMeID creatorPerson grantID
-- Prepare a Grant activity and insert to my outbox
grant@(actionGrant, _, _, _) <- lift $ lift prepareGrant
let recipByKey = resourceToActor $ meToResource meID
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
return (actorMeID, grantID, grant)
let recipByID = resourceToActor $ meToResource meID
lift $ sendActivity
recipByID actorMeID localRecipsGrant
remoteRecipsGrant fwdHostsGrant grantID actionGrant
done "Created a Collab record and published a Grant"
where
insertCollab resourceMeID creatorPerson grantID = do
collabID <- insert $ Collab AP.RoleAdmin resourceMeID
insert_ $ CollabEnable collabID grantID
case creatorPerson of
Left (personID, _, _) ->
insert_ $ CollabRecipLocal collabID personID
Right (author, _) ->
insert_ $ CollabRecipRemote collabID (remoteAuthorId author)
insert_ $ CollabFulfillsLocalTopicCreation collabID
prepareGrant = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
let creatorMsig = second (\ (ra, lu) -> (ra, lu, Nothing)) creator
audCreator <- makeAudSenderOnly creatorMsig
meHash <- encodeKeyHashid meID
uCreator <- getActorURI creatorMsig
uCreate <- getActivityURI creatorMsig
let meActorHash = resourceToActor $ meToResource meHash
audience =
let audMe = AudLocal [] [localActorFollowers meActorHash]
in [audCreator, audMe]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience audience
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uCreate]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = AP.RXRole AP.RoleAdmin
, AP.grantContext =
encodeRouteHome $ renderLocalActor meActorHash
, AP.grantTarget = uCreator
, AP.grantResult = Nothing
, AP.grantStart = Just now
, AP.grantEnd = Nothing
, AP.grantAllows = AP.Invoke
, AP.grantDelegates = Nothing
}
}
return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: An actor is granting access-to-some-resource to another actor -- Meaning: An actor is granting access-to-some-resource to another actor
-- Behavior: -- Behavior:
-- * If I approved an Add-to-project where I'm the component, and the -- * If I approved an Add-to-project where I'm the component, and the

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

@ -107,42 +107,6 @@ deckAdd
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckAdd = componentAdd deckKomponent ComponentDeck deckAdd = componentAdd deckKomponent ComponentDeck
-- Meaning: Someone has created a ticket tracker with my ID URI
-- Behavior:
-- * Verify I'm in a just-been-created state
-- * Verify my creator and the Create sender are the same actor
-- * Create an admin Collab record in DB
-- * Send an admin Grant to the creator
-- * Get out of the just-been-created state
deckCreateMe
:: UTCTime
-> DeckId
-> Verse
-> ActE (Text, Act (), Next)
deckCreateMe = topicCreateMe deckResource LocalResourceDeck
deckCreate
:: UTCTime
-> DeckId
-> Verse
-> AP.Create URIMode
-> ActE (Text, Act (), Next)
deckCreate now deckID verse (AP.Create obj _muTarget) =
case obj of
AP.CreateTicketTracker _ mlocal -> do
(h, local) <- fromMaybeE mlocal "No tracker id provided"
let luTracker = AP.actorId local
uMe <- do
deckHash <- encodeKeyHashid deckID
encodeRouteHome <- getEncodeRouteHome
return $ encodeRouteHome $ DeckR deckHash
unless (uMe == ObjURI h luTracker) $
throwE "The created tracker id isn't me"
deckCreateMe now deckID verse
_ -> throwE "Unsupported Create object for Deck"
-- Meaning: An actor A is offering a ticket or a ticket dependency -- Meaning: An actor A is offering a ticket or a ticket dependency
-- Behavior: -- Behavior:
-- * Verify I'm the target -- * Verify I'm the target
@ -822,11 +786,10 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
deckBehavior :: UTCTime -> DeckId -> ActorMessage Deck -> ActE (Text, Act (), Next) deckBehavior :: UTCTime -> DeckId -> ActorMessage Deck -> ActE (Text, Act (), Next)
deckBehavior now deckID (MsgD verse@(Verse _authorIdMsig body)) = deckBehavior now deckID (DeckMsgVerse verse@(Verse _authorIdMsig body)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
AP.AcceptActivity accept -> deckAccept now deckID verse accept AP.AcceptActivity accept -> deckAccept now deckID verse accept
AP.AddActivity add -> deckAdd now deckID verse add AP.AddActivity add -> deckAdd now deckID verse add
AP.CreateActivity create -> deckCreate now deckID verse create
AP.FollowActivity follow -> deckFollow now deckID verse follow AP.FollowActivity follow -> deckFollow now deckID verse follow
AP.GrantActivity grant -> deckGrant now deckID verse grant AP.GrantActivity grant -> deckGrant now deckID verse grant
AP.InviteActivity invite -> deckInvite now deckID verse invite AP.InviteActivity invite -> deckInvite now deckID verse invite
@ -838,6 +801,9 @@ deckBehavior now deckID (MsgD verse@(Verse _authorIdMsig body)) =
AP.RevokeActivity revoke -> deckRevoke now deckID verse revoke AP.RevokeActivity revoke -> deckRevoke now deckID verse revoke
AP.UndoActivity undo -> deckUndo now deckID verse undo AP.UndoActivity undo -> deckUndo now deckID verse undo
_ -> throwE "Unsupported activity type for Deck" _ -> throwE "Unsupported activity type for Deck"
deckBehavior now deckID (DeckMsgInit creator) =
let grabResource = fmap komponentResource . getJust . deckKomponent
in topicInit grabResource LocalResourceDeck now deckID creator
instance VervisActorLaunch Deck where instance VervisActorLaunch Deck where
actorBehavior' now deckID ve = do actorBehavior' now deckID ve = do

412
src/Vervis/Actor/Factory.hs
View file

@ -18,43 +18,451 @@ module Vervis.Actor.Factory
) )
where where
import Control.Applicative
import Control.Exception.Base
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable import Data.Foldable
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock import Data.Time.Clock
import Data.Traversable
import Database.Persist import Database.Persist
import Database.Persist.Sql
import Optics.Core
import Yesod.Persist.Core import Yesod.Persist.Core
import qualified Data.Text as T import qualified Data.Text as T
import qualified Database.Esqueleto as E
import Control.Concurrent.Actor import Control.Concurrent.Actor
import Network.FedURI import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Yesod.MonadSite import Yesod.MonadSite
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Database.Persist.Local import Database.Persist.Local
import Vervis.Access
import Vervis.ActivityPub
import Vervis.Actor import Vervis.Actor
import Vervis.Actor.Common
import Vervis.Actor.Deck
import Vervis.Actor.Group
import Vervis.Actor.Project
import Vervis.Actor2
import Vervis.Cloth
import Vervis.Data.Actor
import Vervis.Data.Collab
import Vervis.Data.Discussion import Vervis.Data.Discussion
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
import Vervis.RemoteActorStore
import Vervis.Persist.Actor import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Persist.Discussion import Vervis.Persist.Discussion
import Vervis.Settings
import Vervis.Ticket
import Vervis.Web.Collab
data NewActor = NADeck | NAProject | NATeam
factoryCreateMe
:: UTCTime
-> FactoryId
-> Verse
-> ActE (Text, Act (), Next)
factoryCreateMe = topicCreateMe True True factoryResource LocalResourceFactory
-- Meaning: An actor is asking me to create a new actor
-- Behavior:
-- * Create a record on DB
-- * Launch the actor
-- * Forward the Create to followers
-- * Send Accept on the Create, with result being the new actor's URI
factoryCreateNew
:: NewActor
-> UTCTime
-> FactoryId
-> Verse
-> AP.ActorDetail
-> ActE (Text, Act (), Next)
factoryCreateNew new now factoryMeID (Verse authorIdMsig body) detail = do
-- Check input
(name, msummary) <- parseDetail detail
-- Verify that a capability is provided
uCap <- do
let muCap = AP.activityCapability $ actbActivity body
fromMaybeE muCap "No capability provided"
-- Verify the sender is authorized by me to create actors
verifyCapability''
uCap
authorIdMsig
(LocalResourceFactory factoryMeID)
AP.RoleWrite
maybeNew <- withDBExcept $ do
-- Grab me from DB
factoryMe <- lift $ getJust factoryMeID
let resourceMeID = factoryResource factoryMe
Resource actorMeID <- lift $ getJust resourceMeID
actorMe <- lift $ getJust actorMeID
-- Insert the Create to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False
for mractid $ \ (inboxItemID, createDB) -> do
-- Insert new actor to DB
(newLocalResource, launchNewActor, sendInit, newResourceID) <-
insertNewActor now name msummary createDB actorMeID
-- Prepare forwarding the Create to my followers
factoryHash <- encodeKeyHashid factoryMeID
let sieve =
makeRecipientSet
[]
[LocalStageFactoryFollowers factoryHash]
-- Prepare an Accept activity and insert to my outbox
acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
accept@(actionAccept, _, _, _) <- lift $ prepareAccept newLocalResource
let recipByKey = LocalActorFactory factoryMeID
_luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept
return (actorMeID, sieve, acceptID, accept, inboxItemID, launchNewActor, sendInit)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (actorMeID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID, launchNewActor, sendInit) -> do
-- Spawn new actor
success <- lift launchNewActor
unless success $
error "Failed to spawn new actor, somehow ID already in Theater"
-- Forward Create to my followers
forwardActivity
authorIdMsig body (LocalActorFactory factoryMeID) actorMeID sieve
-- Send Accept back to sender
lift $ sendActivity
(LocalActorFactory factoryMeID) actorMeID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
-- Send message to new actor, for it to self-initialize
there <- lift sendInit
unless there $
error "Failed to find new actor, somehow ID not in Theater"
doneDB inboxItemID "Inserted and launched new actor in just-been-created mode, and sent my Accept"
where
naToActorType = \case
NADeck -> AP.ActorTypeTicketTracker
NAProject -> AP.ActorTypeProject
NATeam -> AP.ActorTypeTeam
parseDetail (AP.ActorDetail typ muser mname msummary) = do
unless (typ == naToActorType new) $
error "factoryCreate: Create object not the expected value"
verifyNothingE muser "Can't have a username"
name <- fromMaybeE mname "Doesn't specify name"
return (name, msummary)
findWorkflow = do
mw <- lift $ selectFirst ([] :: [Filter Workflow]) []
entityKey <$> fromMaybeE mw "Can't find a workflow"
insertNewActor now name msummary createDB actorMeID = do
wid <- findWorkflow
Entity aid a <- lift $ insertActor now name (fromMaybe "" msummary) createDB
rid <- lift $ insert $ Resource aid
let authorId = second (\ (ra, lu, _) -> (ra, lu)) authorIdMsig
(lr, launch, sendInit) <-
lift $
case new of
NADeck -> do
kid <- insert $ Komponent rid
did <- insert Deck
{ deckActor = aid
, deckResource = rid
, deckKomponent = kid
, deckWorkflow = wid
, deckNextTicket = 1
, deckWiki = Nothing
}
return
( LocalResourceDeck did
, launchActor did
, send did $ DeckMsgInit authorId
)
NAProject -> do
jid <- insert Project
{ projectActor = aid
, projectResource = rid
}
return
( LocalResourceProject jid
, launchActor jid
, send jid $ ProjectMsgInit authorId
)
NATeam -> do
gid <- insert Group
{ groupActor = aid
, groupResource = rid
}
return
( LocalResourceGroup gid
, launchActor gid
, send gid $ TeamMsgInit authorId
)
return (lr, launch, sendInit, rid)
prepareAccept newLocalResource = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
factoryHash <- encodeKeyHashid factoryMeID
newLocalActorHash <- hashLocalActor $ resourceToActor newLocalResource
audSender <- makeAudSenderWithFollowers authorIdMsig
let audMe = AudLocal [] [LocalStageFactoryFollowers factoryHash]
--audNew = AudLocal [newLocalActorHash] []
uCreate <- lift $ getActivityURI authorIdMsig
let luNew = encodeRouteLocal $ renderLocalActor newLocalActorHash
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audSender, audMe{-, audNew-}]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uCreate]
, AP.actionSpecific = AP.AcceptActivity AP.Accept
{ AP.acceptObject = uCreate
, AP.acceptResult = Just luNew
}
}
return (action, recipientSet, remoteActors, fwdHosts)
factoryCreate
:: UTCTime
-> FactoryId
-> Verse
-> AP.Create URIMode
-> ActE (Text, Act (), Next)
factoryCreate now factoryID verse (AP.Create obj muOrigin) = do
uMe <- do
encodeRouteHome <- getEncodeRouteHome
factoryHash <- encodeKeyHashid factoryID
return $ encodeRouteHome $ FactoryR factoryHash
case obj of
AP.CreateTicketTracker detail mlocal -> do
verifyNothingE mlocal "Object's id must not be provided"
uOrigin <- fromMaybeE muOrigin "'origin' expected in Create-TicketTracker"
unless (uOrigin == uMe) $
throwE "This Create-TicketTracker isn't for me"
factoryCreateNew NADeck now factoryID verse detail
AP.CreateProject detail mlocal -> do
verifyNothingE mlocal "Object's id must not be provided"
uOrigin <- fromMaybeE muOrigin "'origin' expected in Create-Project"
unless (uOrigin == uMe) $
throwE "This Create-Project isn't for me"
factoryCreateNew NAProject now factoryID verse detail
AP.CreateTeam detail mlocal -> do
verifyNothingE mlocal "Object's id must not be provided"
uOrigin <- fromMaybeE muOrigin "'origin' expected in Create-Team"
unless (uOrigin == uMe) $
throwE "This Create-Team isn't for me"
factoryCreateNew NATeam now factoryID verse detail
AP.CreateFactory _ mlocal -> do
(h, local) <- fromMaybeE mlocal "No factory id provided"
let luFactory = AP.actorId local
unless (uMe == ObjURI h luFactory) $
throwE "The created factory id isn't me"
factoryCreateMe now factoryID verse
_ -> throwE "Unsupported Create object for Factory"
-- Meaning: A local account just for verified
-- Behavior:
-- If I’m a resident, OR no-residents-listed-and-I’m-the-only-factory,
-- send a write-Grant to new Person and insert Collab record
factoryCheckPerson
:: UTCTime
-> FactoryId
-> PersonId
-> ActE (Text, Act (), Next)
factoryCheckPerson now factoryMeID personID = do
result <- withDBExcept $ do
-- Grab me from DB
factoryMe <- lift $ getJust factoryMeID
let resourceMeID = factoryResource factoryMe
Resource actorMeID <- lift $ getJust resourceMeID
actorMe <- lift $ getJust actorMeID
existingCollabs <-
lift $ E.select $ E.from $ \ (collab `E.InnerJoin` recip) -> do
E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
E.where_ $
collab E.^. CollabTopic E.==. E.val resourceMeID E.&&.
recip E.^. CollabRecipLocalPerson E.==. E.val personID
return collab
residents <- asksEnv $ appResidentFactories . envSettings
factoryMeHash <- encodeKeyHashid factoryMeID
let meHashText = keyHashidText factoryMeHash
factoryIDs <- lift $ selectKeysList [] []
let meResident =
meHashText `elem` residents ||
null residents && factoryIDs == [factoryMeID]
if not meResident
then pure $ Left "I'm not a resident, nothing to do"
else if not $ null existingCollabs
then pure $ Left "I'm a resident but already have a Collab for this person, so nothing to do"
else lift $ Right <$> do
p <- getJust personID
grantID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
insertResidentCollab resourceMeID grantID
grant@(actionGrant, _, _, _) <- prepareResidentGrant p
let recipByKey = LocalActorFactory factoryMeID
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
return (actorMeID, grantID, grant)
case result of
Left msg -> done msg
Right (actorMeID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
lift $ sendActivity
(LocalActorFactory factoryMeID) actorMeID localRecipsGrant
remoteRecipsGrant fwdHostsGrant grantID actionGrant
done "Sent write-Grant to person and inserted Collab record"
where
insertResidentCollab resourceMeID grantID = do
collabID <- insert $ Collab AP.RoleWrite resourceMeID
insert_ $ CollabEnable collabID grantID
insert_ $ CollabRecipLocal collabID personID
insert_ $ CollabFulfillsResidentFactory collabID
prepareResidentGrant person = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
personHash <- encodeKeyHashid personID
let audPerson = AudLocal [LocalActorPerson personHash] []
meHash <- encodeKeyHashid factoryMeID
uCreate <- do
selfCreateID <- do
mc <- getValBy $ UniqueActorCreateLocalActor $ personActor person
case mc of
Nothing -> error "Person doesn't have an ActorCreateLocal record"
Just c -> pure $ actorCreateLocalCreate c
createHash <- encodeKeyHashid selfCreateID
return $ encodeRouteHome $ PersonOutboxItemR personHash createHash
let topicByHash = LocalActorFactory meHash
audience =
let audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audPerson, audTopic]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience audience
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uCreate]
, AP.actionSpecific = AP.GrantActivity AP.Grant
{ AP.grantObject = AP.RXRole AP.RoleWrite
, AP.grantContext =
encodeRouteHome $ renderLocalActor topicByHash
, AP.grantTarget = encodeRouteHome $ PersonR personHash
, AP.grantResult = Nothing
, AP.grantStart = Just now
, AP.grantEnd = Nothing
, AP.grantAllows = AP.Invoke
, AP.grantDelegates = Nothing
}
}
return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: An actor is following someone/something
-- Behavior:
-- * Verify the target is me
-- * Record the follow in DB
-- * Publish and send an Accept to the sender and its followers
factoryFollow
:: UTCTime
-> FactoryId
-> Verse
-> AP.Follow URIMode
-> ActE (Text, Act (), Next)
factoryFollow now recipFactoryID verse follow = do
recipFactoryHash <- encodeKeyHashid recipFactoryID
actorFollow'
(\case
FactoryR d | d == recipFactoryHash -> pure ()
_ -> throwE "Asking to follow someone else"
)
(fmap resourceActor . getJust . factoryResource)
False
(\ recipFactoryActor () -> pure $ actorFollowers recipFactoryActor)
(\ _ -> pure $ makeRecipientSet [] [])
LocalActorFactory
(\ _ -> pure [])
now recipFactoryID verse follow
factoryBehavior :: UTCTime -> FactoryId -> ActorMessage Factory -> ActE (Text, Act (), Next) factoryBehavior :: UTCTime -> FactoryId -> ActorMessage Factory -> ActE (Text, Act (), Next)
factoryBehavior now factoryID (MsgF _verse@(Verse _authorIdMsig body)) = factoryBehavior now factoryID (FactoryMsgVerse verse@(Verse _authorIdMsig body)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
AP.CreateActivity create -> factoryCreate now factoryID verse create
AP.FollowActivity follow -> factoryFollow now factoryID verse follow
_ -> throwE "Unsupported activity type for Factory" _ -> throwE "Unsupported activity type for Factory"
factoryBehavior now factoryID (FactoryMsgVerified personID) =
factoryCheckPerson now factoryID personID
instance VervisActorLaunch Factory where instance VervisActorLaunch Factory where
actorBehavior' now factoryID ve = do actorBehavior' now factoryID ve = do

44
src/Vervis/Actor/Group.hs
View file

@ -71,7 +71,7 @@ import Vervis.Data.Discussion
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model hiding (groupCreate) import Vervis.Model
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor) import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Persist.Actor import Vervis.Persist.Actor
@ -2441,42 +2441,6 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: Someone has created a group with my ID URI
-- Behavior:
-- * Verify I'm in a just-been-created state
-- * Verify my creator and the Create sender are the same actor
-- * Create an admin Collab record in DB
-- * Send an admin Grant to the creator
-- * Get out of the just-been-created state
groupCreateMe
:: UTCTime
-> GroupId
-> Verse
-> ActE (Text, Act (), Next)
groupCreateMe = topicCreateMe groupResource LocalResourceGroup
groupCreate
:: UTCTime
-> GroupId
-> Verse
-> AP.Create URIMode
-> ActE (Text, Act (), Next)
groupCreate now groupID verse (AP.Create obj _muTarget) =
case obj of
AP.CreateTeam _ mlocal -> do
(h, local) <- fromMaybeE mlocal "No group id provided"
let luGroup = AP.actorId local
uMe <- do
groupHash <- encodeKeyHashid groupID
encodeRouteHome <- getEncodeRouteHome
return $ encodeRouteHome $ GroupR groupHash
unless (uMe == ObjURI h luGroup) $
throwE "The created group id isn't me"
groupCreateMe now groupID verse
_ -> throwE "Unsupported Create object for Group"
-- Meaning: An actor is following someone/something -- Meaning: An actor is following someone/something
-- Behavior: -- Behavior:
-- * Verify the target is me -- * Verify the target is me
@ -5927,11 +5891,10 @@ groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
groupBehavior :: UTCTime -> GroupId -> ActorMessage Group -> ActE (Text, Act (), Next) groupBehavior :: UTCTime -> GroupId -> ActorMessage Group -> ActE (Text, Act (), Next)
groupBehavior now groupID (MsgG verse@(Verse _authorIdMsig body)) = groupBehavior now groupID (TeamMsgVerse verse@(Verse _authorIdMsig body)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
AP.AcceptActivity accept -> groupAccept now groupID verse accept AP.AcceptActivity accept -> groupAccept now groupID verse accept
AP.AddActivity add -> groupAdd now groupID verse add AP.AddActivity add -> groupAdd now groupID verse add
AP.CreateActivity create -> groupCreate now groupID verse create
AP.FollowActivity follow -> groupFollow now groupID verse follow AP.FollowActivity follow -> groupFollow now groupID verse follow
AP.GrantActivity grant -> groupGrant now groupID verse grant AP.GrantActivity grant -> groupGrant now groupID verse grant
AP.InviteActivity invite -> groupInvite now groupID verse invite AP.InviteActivity invite -> groupInvite now groupID verse invite
@ -5941,6 +5904,9 @@ groupBehavior now groupID (MsgG verse@(Verse _authorIdMsig body)) =
AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke
AP.UndoActivity undo -> groupUndo now groupID verse undo AP.UndoActivity undo -> groupUndo now groupID verse undo
_ -> throwE "Unsupported activity type for Group" _ -> throwE "Unsupported activity type for Group"
groupBehavior now groupID (TeamMsgInit creator) =
let grabResource = pure . groupResource
in topicInit grabResource LocalResourceGroup now groupID creator
instance VervisActorLaunch Group where instance VervisActorLaunch Group where
actorBehavior' now groupID ve = do actorBehavior' now groupID ve = do

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

@ -72,11 +72,12 @@ import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Persist.Actor import Vervis.Persist.Actor
import Vervis.Persist.Collab import Vervis.Persist.Collab
import Vervis.Persist.Discussion import Vervis.Persist.Discussion
import Vervis.Persist.Follow import Vervis.Persist.Follow
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience) import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, renderLocalActor)
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Ticket import Vervis.Ticket
@ -282,13 +283,19 @@ personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do
-- Meaning: An actor accepted something -- Meaning: An actor accepted something
-- Behavior: -- Behavior:
-- * Insert to my inbox -- * Insert to my inbox
--
-- * If it's on a Follow I sent to them: -- * If it's on a Follow I sent to them:
-- * Add to my following list in DB -- * Add to my following list in DB
--
-- * If it's on an Invite-for-me to collaborate on a resource: -- * If it's on an Invite-for-me to collaborate on a resource:
-- * Verify I haven't yet seen the resource's accept -- * Verify I haven't yet seen the resource's accept
-- * Verify the Accept author is the resource -- * Verify the Accept author is the resource
-- * Store it in the Permit record in DB -- * Store it in the Permit record in DB
-- * Forward to my followers -- * Forward to my followers
--
-- * If it's on a Create-actor-via-factory I'd sent
-- * Insert PermitTopic*
-- * Send a Follow on the newly created actor
personAccept personAccept
:: UTCTime :: UTCTime
-> PersonId -> PersonId
@ -300,6 +307,34 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
-- Check input -- Check input
acceptee <- parseAccept accept acceptee <- parseAccept accept
-- Discover Accept.result, before DB access since we might use HTTP
maybeRightResult <-
for (AP.acceptResult accept) $ \ luResult -> lift $ runExceptT $ do
let h = objUriAuthority $ AP.acceptObject accept
uResult = ObjURI h luResult
routeOrRemote <- parseFedURI uResult
bitraverse
(\ route -> do
lr <- parseLocalResourceE' route
resourceID <- withDBExcept $ do
lre <- getLocalResourceEntityE lr "Local Accept.result actor not found in DB"
lift $ grabLocalResourceID lre
return (lr, resourceID)
)
(\ u@(ObjURI h lu) -> do
instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
result <-
ExceptT $ first (T.pack . displayException) <$>
fetchRemoteActor' instanceID h lu
case result of
Left Nothing -> throwE "Result @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Result isn't an actor"
Right (Just actor) -> return (u, actor)
)
routeOrRemote
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
@ -314,26 +349,113 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
accepteeDB <- MaybeT $ getActivity acceptee accepteeDB <- MaybeT $ getActivity acceptee
let recipActorID = personActor personRecip let recipActorID = personActor personRecip
Left <$> tryFollow recipActorID accepteeDB acceptDB <|> Left . Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
Right <$> tryInvite recipActorID accepteeDB acceptDB Left . Right <$> tryInvite recipActorID accepteeDB acceptDB <|>
Right <$> tryCreate maybeRightResult recipActorID accepteeDB acceptDB
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (inboxItemID, result) -> Just (inboxItemID, result) ->
case result of case result of
Nothing -> doneDB inboxItemID "Not my Follow/Invite; Just inserted to my inbox" Nothing -> doneDB inboxItemID "Not my Follow/Invite; Just inserted to my inbox"
Just (Left ()) -> Just (Left (Left ())) ->
doneDB inboxItemID "Recorded this Accept on the Follow request I sent" doneDB inboxItemID "Recorded this Accept on the Follow request I sent"
Just (Right (actorID, sieve)) -> do Just (Left (Right (actorID, sieve))) -> do
forwardActivity forwardActivity
authorIdMsig body (LocalActorPerson recipPersonID) authorIdMsig body (LocalActorPerson recipPersonID)
actorID sieve actorID sieve
doneDB inboxItemID doneDB inboxItemID
"Recorded this Accept on the Invite I've had & \ "Recorded this Accept on the Invite I've had & \
\forwarded to my followers" \forwarded to my followers"
Just (Right Nothing) ->
doneDB inboxItemID "Inserted PermitTopic*, Follow/Request already exists"
Just (Right (Just (actorMeID, followID, follow))) -> do
let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
lift $ sendActivity
(LocalActorPerson recipPersonID) actorMeID localRecipsFollow
remoteRecipsFollow fwdHostsFollow followID actionFollow
doneDB inboxItemID "Inserted PermitTopic* & sent Follow"
where where
tryCreate maybeRightResult actorMeID (Left (_, _, outboxItemID)) _ = do
-- Verify Accept specifies a result
result <- do
r <- hoistMaybe maybeRightResult
case r of
Left e -> lift $ throwE e
Right actor -> pure actor
-- Find an admin-Permit-Fulfills-Create I have
PermitPersonGesture permitID _ <-
MaybeT $ lift $ getValBy $ UniquePermitPersonGestureActivity outboxItemID
_ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID
Permit p role <- lift $ lift $ getJust permitID
guard $ p == recipPersonID
guard $ role == AP.RoleAdmin
-- Grab the Create's origin, verify it's identical to Accept sender
AP.Doc _ act <- lift $ lift $ getActivityBody $ Left outboxItemID
uOrigin <-
case AP.activitySpecific act of
AP.CreateActivity (AP.Create _ (Just u)) -> pure u
_ -> lift $ throwE "Expected acceptee to be a Create with origin"
uAcceptSender <- lift $ lift $ lift $ getActorURI authorIdMsig
unless (uAcceptSender == uOrigin) $
lift $ throwE "Accept sender isn't the Create.origin"
-- Verify permit topic is missing
mptl <- lift $ lift $ getBy $ UniquePermitTopicLocal permitID
mptr <- lift $ lift $ getBy $ UniquePermitTopicRemote permitID
unless (isNothing mptl && isNothing mptr) $
lift $ throwE "PermitTopic* already exists in DB"
-- Insert permit topic, the new actor
lift $ lift $
case result of
Left (_, resourceID) ->
insert_ $ PermitTopicLocal permitID resourceID
Right (_, Entity actorID _) ->
insert_ $ PermitTopicRemote permitID actorID
lift $ lift $ do
-- Look for an existing follow/request record in DB
existing <-
case result of
Left (_, resourceID) -> do
Resource actorNewID <- getJust resourceID
fsID <- actorFollowers <$> getJust actorNewID
mf <- getBy $ UniqueFollow actorMeID fsID
mfr <- getBy $ UniqueFollowRequest actorMeID fsID
return $ isJust mf || isJust mfr
Right (uNewActor, _) -> do
mf <- getBy $ UniqueFollowRemote actorMeID uNewActor
mfr <- getBy $ UniqueFollowRemoteRequest recipPersonID uNewActor
return $ isJust mf || isJust mfr
-- If none, insert request and prepare Follow activity
if existing
then pure Nothing
else Just <$> do
actorMe <- getJust actorMeID
followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
case result of
Left (_, resourceID) -> do
Resource actorNewID <- getJust resourceID
fsID <- actorFollowers <$> getJust actorNewID
insert_ $ FollowRequest actorMeID fsID True followID
Right (uNewActor, _) ->
insert_ $ FollowRemoteRequest recipPersonID uNewActor Nothing True followID
follow@(actionFollow, _, _, _) <- lift $ prepareFollow result
luFollow <- updateOutboxItem' (LocalActorPerson recipPersonID) followID actionFollow
return (actorMeID, followID, follow)
tryCreate _ _ (Right _) _ = mzero
tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do
Entity key val <- Entity key val <-
MaybeT $ lift $ MaybeT $ lift $
@ -435,6 +557,37 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
return (recipActorID, sieve) return (recipActorID, sieve)
prepareFollow result = do
encodeRouteHome <- getEncodeRouteHome
(uNewActor, audNewActor) <-
case result of
Left (lr, _) -> do
la <- resourceToActor <$> hashLocalResource lr
return
( encodeRouteHome $ renderLocalActor la
, AudLocal [la] []
)
Right (u@(ObjURI h lu), _) ->
return (u, AudRemote h [lu] [])
uAccept <- getActivityURI authorIdMsig
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audNewActor]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uAccept]
, AP.actionSpecific = AP.FollowActivity AP.Follow
{ AP.followObject = uNewActor
, AP.followContext = Nothing
, AP.followHide = False
}
}
return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: An actor rejected something -- Meaning: An actor rejected something
-- Behavior: -- Behavior:
-- * Insert to my inbox -- * Insert to my inbox
@ -806,6 +959,11 @@ personJoin now recipPersonID (Verse authorIdMsig body) join = do
-- Behavior: -- Behavior:
-- * Insert to my inbox -- * Insert to my inbox
-- --
-- * If it's a developer direct-Grant from a local Factory, and there's no
-- Permit record:
-- * Insert a Permit record, storing the direct-Grant
-- * Forward the direct-Grant to my followers
--
-- * If it's a direct-Grant that fulfills a Permit I have: -- * If it's a direct-Grant that fulfills a Permit I have:
-- * Verify the Permit isn't already enabled -- * Verify the Permit isn't already enabled
-- * Verify the sender is the Permit topic -- * Verify the sender is the Permit topic
@ -924,6 +1082,11 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
(personRecip, actorRecip) <- lift $ do (personRecip, actorRecip) <- lift $ do
p <- getJust recipPersonID p <- getJust recipPersonID
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
selfCreateID <- lift $ do
mc <- getValBy $ UniqueActorCreateLocalActor $ personActor personRecip
case mc of
Nothing -> error "I don't have an ActorCreateLocal record"
Just c -> pure $ actorCreateLocalCreate c
maybePermit <- maybePermit <-
for maybeMine' $ for maybeMine' $
@ -934,39 +1097,45 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
fulfillsDB <- do fulfillsDB <- do
a <- getActivity fulfills a <- getActivity fulfills
fromMaybeE a "Can't find fulfills in DB" fromMaybeE a "Can't find fulfills in DB"
(permitID, maybeGestureID) <- do mp <- runMaybeT $ do
mp <- runMaybeT $ do x@(pt, mg) <-
x@(pt, mg) <- tryInvite fulfillsDB <|>
tryInvite fulfillsDB <|> tryJoin fulfillsDB <|>
tryJoin fulfillsDB <|> tryCreate fulfillsDB
tryCreate fulfillsDB Permit p role' <- lift . lift $ getJust pt
Permit p role' <- lift . lift $ getJust pt guard $ p == recipPersonID
guard $ p == recipPersonID lift $ unless (role == AP.RXRole role') $
lift $ unless (role == AP.RXRole role') $ throwE "Requested and granted roles differ"
throwE "Requested and granted roles differ" return x
return x case mp of
fromMaybeE mp "Can't find a PermitFulfills*" Just (permitID, maybeGestureID) -> do
-- If Permit fulfills an Invite, verify I've approved -- If Permit fulfills an Invite, verify I've approved
-- it -- it
gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite" gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite"
-- Verify the Permit isn't already enabled -- Verify the Permit isn't already enabled
topic <- lift $ getPermitTopic permitID topic <- lift $ getPermitTopic permitID
maybeTopicEnable <- maybeTopicEnable <-
lift $ case bimap fst fst topic of lift $ case bimap fst fst topic of
Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID) Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID) Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
unless (isNothing maybeTopicEnable) $ unless (isNothing maybeTopicEnable) $
throwE "I've already received the direct-Grant" throwE "I've already received the direct-Grant"
-- Verify the Grant sender is the Permit topic -- Verify the Grant sender is the Permit topic
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
(Left la, Left la') | resourceToActor la == la' -> pure () (Left la, Left la') | resourceToActor la == la' -> pure ()
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure () (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
_ -> throwE "Grant sender isn't the Permit topic" _ -> throwE "Grant sender isn't the Permit topic"
return (gestureID, bimap fst fst topic) return $ Left (gestureID, bimap fst fst topic)
Nothing -> do
case (authorIdMsig, role) of
(Left (LocalActorFactory factoryID, actorID, grantID), AP.RXRole AP.RoleWrite) ->
return $ Right (factoryID, actorID, grantID)
_ -> throwE "No Permit found & sender-and-role not local-Factory-and-write"
) )
(\ (resourceDB, role, delegatorID) -> do (\ (resourceDB, role, delegatorID) -> do
Entity sendID (PermitPersonSendDelegator gestureID _) <- do Entity sendID (PermitPersonSendDelegator gestureID _) <- do
@ -990,7 +1159,19 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
fmap (inboxItemID,) $ fmap (inboxItemID,) $
for maybePermit $ for maybePermit $
bitraverse bitraverse
(\ (gestureID, topic) -> lift $ do (\ mode -> lift $ do
-- In factory-mode, we need to create a Permit record
(gestureID, topic) <-
case mode of
Left permit -> pure permit
Right (factoryID, _actorID, _grantID) -> do
resourceID <- factoryResource <$> getJust factoryID
permitID <- insert $ Permit recipPersonID AP.RoleWrite
topicID <- insert $ PermitTopicLocal permitID resourceID
insert_ $ PermitFulfillsResidentFactory permitID
gestureID <- insert $ PermitPersonGesture permitID selfCreateID
return (gestureID, Left topicID)
-- Update the Permit record, storing the direct-Grant -- Update the Permit record, storing the direct-Grant
case (topic, grantDB) of case (topic, grantDB) of
@ -1072,7 +1253,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
sendActivity sendActivity
recipByID recipActorID localRecipsDeleg recipByID recipActorID localRecipsDeleg
remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg
doneDB inboxItemID "Forwarded the direct-Grant, updated Permit, maybe published delegator-Grant" doneDB inboxItemID "Forwarded the direct-Grant, created/updated Permit, maybe published delegator-Grant"
Just (Right ()) -> Just (Right ()) ->
doneDB inboxItemID "Got an extension-Grant, updated Permit" doneDB inboxItemID "Got an extension-Grant, updated Permit"
@ -1316,8 +1497,80 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
-- Main behavior function -- Main behavior function
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Meaning: I've just been verified
-- Behavior: Publish a Create-self activity & record ActorCreateLocal in DB
personInit
:: UTCTime
-> PersonId
-> ActE (Text, Act (), Next)
personInit now personMeID = do
_ <- withDBExcept $ do
-- Grab me from DB
personMe <- lift $ getJust personMeID
let actorMeID = personActor personMe
actorMe <- lift $ getJust actorMeID
-- Grab ActorCreate* record, make sure it doesn't exist
ml <- lift $ getKeyBy $ UniqueActorCreateLocalActor actorMeID
mr <- lift $ getKeyBy $ UniqueActorCreateRemoteActor actorMeID
unless (isNothing ml && isNothing mr) $
throwE "ActorCreate* already exists"
-- Prepare a Create activity and insert to my outbox
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
create@(actionCreate, _, _, _) <- lift $ lift $ prepareCreate personMe actorMe
_luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
return (actorMeID, createID, create)
-- Not sending the activity anywhere
done "Published a Create-self activity"
where
prepareCreate personMe actorMe = do
hLocal <- asksEnv stageInstanceHost
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
personMeHash <- encodeKeyHashid personMeID
let audMe = AudLocal [] [LocalStagePersonFollowers personMeHash]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audMe]
recips = map encodeRouteHome audLocal ++ audRemote
pdetail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeTicketTracker
, AP.actorUsername = Just $ username2text $ personUsername personMe
, AP.actorName = Just $ actorName actorMe
, AP.actorSummary = Just $ actorDesc actorMe
}
plocal = AP.ActorLocal
{ AP.actorId = encodeRouteLocal $ PersonR personMeHash
, AP.actorInbox = encodeRouteLocal $ PersonInboxR personMeHash
, AP.actorOutbox = Nothing
, AP.actorFollowers = Nothing
, AP.actorFollowing = Nothing
, AP.actorPublicKeys = []
, AP.actorSshKeys = []
}
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = []
, AP.actionSpecific = AP.CreateActivity AP.Create
{ AP.createObject = AP.CreatePerson pdetail (Just (hLocal, plocal))
, AP.createOrigin = Nothing
}
}
return (action, recipientSet, remoteActors, fwdHosts)
personBehavior :: UTCTime -> PersonId -> ActorMessage Person -> ActE (Text, Act (), Next) personBehavior :: UTCTime -> PersonId -> ActorMessage Person -> ActE (Text, Act (), Next)
personBehavior now personID (MsgP (Left verse@(Verse _authorIdMsig body))) = personBehavior now personID (PersonMsgVerse verse@(Verse _authorIdMsig body)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
AP.AcceptActivity accept -> personAccept now personID verse accept AP.AcceptActivity accept -> personAccept now personID verse accept
AP.AddActivity add -> personAdd now personID verse add AP.AddActivity add -> personAdd now personID verse add
@ -1337,7 +1590,8 @@ personBehavior now personID (MsgP (Left verse@(Verse _authorIdMsig body))) =
AP.RevokeActivity revoke -> personRevoke now personID verse revoke AP.RevokeActivity revoke -> personRevoke now personID verse revoke
AP.UndoActivity undo -> personUndo now personID verse undo AP.UndoActivity undo -> personUndo now personID verse undo
_ -> throwE "Unsupported activity type for Person" _ -> throwE "Unsupported activity type for Person"
personBehavior now personID (MsgP (Right msg)) = clientBehavior now personID msg personBehavior now personID (PersonMsgClient msg) = clientBehavior now personID msg
personBehavior now personID PersonMsgInit = personInit now personID
instance VervisActorLaunch Person where instance VervisActorLaunch Person where
actorBehavior' now personID ve = do actorBehavior' now personID ve = do

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

@ -358,26 +358,35 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
fwdHosts addID action fwdHosts addID action
return addID return addID
-- Meaning: The human wants to create a ticket tracker -- Meaning: The human wants to create an actor via a Factory
-- Behavior: -- Behavior:
-- * Create a deck on DB -- * Ensure the origin is addressed
-- * Create a Permit record in DB -- * Insert Create to outbox
-- * Launch a deck actor -- * Create an open permit record
-- * Record a FollowRequest in DB -- * Send the Create to recipients
-- * Create and send Create and Follow to it clientCreateActor
clientCreateDeck
:: UTCTime :: UTCTime
-> PersonId -> PersonId
-> ClientMsg -> ClientMsg
-> AP.ActorDetail -> AP.ActorDetail
-> FedURI
-> ActE OutboxItemId -> ActE OutboxItemId
clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do clientCreateActor now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) detail uOrigin = do
-- Check input -- Check input
verifyNothingE maybeCap "Capability not needed" _ <- fromMaybeE maybeCap "Capability not provided"
(name, msummary) <- parseTracker tracker _ <- parseDetail detail
origin <- do
routeOrRemote <- parseFedURI uOrigin
bitraverse parseLocalActorE' pure routeOrRemote
(actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, deckID) <- withDBExcept $ do -- Verify origin is addressed
bitraverse_
(verifyActorAddressed localRecips)
(verifyRemoteAddressed remoteRecips)
origin
(actorMeID, createID) <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(personMe, actorMe) <- lift $ do (personMe, actorMe) <- lift $ do
@ -385,455 +394,35 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
let actorMeID = personActor personMe let actorMeID = personActor personMe
-- Insert new deck to DB -- Insert the Create activity to my outbox
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
wid <- findWorkflow _luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID action
(deckID, resourceID, deckFollowerSetID) <-
lift $ insertDeck now name msummary createID wid actorMeID
-- Insert a Permit record -- Insert a partial Permit record, i.e. without topic
-- (Is this a good idea?
-- It's a way to remember the createID for when the Accept from the
-- Factory arrives, which is when we insert the missing topic)
lift $ do lift $ do
permitID <- insert $ Permit personMeID AP.RoleAdmin permitID <- insert $ Permit personMeID AP.RoleAdmin
topicID <- insert $ PermitTopicLocal permitID resourceID
insert_ $ PermitFulfillsTopicCreation permitID insert_ $ PermitFulfillsTopicCreation permitID
insert_ $ PermitPersonGesture permitID createID insert_ $ PermitPersonGesture permitID createID
-- Insert the Create activity to my outbox return (personActor personMe, createID)
deckHash <- encodeKeyHashid deckID
actionCreate <- prepareCreate name msummary deckHash
luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
-- Prepare recipient sieve for sending the Create
personMeHash <- lift $ encodeKeyHashid personMeID
let sieve =
makeRecipientSet
[LocalActorDeck deckHash]
[LocalStagePersonFollowers personMeHash]
onlyDeck = DeckFamilyRoutes (DeckRoutes True False) []
addMe' decks = (deckHash, onlyDeck) : decks
addMe rs = rs { recipDecks = addMe' $ recipDecks rs }
-- Insert a follow request, since I'm about to send a Follow
followID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
lift $ insert_ $ FollowRequest actorMeID deckFollowerSetID True followID
-- Insert a Follow to my outbox
follow@(actionFollow, _, _, _) <- lift $ lift $ prepareFollow deckID luCreate
_luFollow <- lift $ updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
return
( personActor personMe
, localRecipSieve sieve False $ addMe localRecips
, createID
, actionCreate
, followID
, follow
, deckID
)
-- Spawn new Deck actor
success <- lift $ launchActor deckID
unless success $
error "Failed to spawn new Deck, somehow ID already in Theater"
-- Send the Create -- Send the Create
lift $ sendActivity lift $ sendActivity
(LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips (LocalActorPerson personMeID) actorMeID localRecips remoteRecips
fwdHosts createID actionCreate fwdHosts createID action
-- Send the Follow
let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
lift $ sendActivity
(LocalActorPerson personMeID) actorMeID localRecipsFollow
remoteRecipsFollow fwdHostsFollow followID actionFollow
return createID return createID
where where
parseTracker (AP.ActorDetail typ muser mname msummary) = do parseDetail (AP.ActorDetail typ muser mname msummary) = do
unless (typ == AP.ActorTypeTicketTracker) $ verifyNothingE muser "Can't have a username"
error "createTicketTrackerC: Create object isn't a TicketTracker" name <- fromMaybeE mname "Doesn't specify name"
verifyNothingE muser "TicketTracker can't have a username"
name <- fromMaybeE mname "TicketTracker doesn't specify name"
return (name, msummary) return (name, msummary)
findWorkflow = do
mw <- lift $ selectFirst ([] :: [Filter Workflow]) []
entityKey <$> fromMaybeE mw "Can't find a workflow"
insertDeck now name msummary obiidCreate wid actorMeID = do
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID)
rid <- insert $ Resource aid
kid <- insert $ Komponent rid
did <- insert Deck
{ deckActor = aid
, deckResource = rid
, deckKomponent = kid
, deckWorkflow = wid
, deckNextTicket = 1
, deckWiki = Nothing
, deckCreate = obiidCreate
}
return (did, rid, actorFollowers a)
prepareCreate name msummary deckHash = do
encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksEnv stageInstanceHost
let ttdetail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeTicketTracker
, AP.actorUsername = Nothing
, AP.actorName = Just name
, AP.actorSummary = msummary
}
ttlocal = AP.ActorLocal
{ AP.actorId = encodeRouteLocal $ DeckR deckHash
, AP.actorInbox = encodeRouteLocal $ DeckInboxR deckHash
, AP.actorOutbox = Nothing
, AP.actorFollowers = Nothing
, AP.actorFollowing = Nothing
, AP.actorPublicKeys = []
, AP.actorSshKeys = []
}
specific = AP.CreateActivity AP.Create
{ AP.createObject = AP.CreateTicketTracker ttdetail (Just (hLocal, ttlocal))
, AP.createTarget = Nothing
}
return action { AP.actionSpecific = specific }
prepareFollow deckID luCreate = do
encodeRouteHome <- getEncodeRouteHome
h <- asksEnv stageInstanceHost
deckHash <- encodeKeyHashid deckID
let audTopic = AudLocal [LocalActorDeck deckHash] []
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audTopic]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [ObjURI h luCreate]
, AP.actionSpecific = AP.FollowActivity AP.Follow
{ AP.followObject = encodeRouteHome $ DeckR deckHash
, AP.followContext = Nothing
, AP.followHide = False
}
}
return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: The human wants to create a project
-- Behavior:
-- * Create a project on DB
-- * Create a Permit record in DB
-- * Launch a project actor
-- * Record a FollowRequest in DB
-- * Create and send Create and Follow to it
clientCreateProject
:: UTCTime
-> PersonId
-> ClientMsg
-> AP.ActorDetail
-> ActE OutboxItemId
clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do
-- Check input
verifyNothingE maybeCap "Capability not needed"
(name, msummary) <- parseTracker tracker
(actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, projectID) <- lift $ withDB $ do
-- Grab me from DB
(personMe, actorMe) <- do
p <- getJust personMeID
(p,) <$> getJust (personActor p)
let actorMeID = personActor personMe
-- Insert new project to DB
createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
(projectID, resourceID, projectFollowerSetID) <-
insertProject now name msummary createID actorMeID
-- Insert a Permit record
permitID <- insert $ Permit personMeID AP.RoleAdmin
topicID <- insert $ PermitTopicLocal permitID resourceID
insert_ $ PermitFulfillsTopicCreation permitID
insert_ $ PermitPersonGesture permitID createID
-- Insert the Create activity to my outbox
projectHash <- lift $ encodeKeyHashid projectID
actionCreate <- lift $ prepareCreate name msummary projectHash
luCreate <- updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
-- Prepare recipient sieve for sending the Create
personMeHash <- lift $ encodeKeyHashid personMeID
let sieve =
makeRecipientSet
[LocalActorProject projectHash]
[LocalStagePersonFollowers personMeHash]
onlyProject = ProjectRoutes True False
addMe' projects = (projectHash, onlyProject) : projects
addMe rs = rs { recipProjects = addMe' $ recipProjects rs }
-- Insert a follow request, since I'm about to send a Follow
followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
insert_ $ FollowRequest actorMeID projectFollowerSetID True followID
-- Insert a Follow to my outbox
follow@(actionFollow, _, _, _) <- lift $ prepareFollow projectID luCreate
_luFollow <- updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
return
( personActor personMe
, localRecipSieve sieve False $ addMe localRecips
, createID
, actionCreate
, followID
, follow
, projectID
)
-- Spawn new Project actor
success <- lift $ launchActor projectID
unless success $
error "Failed to spawn new Project, somehow ID already in Theater"
-- Send the Create
lift $ sendActivity
(LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
fwdHosts createID actionCreate
-- Send the Follow
let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
lift $ sendActivity
(LocalActorPerson personMeID) actorMeID localRecipsFollow
remoteRecipsFollow fwdHostsFollow followID actionFollow
return createID
where
parseTracker (AP.ActorDetail typ muser mname msummary) = do
unless (typ == AP.ActorTypeProject) $
error "clientCreateProject: Create object isn't a Project"
verifyNothingE muser "Project can't have a username"
name <- fromMaybeE mname "Project doesn't specify name"
return (name, msummary)
insertProject now name msummary obiidCreate actorMeID = do
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID)
rid <- insert $ Resource aid
did <- insert Project
{ projectActor = aid
, projectResource = rid
, projectCreate = obiidCreate
}
return (did, rid, actorFollowers a)
prepareCreate name msummary projectHash = do
encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksEnv stageInstanceHost
let ttdetail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeProject
, AP.actorUsername = Nothing
, AP.actorName = Just name
, AP.actorSummary = msummary
}
ttlocal = AP.ActorLocal
{ AP.actorId = encodeRouteLocal $ ProjectR projectHash
, AP.actorInbox = encodeRouteLocal $ ProjectInboxR projectHash
, AP.actorOutbox = Nothing
, AP.actorFollowers = Nothing
, AP.actorFollowing = Nothing
, AP.actorPublicKeys = []
, AP.actorSshKeys = []
}
specific = AP.CreateActivity AP.Create
{ AP.createObject = AP.CreateProject ttdetail (Just (hLocal, ttlocal))
, AP.createTarget = Nothing
}
return action { AP.actionSpecific = specific }
prepareFollow projectID luCreate = do
encodeRouteHome <- getEncodeRouteHome
h <- asksEnv stageInstanceHost
projectHash <- encodeKeyHashid projectID
let audTopic = AudLocal [LocalActorProject projectHash] []
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audTopic]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [ObjURI h luCreate]
, AP.actionSpecific = AP.FollowActivity AP.Follow
{ AP.followObject = encodeRouteHome $ ProjectR projectHash
, AP.followContext = Nothing
, AP.followHide = False
}
}
return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: The human wants to create a team
-- Behavior:
-- * Create a team on DB
-- * Create a Permit record in DB
-- * Launch a team actor
-- * Record a FollowRequest in DB
-- * Create and send Create and Follow to it
clientCreateTeam
:: UTCTime
-> PersonId
-> ClientMsg
-> AP.ActorDetail
-> ActE OutboxItemId
clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do
-- Check input
verifyNothingE maybeCap "Capability not needed"
(name, msummary) <- parseTracker tracker
(actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, groupID) <- lift $ withDB $ do
-- Grab me from DB
(personMe, actorMe) <- do
p <- getJust personMeID
(p,) <$> getJust (personActor p)
let actorMeID = personActor personMe
-- Insert new team to DB
createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
(groupID, resourceID, projectFollowerSetID) <-
insertTeam now name msummary createID actorMeID
-- Insert a Permit record
permitID <- insert $ Permit personMeID AP.RoleAdmin
topicID <- insert $ PermitTopicLocal permitID resourceID
insert_ $ PermitFulfillsTopicCreation permitID
insert_ $ PermitPersonGesture permitID createID
-- Insert the Create activity to my outbox
groupHash <- lift $ encodeKeyHashid groupID
actionCreate <- lift $ prepareCreate name msummary groupHash
luCreate <- updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
-- Prepare recipient sieve for sending the Create
personMeHash <- lift $ encodeKeyHashid personMeID
let sieve =
makeRecipientSet
[LocalActorGroup groupHash]
[LocalStagePersonFollowers personMeHash]
onlyGroup = GroupRoutes True False
addMe' groups = (groupHash, onlyGroup) : groups
addMe rs = rs { recipGroups = addMe' $ recipGroups rs }
-- Insert a follow request, since I'm about to send a Follow
followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
insert_ $ FollowRequest actorMeID projectFollowerSetID True followID
-- Insert a Follow to my outbox
follow@(actionFollow, _, _, _) <- lift $ prepareFollow groupID luCreate
_luFollow <- updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
return
( personActor personMe
, localRecipSieve sieve False $ addMe localRecips
, createID
, actionCreate
, followID
, follow
, groupID
)
-- Spawn new Group actor
success <- lift $ launchActor groupID
unless success $
error "Failed to spawn new Group, somehow ID already in Theater"
-- Send the Create
lift $ sendActivity
(LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
fwdHosts createID actionCreate
-- Send the Follow
let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
lift $ sendActivity
(LocalActorPerson personMeID) actorMeID localRecipsFollow
remoteRecipsFollow fwdHostsFollow followID actionFollow
return createID
where
parseTracker (AP.ActorDetail typ muser mname msummary) = do
unless (typ == AP.ActorTypeTeam) $
error "clientCreateTeam: Create object isn't a Team"
verifyNothingE muser "Team can't have a username"
name <- fromMaybeE mname "Team doesn't specify name"
return (name, msummary)
insertTeam now name msummary obiidCreate actorMeID = do
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID)
rid <- insert $ Resource aid
gid <- insert Group
{ groupActor = aid
, groupResource = rid
, groupCreate = obiidCreate
}
return (gid, rid, actorFollowers a)
prepareCreate name msummary groupHash = do
encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksEnv stageInstanceHost
let ttdetail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeTeam
, AP.actorUsername = Nothing
, AP.actorName = Just name
, AP.actorSummary = msummary
}
ttlocal = AP.ActorLocal
{ AP.actorId = encodeRouteLocal $ GroupR groupHash
, AP.actorInbox = encodeRouteLocal $ GroupInboxR groupHash
, AP.actorOutbox = Nothing
, AP.actorFollowers = Nothing
, AP.actorFollowing = Nothing
, AP.actorPublicKeys = []
, AP.actorSshKeys = []
}
specific = AP.CreateActivity AP.Create
{ AP.createObject = AP.CreateTeam ttdetail (Just (hLocal, ttlocal))
, AP.createTarget = Nothing
}
return action { AP.actionSpecific = specific }
prepareFollow groupID luCreate = do
encodeRouteHome <- getEncodeRouteHome
h <- asksEnv stageInstanceHost
groupHash <- encodeKeyHashid groupID
let audTopic = AudLocal [LocalActorGroup groupHash] []
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audTopic]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [ObjURI h luCreate]
, AP.actionSpecific = AP.FollowActivity AP.Follow
{ AP.followObject = encodeRouteHome $ GroupR groupHash
, AP.followContext = Nothing
, AP.followHide = False
}
}
return (action, recipientSet, remoteActors, fwdHosts)
-- Meaning: The human wants to create a factory -- Meaning: The human wants to create a factory
-- Behavior: -- Behavior:
-- * Verify human is allowed to -- * Verify human is allowed to
@ -939,11 +528,10 @@ clientCreateFactory now personMeID (ClientMsg maybeCap localRecips remoteRecips
return (name, msummary) return (name, msummary)
insertFactory now name msummary obiidCreate actorMeID = do insertFactory now name msummary obiidCreate actorMeID = do
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID) Entity aid a <- insertActor now name (fromMaybe "" msummary) (Left (LocalActorPerson personMeID, actorMeID, obiidCreate))
rid <- insert $ Resource aid rid <- insert $ Resource aid
fid <- insert Factory fid <- insert Factory
{ factoryResource = rid { factoryResource = rid
, factoryCreate = obiidCreate
} }
return (fid, rid, actorFollowers a) return (fid, rid, actorFollowers a)
@ -967,7 +555,7 @@ clientCreateFactory now personMeID (ClientMsg maybeCap localRecips remoteRecips
} }
specific = AP.CreateActivity AP.Create specific = AP.CreateActivity AP.Create
{ AP.createObject = AP.CreateFactory ttdetail (Just (hLocal, ttlocal)) { AP.createObject = AP.CreateFactory ttdetail (Just (hLocal, ttlocal))
, AP.createTarget = Nothing , AP.createOrigin = Nothing
} }
return action { AP.actionSpecific = specific } return action { AP.actionSpecific = specific }
@ -1000,27 +588,27 @@ clientCreate
-> ClientMsg -> ClientMsg
-> AP.Create URIMode -> AP.Create URIMode
-> ActE OutboxItemId -> ActE OutboxItemId
clientCreate now personMeID msg (AP.Create object muTarget) = clientCreate now personMeID msg (AP.Create object muOrigin) =
case object of case object of
AP.CreateTicketTracker detail mlocal -> do AP.CreateTicketTracker detail mlocal -> do
verifyNothingE mlocal "Tracker id must not be provided" verifyNothingE mlocal "Tracker id must not be provided"
verifyNothingE muTarget "'target' not supported in Create TicketTracker" uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
clientCreateDeck now personMeID msg detail clientCreateActor now personMeID msg detail uOrigin
AP.CreateProject detail mlocal -> do AP.CreateProject detail mlocal -> do
verifyNothingE mlocal "Project id must not be provided" verifyNothingE mlocal "Project id must not be provided"
verifyNothingE muTarget "'target' not supported in Create Project" uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
clientCreateProject now personMeID msg detail clientCreateActor now personMeID msg detail uOrigin
AP.CreateTeam detail mlocal -> do AP.CreateTeam detail mlocal -> do
verifyNothingE mlocal "Team id must not be provided" verifyNothingE mlocal "Team id must not be provided"
verifyNothingE muTarget "'target' not supported in Create Team" uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
clientCreateTeam now personMeID msg detail clientCreateActor now personMeID msg detail uOrigin
AP.CreateFactory detail mlocal -> do AP.CreateFactory detail mlocal -> do
verifyNothingE mlocal "Factory id must not be provided" verifyNothingE mlocal "Factory id must not be provided"
verifyNothingE muTarget "'target' not supported in Create Factory" verifyNothingE muOrigin "'target' not supported in Create Factory"
clientCreateFactory now personMeID msg detail clientCreateFactory now personMeID msg detail
_ -> throwE "Unsupported Create object for C2S" _ -> throwE "Unsupported Create object for C2S"

44
src/Vervis/Actor/Project.hs
View file

@ -71,7 +71,7 @@ import Vervis.Data.Discussion
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model hiding (projectCreate) import Vervis.Model
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor) import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Persist.Actor import Vervis.Persist.Actor
@ -2755,42 +2755,6 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
Right (author, _, addID) -> Right (author, _, addID) ->
insert_ $ SquadThemGestureRemote themID (remoteAuthorId author) addID insert_ $ SquadThemGestureRemote themID (remoteAuthorId author) addID
-- Meaning: Someone has created a project with my ID URI
-- Behavior:
-- * Verify I'm in a just-been-created state
-- * Verify my creator and the Create sender are the same actor
-- * Create an admin Collab record in DB
-- * Send an admin Grant to the creator
-- * Get out of the just-been-created state
projectCreateMe
:: UTCTime
-> ProjectId
-> Verse
-> ActE (Text, Act (), Next)
projectCreateMe = topicCreateMe projectResource LocalResourceProject
projectCreate
:: UTCTime
-> ProjectId
-> Verse
-> AP.Create URIMode
-> ActE (Text, Act (), Next)
projectCreate now projectID verse (AP.Create obj _muTarget) =
case obj of
AP.CreateProject _ mlocal -> do
(h, local) <- fromMaybeE mlocal "No project id provided"
let luProject = AP.actorId local
uMe <- do
projectHash <- encodeKeyHashid projectID
encodeRouteHome <- getEncodeRouteHome
return $ encodeRouteHome $ ProjectR projectHash
unless (uMe == ObjURI h luProject) $
throwE "The created project id isn't me"
projectCreateMe now projectID verse
_ -> throwE "Unsupported Create object for Project"
-- Meaning: An actor is following someone/something -- Meaning: An actor is following someone/something
-- Behavior: -- Behavior:
-- * Verify the target is me -- * Verify the target is me
@ -7614,11 +7578,10 @@ projectUndo now recipProjectID (Verse authorIdMsig body) (AP.Undo uObject) = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
projectBehavior :: UTCTime -> ProjectId -> ActorMessage Project -> ActE (Text, Act (), Next) projectBehavior :: UTCTime -> ProjectId -> ActorMessage Project -> ActE (Text, Act (), Next)
projectBehavior now projectID (MsgJ verse@(Verse _authorIdMsig body)) = projectBehavior now projectID (ProjectMsgVerse verse@(Verse _authorIdMsig body)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of
AP.AcceptActivity accept -> projectAccept now projectID verse accept AP.AcceptActivity accept -> projectAccept now projectID verse accept
AP.AddActivity add -> projectAdd now projectID verse add AP.AddActivity add -> projectAdd now projectID verse add
AP.CreateActivity create -> projectCreate now projectID verse create
AP.FollowActivity follow -> projectFollow now projectID verse follow AP.FollowActivity follow -> projectFollow now projectID verse follow
AP.GrantActivity grant -> projectGrant now projectID verse grant AP.GrantActivity grant -> projectGrant now projectID verse grant
AP.InviteActivity invite -> projectInvite now projectID verse invite AP.InviteActivity invite -> projectInvite now projectID verse invite
@ -7628,6 +7591,9 @@ projectBehavior now projectID (MsgJ verse@(Verse _authorIdMsig body)) =
AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke
AP.UndoActivity undo -> projectUndo now projectID verse undo AP.UndoActivity undo -> projectUndo now projectID verse undo
_ -> throwE "Unsupported activity type for Project" _ -> throwE "Unsupported activity type for Project"
projectBehavior now projectID (ProjectMsgInit creator) =
let grabResource = pure . projectResource
in topicInit grabResource LocalResourceProject now projectID creator
instance VervisActorLaunch Project where instance VervisActorLaunch Project where
actorBehavior' now projectID ve = do actorBehavior' now projectID ve = do

51
src/Vervis/Client.hs
View file

@ -1003,12 +1003,23 @@ createDeck
=> KeyHashid Person => KeyHashid Person
-> Text -> Text
-> Text -> Text
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail) -> FedURI
createDeck senderHash name desc = do -> ExceptT Text m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
createDeck senderHash name desc uFactory = do
audFactory <- do
routeOrRemote <- parseFedURIOld uFactory
actorOrRemote <- bitraverse parseLocalActorE pure routeOrRemote
case actorOrRemote of
Left la -> do
h <- VR.hashLocalActor la
return $ AudLocal [h] []
Right (ObjURI h lu) ->
pure $ AudRemote h [lu] []
let audAuthor = let audAuthor =
AudLocal [] [LocalStagePersonFollowers senderHash] AudLocal [] [LocalStagePersonFollowers senderHash]
audience = [audAuthor] audience = [audAuthor, audFactory]
detail = AP.ActorDetail detail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeTicketTracker { AP.actorType = AP.ActorTypeTicketTracker
@ -1074,12 +1085,23 @@ createProject
=> KeyHashid Person => KeyHashid Person
-> Text -> Text
-> Text -> Text
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail) -> FedURI
createProject senderHash name desc = do -> ExceptT Text m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
createProject senderHash name desc uFactory = do
audFactory <- do
routeOrRemote <- parseFedURIOld uFactory
actorOrRemote <- bitraverse parseLocalActorE pure routeOrRemote
case actorOrRemote of
Left la -> do
h <- VR.hashLocalActor la
return $ AudLocal [h] []
Right (ObjURI h lu) ->
pure $ AudRemote h [lu] []
let audAuthor = let audAuthor =
AudLocal [] [LocalStagePersonFollowers senderHash] AudLocal [] [LocalStagePersonFollowers senderHash]
audience = [audAuthor] audience = [audAuthor, audFactory]
detail = AP.ActorDetail detail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeProject { AP.actorType = AP.ActorTypeProject
@ -1095,12 +1117,23 @@ createGroup
=> KeyHashid Person => KeyHashid Person
-> Text -> Text
-> Text -> Text
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail) -> FedURI
createGroup senderHash name desc = do -> ExceptT Text m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
createGroup senderHash name desc uFactory = do
audFactory <- do
routeOrRemote <- parseFedURIOld uFactory
actorOrRemote <- bitraverse parseLocalActorE pure routeOrRemote
case actorOrRemote of
Left la -> do
h <- VR.hashLocalActor la
return $ AudLocal [h] []
Right (ObjURI h lu) ->
pure $ AudRemote h [lu] []
let audAuthor = let audAuthor =
AudLocal [] [LocalStagePersonFollowers senderHash] AudLocal [] [LocalStagePersonFollowers senderHash]
audience = [audAuthor] audience = [audAuthor, audFactory]
detail = AP.ActorDetail detail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeTeam { AP.actorType = AP.ActorTypeTeam

29
src/Vervis/Data/Actor.hs
View file

@ -22,6 +22,7 @@ module Vervis.Data.Actor
, stampRoute , stampRoute
, parseStampRoute , parseStampRoute
, grabLocalActorID , grabLocalActorID
, grabLocalResourceID
, localResourceID , localResourceID
, WA.parseLocalURI , WA.parseLocalURI
, parseFedURIOld , parseFedURIOld
@ -72,6 +73,15 @@ import Vervis.Recipient
import qualified Vervis.Actor as VA import qualified Vervis.Actor as VA
parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i)
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i)
parseOutboxItemRoute (FactoryOutboxItemR r i) = Just (LocalActorFactory r, i)
parseOutboxItemRoute _ = Nothing
parseLocalActivityURI parseLocalActivityURI
:: (MonadSite m, YesodHashids (SiteEnv m)) :: (MonadSite m, YesodHashids (SiteEnv m))
=> LocalURI => LocalURI
@ -85,14 +95,6 @@ parseLocalActivityURI luAct = do
outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash" outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
actorKey <- unhashLocalActorE actorHash "Invalid actor hash" actorKey <- unhashLocalActorE actorHash "Invalid actor hash"
return (actorKey, actorHash, outboxItemID) return (actorKey, actorHash, outboxItemID)
where
parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i)
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i)
parseOutboxItemRoute _ = Nothing
parseLocalActivityURI' parseLocalActivityURI'
:: LocalURI :: LocalURI
@ -106,14 +108,6 @@ parseLocalActivityURI' luAct = do
outboxItemID <- WAP.decodeKeyHashidE outboxItemHash "Invalid outbox item hash" outboxItemID <- WAP.decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
actorKey <- VA.unhashLocalActorE actorHash "Invalid actor hash" actorKey <- VA.unhashLocalActorE actorHash "Invalid actor hash"
return (actorKey, actorHash, outboxItemID) return (actorKey, actorHash, outboxItemID)
where
parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i)
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i)
parseOutboxItemRoute _ = Nothing
-- | If the given URI is remote, return as is. If the URI is local, verify that -- | If the given URI is remote, return as is. If the URI is local, verify that
-- it parses as an activity URI, i.e. an outbox item route, and return the -- it parses as an activity URI, i.e. an outbox item route, and return the
@ -194,6 +188,9 @@ localResourceID (LocalResourceLoom (Entity _ l)) = loomResource l
localResourceID (LocalResourceProject (Entity _ r)) = projectResource r localResourceID (LocalResourceProject (Entity _ r)) = projectResource r
localResourceID (LocalResourceFactory (Entity _ f)) = factoryResource f localResourceID (LocalResourceFactory (Entity _ f)) = factoryResource f
grabLocalResourceID :: MonadIO m => LocalResourceBy Entity -> SqlPersistT m ResourceId
grabLocalResourceID = pure . localResourceID
parseFedURIOld parseFedURIOld
:: ( MonadSite m :: ( MonadSite m
, SiteEnv m ~ site , SiteEnv m ~ site

61
src/Vervis/Field/Person.hs
View file

@ -17,23 +17,30 @@ module Vervis.Field.Person
( passField ( passField
, fedUriField , fedUriField
, capField , capField
, factoryField
) )
where where
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.Char (isDigit) import Data.Char (isDigit)
import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Database.Esqueleto import Database.Esqueleto
import Yesod.Core import Yesod.Core
import Yesod.Form.Fields import Yesod.Form.Fields
import Yesod.Form.Functions import Yesod.Form.Functions
import Yesod.Form.Types import Yesod.Form.Types
import Yesod.Persist.Core
import qualified Data.Text as T import qualified Data.Text as T
import qualified Database.Esqueleto as E
import Network.FedURI import Network.FedURI
import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local import Control.Monad.Trans.Except.Local
import Data.Char.Local (isAsciiLetter) import Data.Char.Local (isAsciiLetter)
@ -43,6 +50,7 @@ import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident (text2shr) import Vervis.Model.Ident (text2shr)
import Vervis.Recipient
import Vervis.Settings import Vervis.Settings
checkPassLength :: Field Handler Text -> Field Handler Text checkPassLength :: Field Handler Text -> Field Handler Text
@ -98,3 +106,56 @@ capField = checkMMap toCap fst fedUriField
where where
toCap u = toCap u =
runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u) runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u)
factoryField personID = selectField $ do
l <- runDB $ do
local <-
E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` factory `E.InnerJoin` resource `E.InnerJoin` actor) -> do
E.on $ resource E.^. ResourceActor E.==. actor E.^. ActorId
E.on $ factory E.^. FactoryResource E.==. resource E.^. ResourceId
E.on $ topic E.^. PermitTopicLocalTopic E.==. factory E.^. FactoryResource
E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
E.where_ $
permit E.^. PermitPerson E.==. E.val personID E.&&.
permit E.^. PermitRole `E.in_` E.valList [AP.RoleWrite, AP.RoleMaintain, AP.RoleAdmin]
return (factory E.^. FactoryId, actor E.^. ActorName, enable E.^. PermitTopicEnableLocalGrant)
remote <-
E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` actor `E.InnerJoin` object `E.InnerJoin` i `E.InnerJoin` ract `E.InnerJoin` ro) -> do
E.on $ ract E.^. RemoteActivityIdent E.==. ro E.^. RemoteObjectId
E.on $ enable E.^. PermitTopicEnableRemoteGrant E.==. ract E.^. RemoteActivityId
E.on $ object E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ actor E.^. RemoteActorIdent E.==. object E.^. RemoteObjectId
E.on $ topic E.^. PermitTopicRemoteActor E.==. actor E.^. RemoteActorId
E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
E.where_ $
permit E.^. PermitPerson E.==. E.val personID E.&&.
actor E.^. RemoteActorType E.==. E.val AP.ActorTypeFactory E.&&.
permit E.^. PermitRole `E.in_` E.valList [AP.RoleWrite, AP.RoleMaintain, AP.RoleAdmin]
return (i E.^. InstanceHost, object E.^. RemoteObjectIdent, actor E.^. RemoteActorName, ro E.^. RemoteObjectIdent)
return $ map Left local ++ map Right remote
hashFactory <- getEncodeKeyHashid
hashItem <- getEncodeKeyHashid
encodeRouteHome <- getEncodeRouteHome
optionsPairs $
map (\case
Left (E.Value factoryID, E.Value name, E.Value grantID) ->
( T.concat
[ "*", keyHashidText $ hashFactory factoryID
, " ", name
]
, ( encodeRouteHome $ FactoryR $ hashFactory factoryID
, encodeRouteHome $ FactoryOutboxItemR (hashFactory factoryID) (hashItem grantID)
)
)
Right (E.Value h, E.Value lu, E.Value mname, E.Value luGrant) ->
( T.concat
[ renderObjURI $ ObjURI h lu
, " "
, fromMaybe "(?)" mname
]
, (ObjURI h lu, ObjURI h luGrant)
)
)
l

25
src/Vervis/Form/Tracker.hs
View file

@ -55,6 +55,7 @@ import Yesod.Hashids
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import Vervis.FedURI import Vervis.FedURI
import Vervis.Field.Person
import Vervis.Form.Ticket import Vervis.Form.Ticket
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
@ -63,32 +64,38 @@ import Vervis.Model.Ident
data NewDeck = NewDeck data NewDeck = NewDeck
{ ndName :: Text { ndName :: Text
, ndDesc :: Text , ndDesc :: Text
, ndFactory :: (FedURI, FedURI)
} }
newDeckForm :: Form NewDeck newDeckForm :: PersonId -> Form NewDeck
newDeckForm = renderDivs $ NewDeck newDeckForm p = renderDivs $ NewDeck
<$> areq textField "Name*" Nothing <$> areq textField "Name*" Nothing
<*> areq textField "Description" Nothing <*> areq textField "Description*" Nothing
<*> areq (factoryField p) "Factory*" Nothing
data NewProject = NewProject data NewProject = NewProject
{ npName :: Text { npName :: Text
, npDesc :: Text , npDesc :: Text
, npFactory :: (FedURI, FedURI)
} }
newProjectForm :: Form NewProject newProjectForm :: PersonId -> Form NewProject
newProjectForm = renderDivs $ NewProject newProjectForm p = renderDivs $ NewProject
<$> areq textField "Name*" Nothing <$> areq textField "Name*" Nothing
<*> areq textField "Description" Nothing <*> areq textField "Description*" Nothing
<*> areq (factoryField p) "Factory*" Nothing
data NewGroup = NewGroup data NewGroup = NewGroup
{ ngName :: Text { ngName :: Text
, ngDesc :: Text , ngDesc :: Text
, ngFactory :: (FedURI, FedURI)
} }
newGroupForm :: Form NewGroup newGroupForm :: PersonId -> Form NewGroup
newGroupForm = renderDivs $ NewGroup newGroupForm p = renderDivs $ NewGroup
<$> areq textField "Name*" Nothing <$> areq textField "Name*" Nothing
<*> areq textField "Description" Nothing <*> areq textField "Description*" Nothing
<*> areq (factoryField p) "Factory*" Nothing
data NewLoom = NewLoom data NewLoom = NewLoom
{ nlName :: Text { nlName :: Text

18
src/Vervis/Foundation.hs
View file

@ -57,6 +57,8 @@ import Yesod.Static
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.HashSet as HS
import qualified Data.HList as H
import qualified Data.Time.Units as U import qualified Data.Time.Units as U
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
@ -680,7 +682,6 @@ instance AccountDB AccountPersistDB' where
, actorInbox = ibid , actorInbox = ibid
, actorOutbox = obid , actorOutbox = obid
, actorFollowers = fsid , actorFollowers = fsid
, actorJustCreatedBy = Nothing
, actorErrbox = rbid , actorErrbox = rbid
} }
aid <- insert actor aid <- insert actor
@ -719,6 +720,21 @@ instance AccountDB AccountPersistDB' where
takeMVar mvarResult takeMVar mvarResult
unless success $ unless success $
error "Failed to spawn new Person, somehow ID already in Theater" error "Failed to spawn new Person, somehow ID already in Theater"
AccountPersistDB' $ do
theater <- asksSite appTheater
there <- liftIO $ sendIO theater personID PersonMsgInit
unless there $
error "Failed to find new Person, somehow ID not in Theater"
factoryIDs <- runDB $ selectKeysList [] []
let package = (HS.fromList factoryIDs, FactoryMsgVerified personID)
liftIO $ sendManyIO theater $
Nothing `H.HCons`
Nothing `H.HCons`
Nothing `H.HCons`
Nothing `H.HCons`
Nothing `H.HCons`
Nothing `H.HCons`
Just package `H.HCons` H.HNil
setVerifyKey = (morphAPDB .) . setVerifyKey setVerifyKey = (morphAPDB .) . setVerifyKey
setNewPasswordKey = (morphAPDB .) . setNewPasswordKey setNewPasswordKey = (morphAPDB .) . setNewPasswordKey
setNewPassword = (morphAPDB .) . setNewPassword setNewPassword = (morphAPDB .) . setNewPassword

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

@ -353,34 +353,31 @@ getDeckMessageR _ _ = notFound
getDeckNewR :: Handler Html getDeckNewR :: Handler Html
getDeckNewR = do getDeckNewR = do
((_result, widget), enctype) <- runFormPost newDeckForm p <- requireAuthId
((_result, widget), enctype) <- runFormPost $ newDeckForm p
defaultLayout $(widgetFile "deck/new") defaultLayout $(widgetFile "deck/new")
postDeckNewR :: Handler Html postDeckNewR :: Handler Html
postDeckNewR = do postDeckNewR = do
NewDeck name desc <- runFormPostRedirect DeckNewR newDeckForm
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
NewDeck name desc (uFactory, uCap) <- runFormPostRedirect DeckNewR $ newDeckForm personID
personHash <- encodeKeyHashid personID personHash <- encodeKeyHashid personID
(maybeSummary, audience, detail) <- C.createDeck personHash name desc result <- runExceptT $ do
(localRecips, remoteRecips, fwdHosts, action) <- (maybeSummary, audience, detail) <- C.createDeck personHash name desc uFactory
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) Nothing (localRecips, remoteRecips, fwdHosts, action) <-
result <- lift $
runExceptT $ C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) (Just uFactory)
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action cap <- parseActivityURI uCap
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
case result of case result of
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
redirect DeckNewR redirect DeckNewR
Right createID -> do Right _createID -> do
maybeDeckID <- runDB $ getKeyBy $ UniqueDeckCreate createID setMessage "Create activity sent"
case maybeDeckID of redirect HomeR
Nothing -> error "Can't find the newly created deck"
Just deckID -> do
deckHash <- encodeKeyHashid deckID
setMessage "New ticket tracker created"
redirect $ DeckR deckHash
postDeckDeleteR :: KeyHashid Deck -> Handler Html postDeckDeleteR :: KeyHashid Deck -> Handler Html
postDeckDeleteR _ = error "Temporarily disabled" postDeckDeleteR _ = error "Temporarily disabled"

17
src/Vervis/Handler/Factory.hs
View file

@ -126,12 +126,17 @@ import qualified Vervis.Client as C
getFactoryR :: KeyHashid Factory -> Handler TypedContent getFactoryR :: KeyHashid Factory -> Handler TypedContent
getFactoryR factoryHash = do getFactoryR factoryHash = do
factoryID <- decodeKeyHashid404 factoryHash factoryID <- decodeKeyHashid404 factoryHash
(factory, actor, sigKeyIDs) <- runDB $ do mp <- maybeAuthId
(factory, actorID, actor, sigKeyIDs, permits) <- runDB $ do
f <- get404 factoryID f <- get404 factoryID
Resource aid <- getJust $ factoryResource f Resource aid <- getJust $ factoryResource f
a <- getJust aid a <- getJust aid
sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId] sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
return (f, a, sigKeys) permits <-
case mp of
Nothing -> pure []
Just personID -> getPermitsForResource personID (Left $ factoryResource f)
return (f, aid, a, sigKeys, permits)
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
hashSigKey <- getEncodeKeyHashid hashSigKey <- getEncodeKeyHashid
@ -166,7 +171,7 @@ getFactoryR factoryHash = do
encodeRouteLocal $ FactoryTeamsR factoryHash encodeRouteLocal $ FactoryTeamsR factoryHash
} }
provideHtmlAndAP factoryAP $ redirectToPrettyJSON $ FactoryR factoryHash provideHtmlAndAP factoryAP $(widgetFile "factory/one")
grabActorID = fmap resourceActor . getJust . factoryResource grabActorID = fmap resourceActor . getJust . factoryResource
@ -221,7 +226,11 @@ postFactoryNewR = do
setMessage $ toHtml e setMessage $ toHtml e
redirect FactoryNewR redirect FactoryNewR
Right createID -> do Right createID -> do
maybeFactoryID <- runDB $ getKeyBy $ UniqueFactoryCreate createID maybeFactoryID <- runDB $ runMaybeT $ do
ActorCreateLocal actorID _ <-
MaybeT $ getValBy $ UniqueActorCreateLocalCreate createID
resourceID <- MaybeT $ getKeyBy $ UniqueResource actorID
MaybeT $ getKeyBy $ UniqueFactory resourceID
case maybeFactoryID of case maybeFactoryID of
Nothing -> error "Can't find the newly created factory" Nothing -> error "Can't find the newly created factory"
Just factoryID -> do Just factoryID -> do

31
src/Vervis/Handler/Group.hs
View file

@ -147,34 +147,31 @@ import qualified Vervis.Client as C
getGroupNewR :: Handler Html getGroupNewR :: Handler Html
getGroupNewR = do getGroupNewR = do
((_result, widget), enctype) <- runFormPost newGroupForm p <- requireAuthId
((_result, widget), enctype) <- runFormPost $ newGroupForm p
defaultLayout $(widgetFile "group/new") defaultLayout $(widgetFile "group/new")
postGroupNewR :: Handler Html postGroupNewR :: Handler Html
postGroupNewR = do postGroupNewR = do
NewGroup name desc <- runFormPostRedirect GroupNewR newGroupForm
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
NewGroup name desc (uFactory, uCap) <- runFormPostRedirect GroupNewR $ newGroupForm personID
personHash <- encodeKeyHashid personID personHash <- encodeKeyHashid personID
(maybeSummary, audience, detail) <- C.createGroup personHash name desc result <- runExceptT $ do
(localRecips, remoteRecips, fwdHosts, action) <- (maybeSummary, audience, detail) <- C.createGroup personHash name desc uFactory
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) Nothing (localRecips, remoteRecips, fwdHosts, action) <-
result <- lift $
runExceptT $ C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) (Just uFactory)
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action cap <- parseActivityURI uCap
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
case result of case result of
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
redirect GroupNewR redirect GroupNewR
Right createID -> do Right _createID -> do
maybeGroupID <- runDB $ getKeyBy $ UniqueGroupCreate createID setMessage "Create activity sent"
case maybeGroupID of redirect HomeR
Nothing -> error "Can't find the newly created group"
Just groupID -> do
groupHash <- encodeKeyHashid groupID
setMessage "New group created"
redirect $ GroupR groupHash
getGroupR :: KeyHashid Group -> Handler TypedContent getGroupR :: KeyHashid Group -> Handler TypedContent
getGroupR groupHash = do getGroupR groupHash = do

11
src/Vervis/Handler/Loom.hs
View file

@ -362,14 +362,9 @@ postLoomNewR = do
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
redirect LoomNewR redirect LoomNewR
Right createID -> do Right _createID -> do
maybeLoomID <- runDB $ getKeyBy $ UniqueLoomCreate createID setMessage "Create activity sent"
case maybeLoomID of redirect HomeR
Nothing -> error "Can't find the newly created loom"
Just loomID -> do
loomHash <- encodeKeyHashid loomID
setMessage "New patch tracker created"
redirect $ LoomR loomHash
getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent
getLoomStampR = servePerActorKey loomActor LocalActorLoom getLoomStampR = servePerActorKey loomActor LocalActorLoom

31
src/Vervis/Handler/Project.hs
View file

@ -225,34 +225,31 @@ getProjectMessageR _ _ = notFound
getProjectNewR :: Handler Html getProjectNewR :: Handler Html
getProjectNewR = do getProjectNewR = do
((_result, widget), enctype) <- runFormPost newProjectForm p <- requireAuthId
((_result, widget), enctype) <- runFormPost $ newProjectForm p
defaultLayout $(widgetFile "project/new") defaultLayout $(widgetFile "project/new")
postProjectNewR :: Handler Html postProjectNewR :: Handler Html
postProjectNewR = do postProjectNewR = do
NewProject name desc <- runFormPostRedirect ProjectNewR newProjectForm
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
NewProject name desc (uFactory, uCap) <- runFormPostRedirect ProjectNewR $ newProjectForm personID
personHash <- encodeKeyHashid personID personHash <- encodeKeyHashid personID
(maybeSummary, audience, detail) <- C.createProject personHash name desc result <- runExceptT $ do
(localRecips, remoteRecips, fwdHosts, action) <- (maybeSummary, audience, detail) <- C.createProject personHash name desc uFactory
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) Nothing (localRecips, remoteRecips, fwdHosts, action) <-
result <- lift $
runExceptT $ C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) (Just uFactory)
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action cap <- parseActivityURI uCap
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
case result of case result of
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
redirect ProjectNewR redirect ProjectNewR
Right createID -> do Right _createID -> do
maybeProjectID <- runDB $ getKeyBy $ UniqueProjectCreate createID setMessage "Create activity sent"
case maybeProjectID of redirect HomeR
Nothing -> error "Can't find the newly created project"
Just projectID -> do
projectHash <- encodeKeyHashid projectID
setMessage "New project created"
redirect $ ProjectR projectHash
getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent
getProjectStampR = servePerActorKey projectActor LocalActorProject getProjectStampR = servePerActorKey projectActor LocalActorProject

11
src/Vervis/Handler/Repo.hs
View file

@ -472,14 +472,9 @@ postRepoNewR = do
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
redirect RepoNewR redirect RepoNewR
Right createID -> do Right _createID -> do
maybeRepoID <- runDB $ getKeyBy $ UniqueRepoCreate createID setMessage "Create activity sent"
case maybeRepoID of redirect HomeR
Nothing -> error "Can't find the newly created repo"
Just repoID -> do
repoHash <- encodeKeyHashid repoID
setMessage "New repository created"
redirect $ RepoR repoHash
postRepoDeleteR :: KeyHashid Repo -> Handler Html postRepoDeleteR :: KeyHashid Repo -> Handler Html
postRepoDeleteR repoHash = do postRepoDeleteR repoHash = do

63
src/Vervis/Migration.hs
View file

@ -3850,6 +3850,69 @@ changes hLocal ctx =
, addEntities model_648_report , addEntities model_648_report
-- 649 -- 649
, addEntities model_649_factory , addEntities model_649_factory
-- 650
, addEntities model_650_fulfills_resident
-- 651
, unchecked $ lift $ do
ps <- selectList [Person651Verified ==. True] []
let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
for_ ps $ \ (Entity pid p) -> do
let aid = person651Actor p
obid <- actor651Outbox <$> getJust aid
createID <- insert $ OutboxItem651 obid doc defaultTime
insert_ $ ActorCreateLocal651 aid createID
rs <- map entityVal <$> selectList [] []
ds <- map entityVal <$> selectList [] []
ls <- map entityVal <$> selectList [] []
js <- map entityVal <$> selectList [] []
gs <- map entityVal <$> selectList [] []
let l = concat
[ map (\ r -> (repo651Actor r, repo651Create r)) rs
, map (\ d -> (deck651Actor d, deck651Create d)) ds
, map (\ l -> (loom651Actor l, loom651Create l)) ls
, map (\ j -> (project651Actor j, project651Create j)) js
, map (\ g -> (group651Actor g, group651Create g)) gs
]
insertMany_ $ map (uncurry ActorCreateLocal651) l
{-
inboxID <- insert Inbox651
errboxID <- insert Inbox651
outboxID <- insert Outbox651
fsID <- insert FollowerSet651
actorID <- insert $ Actor651 "Default factory" "" defaultTime inboxID outboxID fsID Nothing errboxID
resourceID <- insert $ Resource651 actorID
createID <- insert $ OutboxItem651 outboxID doc defaultTime
insert_ $ Factory651 resourceID createID
insert_ $ ActorCreateLocal651 actorID createID
-}
-- 652
, removeField "Actor" "justCreatedBy"
-- 653
, removeUnique' "Deck" "Create"
-- 654
, removeUnique' "Loom" "Create"
-- 655
, removeUnique' "Repo" "Create"
-- 656
, removeUnique' "Project" "Create"
-- 657
, removeUnique' "Group" "Create"
-- 658
, removeUnique' "Factory" "Create"
-- 659
, removeField "Deck" "create"
-- 660
, removeField "Loom" "create"
-- 661
, removeField "Repo" "create"
-- 662
, removeField "Project" "create"
-- 663
, removeField "Group" "create"
-- 664
, removeField "Factory" "create"
] ]
migrateDB migrateDB

4
src/Vervis/Migration/Entities.hs
View file

@ -80,6 +80,7 @@ module Vervis.Migration.Entities
, model_639_component_convey , model_639_component_convey
, model_648_report , model_648_report
, model_649_factory , model_649_factory
, model_650_fulfills_resident
) )
where where
@ -315,3 +316,6 @@ model_648_report = $(schema "648_2024-07-06_report")
model_649_factory :: [Entity SqlBackend] model_649_factory :: [Entity SqlBackend]
model_649_factory = $(schema "649_2024-07-29_factory") model_649_factory = $(schema "649_2024-07-29_factory")
model_650_fulfills_resident :: [Entity SqlBackend]
model_650_fulfills_resident = $(schema "650_2024-08-03_fulfills_resident")

3
src/Vervis/Migration/Model2024.hs
View file

@ -80,3 +80,6 @@ makeEntitiesMigration "630"
makeEntitiesMigration "634" makeEntitiesMigration "634"
$(modelFile "migrations/634_2024-04-29_stem_holder.model") $(modelFile "migrations/634_2024-04-29_stem_holder.model")
makeEntitiesMigration "651"
$(modelFile "migrations/651_2024-08-03_actor_create.model")

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

@ -273,7 +273,7 @@ getRemoteActivityURI act = do
object <- getJust $ remoteActivityIdent act object <- getJust $ remoteActivityIdent act
getRemoteObjectURI object getRemoteObjectURI object
insertActor now name desc mby = do insertActor now name desc create = do
ibid <- insert Inbox ibid <- insert Inbox
rbid <- insert Inbox rbid <- insert Inbox
obid <- insert Outbox obid <- insert Outbox
@ -285,10 +285,12 @@ insertActor now name desc mby = do
, actorInbox = ibid , actorInbox = ibid
, actorOutbox = obid , actorOutbox = obid
, actorFollowers = fsid , actorFollowers = fsid
, actorJustCreatedBy = mby
, actorErrbox = rbid , actorErrbox = rbid
} }
actorID <- insert actor actorID <- insert actor
case create of
Left (_, _, obiid) -> insert_ $ ActorCreateLocal actorID obiid
Right (ra, _, act) -> insert_ $ ActorCreateRemote actorID act (VA.remoteAuthorId ra)
return $ Entity actorID actor return $ Entity actorID actor
updateOutboxItem updateOutboxItem

7
src/Vervis/Settings.hs
View file

@ -158,6 +158,12 @@ data AppSettings = AppSettings
, appMail :: Maybe MailSettings , appMail :: Maybe MailSettings
-- | People's usernames who are allowed to create Factory actors -- | People's usernames who are allowed to create Factory actors
, appCanCreateFactories :: [Text] , appCanCreateFactories :: [Text]
-- | KeyHashids of local Factory actors who will auto-send a
-- develop-Grant to every newly created account.
--
-- If empty, and there's exactly 1 local factory in DB, it will
-- automatically become the resident.
, appResidentFactories :: [Text]
-- | Whether to support federation. This includes: -- | Whether to support federation. This includes:
-- --
@ -257,6 +263,7 @@ instance FromJSON AppSettings where
appEmailVerification <- o .:? "email-verification" .!= not defaultDev appEmailVerification <- o .:? "email-verification" .!= not defaultDev
appMail <- o .:? "mail" appMail <- o .:? "mail"
appCanCreateFactories <- o .:? "can-create-factories" .!= [] appCanCreateFactories <- o .:? "can-create-factories" .!= []
appResidentFactories <- o .:? "resident-factories" .!= []
appFederation <- o .:? "federation" .!= False appFederation <- o .:? "federation" .!= False
appCapabilitySigningKeyFile <- o .: "capability-signing-key" appCapabilitySigningKeyFile <- o .: "capability-signing-key"

17
src/Web/ActivityPub.hs
View file

@ -2005,6 +2005,7 @@ data CreateObject u
| CreateProject ActorDetail (Maybe (Authority u, ActorLocal u)) | CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
| CreateTeam ActorDetail (Maybe (Authority u, ActorLocal u)) | CreateTeam ActorDetail (Maybe (Authority u, ActorLocal u))
| CreateFactory ActorDetail (Maybe (Authority u, ActorLocal u)) | CreateFactory ActorDetail (Maybe (Authority u, ActorLocal u))
| CreatePerson ActorDetail (Maybe (Authority u, ActorLocal u))
parseCreateObject :: UriMode u => Object -> Parser (CreateObject u) parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
parseCreateObject o parseCreateObject o
@ -2042,6 +2043,11 @@ parseCreateObject o
fail "type isn't Factory" fail "type isn't Factory"
ml <- parseActorLocal o ml <- parseActorLocal o
return $ CreateFactory f ml return $ CreateFactory f ml
<|> do f <- parseActorDetail o
unless (actorType f == ActorTypePerson) $
fail "type isn't Person"
ml <- parseActorLocal o
return $ CreatePerson f ml
encodeCreateObject :: UriMode u => CreateObject u -> Series encodeCreateObject :: UriMode u => CreateObject u -> Series
encodeCreateObject (CreateNote h note) = toSeries h note encodeCreateObject (CreateNote h note) = toSeries h note
@ -2062,10 +2068,12 @@ encodeCreateObject (CreateTeam d ml) =
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
encodeCreateObject (CreateFactory d ml) = encodeCreateObject (CreateFactory d ml) =
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
encodeCreateObject (CreatePerson d ml) =
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
data Create u = Create data Create u = Create
{ createObject :: CreateObject u { createObject :: CreateObject u
, createTarget :: Maybe (ObjURI u) , createOrigin :: Maybe (ObjURI u)
} }
parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u) parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u)
@ -2084,12 +2092,13 @@ parseCreate o a luActor = do
CreateProject _ _ -> return () CreateProject _ _ -> return ()
CreateTeam _ _ -> return () CreateTeam _ _ -> return ()
CreateFactory _ _ -> return () CreateFactory _ _ -> return ()
Create obj <$> o .:? "target" CreatePerson _ _ -> return ()
Create obj <$> o .:? "origin"
encodeCreate :: UriMode u => Create u -> Series encodeCreate :: UriMode u => Create u -> Series
encodeCreate (Create obj target) encodeCreate (Create obj origin)
= "object" `pair` pairs (encodeCreateObject obj) = "object" `pair` pairs (encodeCreateObject obj)
<> "target" .=? target <> "origin" .=? origin
data Follow u = Follow data Follow u = Follow
{ followObject :: ObjURI u { followObject :: ObjURI u

2
src/Web/Actor/Deliver.hs
View file

@ -236,4 +236,4 @@ sendHttp (DeliveryTheater manager headers micros logFunc root theater) method re
for_ recips $ \ u -> for_ recips $ \ u ->
let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root </>) . T.unpack >>= mkEnv (manager, headers, micros) logFunc let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root </>) . T.unpack >>= mkEnv (manager, headers, micros) logFunc
in void $ spawnIO theater u makeEnv in void $ spawnIO theater u makeEnv
sendManyIO theater $ (HS.fromList recips, method) `H.HCons` H.HNil sendManyIO theater $ Just (HS.fromList recips, method) `H.HCons` H.HNil

2
templates/default-layout.hamlet
View file

@ -17,7 +17,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div> <div>
$if verified $if verified
<span> <span>
[You are logged in as [You are logged in as #
$if can $if can
<span>👑 <span>👑
<span .username>#{personLogin person}</span>] <span .username>#{personLogin person}</span>]

19
templates/factory/one.hamlet Normal file
View file

@ -0,0 +1,19 @@
$# This file is part of Vervis.
$#
$# Written in 2024 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/>.
^{factoryNavW (Entity factoryID factory) actor}
^{followW' $ Left actorID}
^{personPermitsForResourceW permits}

41
th/models
View file

@ -126,13 +126,27 @@ Actor
inbox InboxId inbox InboxId
outbox OutboxId outbox OutboxId
followers FollowerSetId followers FollowerSetId
justCreatedBy ActorId Maybe
errbox InboxId errbox InboxId
UniqueActorInbox inbox UniqueActorInbox inbox
UniqueActorOutbox outbox UniqueActorOutbox outbox
UniqueActorFollowers followers UniqueActorFollowers followers
ActorCreateLocal
actor ActorId
create OutboxItemId
UniqueActorCreateLocalActor actor
UniqueActorCreateLocalCreate create
ActorCreateRemote
actor ActorId
create RemoteActivityId
sender RemoteActorId
UniqueActorCreateRemoteActor actor
UniqueActorCreateRemoteCreate create
SigKey SigKey
actor ActorId actor ActorId
material ActorKey material ActorKey
@ -169,10 +183,8 @@ Komponent
Factory Factory
resource ResourceId resource ResourceId
create OutboxItemId
UniqueFactory resource UniqueFactory resource
UniqueFactoryCreate create
-- ========================================================================= -- -- ========================================================================= --
-- Delivery -- Delivery
@ -297,10 +309,8 @@ SshKey
Group Group
actor ActorId actor ActorId
resource ResourceId resource ResourceId
create OutboxItemId
UniqueGroupActor actor UniqueGroupActor actor
UniqueGroupCreate create
GroupMember GroupMember
person PersonId person PersonId
@ -317,10 +327,8 @@ GroupMember
Project Project
actor ActorId actor ActorId
resource ResourceId resource ResourceId
create OutboxItemId
UniqueProjectActor actor UniqueProjectActor actor
UniqueProjectCreate create
Deck Deck
actor ActorId actor ActorId
@ -329,10 +337,8 @@ Deck
workflow WorkflowId workflow WorkflowId
nextTicket Int nextTicket Int
wiki RepoId Maybe wiki RepoId Maybe
create OutboxItemId
UniqueDeckActor actor UniqueDeckActor actor
UniqueDeckCreate create
Loom Loom
nextTicket Int nextTicket Int
@ -340,11 +346,9 @@ Loom
resource ResourceId resource ResourceId
komponent KomponentId komponent KomponentId
repo RepoId repo RepoId
create OutboxItemId
UniqueLoomActor actor UniqueLoomActor actor
UniqueLoomRepo repo UniqueLoomRepo repo
UniqueLoomCreate create
Repo Repo
vcs VersionControlSystem vcs VersionControlSystem
@ -353,11 +357,9 @@ Repo
actor ActorId actor ActorId
resource ResourceId resource ResourceId
komponent KomponentId komponent KomponentId
create OutboxItemId
loom LoomId Maybe loom LoomId Maybe
UniqueRepoActor actor UniqueRepoActor actor
UniqueRepoCreate create
-- I removed the 'sharer' field so Workflows don't specify who controls them -- I removed the 'sharer' field so Workflows don't specify who controls them
-- For now there's no way to create new ones, and what's already in the DB can -- For now there's no way to create new ones, and what's already in the DB can
@ -624,6 +626,11 @@ CollabFulfillsLocalTopicCreation
UniqueCollabFulfillsLocalTopicCreation collab UniqueCollabFulfillsLocalTopicCreation collab
CollabFulfillsResidentFactory
collab CollabId
UniqueCollabFulfillsResidentFactory collab
CollabFulfillsInvite CollabFulfillsInvite
collab CollabId collab CollabId
accept OutboxItemId accept OutboxItemId
@ -776,6 +783,11 @@ PermitFulfillsTopicCreation
UniquePermitFulfillsTopicCreation permit UniquePermitFulfillsTopicCreation permit
PermitFulfillsResidentFactory
permit PermitId
UniquePermitFulfillsResidentFactory permit
PermitFulfillsInvite PermitFulfillsInvite
permit PermitId permit PermitId
@ -792,6 +804,7 @@ PermitFulfillsJoin
-- Invite: Witnesses their approval, seeing the topic's accept, and then -- Invite: Witnesses their approval, seeing the topic's accept, and then
-- sending their own accept -- sending their own accept
-- Create: Records the Create activity that created the topic -- Create: Records the Create activity that created the topic
-- Factory: Records the self-Create the Person published
PermitPersonGesture PermitPersonGesture
permit PermitId permit PermitId
@ -852,6 +865,8 @@ PermitTopicAcceptRemote
-- Invite: Seeing existing-collaborator's Invite and new-collaborator's Accept, -- Invite: Seeing existing-collaborator's Invite and new-collaborator's Accept,
-- the topic has made the link official and sent a direct-grant -- the topic has made the link official and sent a direct-grant
-- Create: Upon being created, topic has sent its creator an admin-Grant -- Create: Upon being created, topic has sent its creator an admin-Grant
-- Factory: A factory that became active sent me a Grant (usually because I've
-- just created a new account)
PermitTopicEnableLocal PermitTopicEnableLocal
permit PermitPersonGestureId permit PermitPersonGestureId