Switch to factory-based creation of Deck, Project and Group
- 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
parent
66870458b7
commit
e196ee6f34
34 changed files with 1607 additions and 816 deletions
|
|
@ -110,6 +110,13 @@ max-accounts: 3
|
|||
# Person usernames who are allowed to create Factory actors
|
||||
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
|
||||
###############################################################################
|
||||
|
|
|
|||
24
migrations/650_2024-08-03_fulfills_resident.model
Normal file
24
migrations/650_2024-08-03_fulfills_resident.model
Normal 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
114
migrations/651_2024-08-03_actor_create.model
Normal 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
|
||||
|
|
@ -486,9 +486,10 @@ hSendTo
|
|||
:: ( Actor 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 ()
|
||||
hSendTo (tvar, (recips, msg)) = do
|
||||
hSendTo (_ , Nothing) = pure ()
|
||||
hSendTo (tvar, Just (recips, msg)) = do
|
||||
allActors <- readTVarIO tvar
|
||||
for_ (HM.intersection allActors (HS.toMap recips)) $
|
||||
\ actor -> sendIO' actor msg
|
||||
|
|
@ -497,7 +498,7 @@ data HSendTo = HSendTo
|
|||
instance
|
||||
( Actor 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
|
||||
applyAB _ a = hSendTo a
|
||||
|
|
@ -509,7 +510,7 @@ type instance Eval (B_ a) =
|
|||
)
|
||||
|
||||
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
|
||||
type instance Eval (Pair__ a) = (Eval (Item_ a), Eval (Set_ a))
|
||||
|
|
|
|||
|
|
@ -147,7 +147,7 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
|
|||
let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap
|
||||
msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action
|
||||
maybeResult <-
|
||||
liftIO $ callIO theater personID (MsgP $ Right msg)
|
||||
liftIO $ callIO theater personID (PersonMsgClient msg)
|
||||
itemText <-
|
||||
case maybeResult of
|
||||
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
|
||||
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
|
||||
komponentID <- insert $ Komponent resourceID
|
||||
loomID <- insert Loom
|
||||
|
|
@ -1159,7 +1159,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
|||
, loomResource = resourceID
|
||||
, loomKomponent = komponentID
|
||||
, loomRepo = repoID
|
||||
, loomCreate = obiidCreate
|
||||
--, loomCreate = obiidCreate
|
||||
}
|
||||
return (loomID, resourceID, actor)
|
||||
|
||||
|
|
@ -1185,7 +1185,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
|||
repo = encodeRouteHome $ RepoR repoHash
|
||||
specific = CreateActivity Create
|
||||
{ createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal))
|
||||
, createTarget = Nothing
|
||||
, createOrigin = Nothing
|
||||
}
|
||||
return action { actionSpecific = specific }
|
||||
|
||||
|
|
@ -1395,7 +1395,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
|||
|
||||
insertRepo now name msummary createID = do
|
||||
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
|
||||
komponentID <- insert $ Komponent resourceID
|
||||
repoID <- insert Repo
|
||||
|
|
@ -1405,7 +1405,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
|||
, repoActor = actorID
|
||||
, repoResource = resourceID
|
||||
, repoKomponent = komponentID
|
||||
, repoCreate = createID
|
||||
--, repoCreate = createID
|
||||
, repoLoom = Nothing
|
||||
}
|
||||
return (repoID, resourceID, actor)
|
||||
|
|
@ -1430,7 +1430,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
|||
}
|
||||
specific = CreateActivity Create
|
||||
{ createObject = CreateRepository rdetail vcs (Just (hLocal, rlocal))
|
||||
, createTarget = Nothing
|
||||
, createOrigin = Nothing
|
||||
}
|
||||
return action { actionSpecific = specific }
|
||||
|
||||
|
|
|
|||
|
|
@ -506,12 +506,17 @@ instance Actor Person where
|
|||
type ActorStage Person = Staje
|
||||
type ActorKey Person = PersonId
|
||||
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
|
||||
type ActorStage Deck = Staje
|
||||
type ActorKey Deck = DeckId
|
||||
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
|
||||
type ActorStage Loom = Staje
|
||||
type ActorKey Loom = LoomId
|
||||
|
|
@ -526,33 +531,40 @@ instance Actor Project where
|
|||
type ActorStage Project = Staje
|
||||
type ActorKey Project = ProjectId
|
||||
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
|
||||
type ActorStage Group = Staje
|
||||
type ActorKey Group = GroupId
|
||||
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
|
||||
type ActorStage Factory = Staje
|
||||
type ActorKey Factory = FactoryId
|
||||
type ActorReturn Factory = Either Text Text
|
||||
data ActorMessage Factory = MsgF Verse
|
||||
data ActorMessage Factory
|
||||
= FactoryMsgVerse Verse
|
||||
| FactoryMsgVerified PersonId
|
||||
|
||||
instance VervisActor Person where
|
||||
actorVerse = MsgP . Left
|
||||
toVerse (MsgP e) =
|
||||
case e of
|
||||
Left v -> Just v
|
||||
Right _ -> Nothing
|
||||
actorVerse = PersonMsgVerse
|
||||
toVerse (PersonMsgVerse v) = Just v
|
||||
toVerse _ = Nothing
|
||||
instance VervisActor Project where
|
||||
actorVerse = MsgJ
|
||||
toVerse (MsgJ v) = Just v
|
||||
actorVerse = ProjectMsgVerse
|
||||
toVerse (ProjectMsgVerse v) = Just v
|
||||
toVerse _ = Nothing
|
||||
instance VervisActor Group where
|
||||
actorVerse = MsgG
|
||||
toVerse (MsgG v) = Just v
|
||||
actorVerse = TeamMsgVerse
|
||||
toVerse (TeamMsgVerse v) = Just v
|
||||
toVerse _ = Nothing
|
||||
instance VervisActor Deck where
|
||||
actorVerse = MsgD
|
||||
toVerse (MsgD v) = Just v
|
||||
actorVerse = DeckMsgVerse
|
||||
toVerse (DeckMsgVerse v) = Just v
|
||||
toVerse _ = Nothing
|
||||
instance VervisActor Loom where
|
||||
actorVerse = MsgL
|
||||
toVerse (MsgL v) = Just v
|
||||
|
|
@ -563,8 +575,9 @@ instance VervisActor Repo where
|
|||
Left v -> Just v
|
||||
Right _ -> Nothing
|
||||
instance VervisActor Factory where
|
||||
actorVerse = MsgF
|
||||
toVerse (MsgF v) = Just v
|
||||
actorVerse = FactoryMsgVerse
|
||||
toVerse (FactoryMsgVerse v) = Just v
|
||||
toVerse _ = Nothing
|
||||
|
||||
instance Stage Staje where
|
||||
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]
|
||||
|
||||
instance Message (ActorMessage Person) where
|
||||
summarize (MsgP (Left verse)) = summarizeVerse verse
|
||||
summarize (MsgP (Right _)) = "ClientMsg"
|
||||
refer (MsgP (Left verse)) = referVerse verse
|
||||
refer (MsgP (Right _)) = "ClientMsg"
|
||||
summarize (PersonMsgVerse verse) = summarizeVerse verse
|
||||
summarize (PersonMsgClient _) = "PersonMsgClient"
|
||||
summarize PersonMsgInit = "PersonMsgInit"
|
||||
refer (PersonMsgVerse verse) = referVerse verse
|
||||
refer (PersonMsgClient _) = "PersonMsgClient"
|
||||
refer PersonMsgInit = "PersonMsgInit"
|
||||
instance Message (ActorMessage Deck) where
|
||||
summarize (MsgD verse) = summarizeVerse verse
|
||||
refer (MsgD verse) = referVerse verse
|
||||
summarize (DeckMsgVerse verse) = summarizeVerse verse
|
||||
summarize (DeckMsgInit _) = "DeckMsgInit"
|
||||
refer (DeckMsgVerse verse) = referVerse verse
|
||||
refer (DeckMsgInit _) = "DeckMsgInit"
|
||||
instance Message (ActorMessage Loom) where
|
||||
summarize (MsgL verse) = summarizeVerse verse
|
||||
refer (MsgL verse) = referVerse verse
|
||||
|
|
@ -610,14 +627,20 @@ instance Message (ActorMessage Repo) where
|
|||
refer (MsgR (Left verse)) = referVerse verse
|
||||
refer (MsgR (Right _)) = "WaitPushCompletion"
|
||||
instance Message (ActorMessage Project) where
|
||||
summarize (MsgJ verse) = summarizeVerse verse
|
||||
refer (MsgJ verse) = referVerse verse
|
||||
summarize (ProjectMsgVerse verse) = summarizeVerse verse
|
||||
summarize (ProjectMsgInit _) = "ProjectMsgInit"
|
||||
refer (ProjectMsgVerse verse) = referVerse verse
|
||||
refer (ProjectMsgInit _) = "ProjectMsgInit"
|
||||
instance Message (ActorMessage Group) where
|
||||
summarize (MsgG verse) = summarizeVerse verse
|
||||
refer (MsgG verse) = referVerse verse
|
||||
summarize (TeamMsgVerse verse) = summarizeVerse verse
|
||||
summarize (TeamMsgInit _) = "TeamMsgInit"
|
||||
refer (TeamMsgVerse verse) = referVerse verse
|
||||
refer (TeamMsgInit _) = "TeamMsgInit"
|
||||
instance Message (ActorMessage Factory) where
|
||||
summarize (MsgF verse) = summarizeVerse verse
|
||||
refer (MsgF verse) = referVerse verse
|
||||
summarize (FactoryMsgVerse verse) = summarizeVerse verse
|
||||
summarize (FactoryMsgVerified _) = "FactoryMsgVerified"
|
||||
refer (FactoryMsgVerse verse) = referVerse verse
|
||||
refer (FactoryMsgVerified _) = "FactoryMsgVerified"
|
||||
|
||||
type YesodRender y = Route y -> [(Text, Text)] -> Text
|
||||
|
||||
|
|
@ -935,13 +958,13 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
partitionByActor liveRecips
|
||||
verse = Verse authorAndId' body
|
||||
sendMany $
|
||||
(liveRecipsP, actorVerse verse) `H.HCons`
|
||||
(liveRecipsJ, actorVerse verse) `H.HCons`
|
||||
(liveRecipsG, actorVerse verse) `H.HCons`
|
||||
(liveRecipsD, actorVerse verse) `H.HCons`
|
||||
(liveRecipsL, actorVerse verse) `H.HCons`
|
||||
(liveRecipsR, actorVerse verse) `H.HCons`
|
||||
(liveRecipsF, actorVerse verse) `H.HCons` H.HNil
|
||||
(Just (liveRecipsP, actorVerse verse)) `H.HCons`
|
||||
(Just (liveRecipsJ, actorVerse verse)) `H.HCons`
|
||||
(Just (liveRecipsG, actorVerse verse)) `H.HCons`
|
||||
(Just (liveRecipsD, actorVerse verse)) `H.HCons`
|
||||
(Just (liveRecipsL, actorVerse verse)) `H.HCons`
|
||||
(Just (liveRecipsR, actorVerse verse)) `H.HCons`
|
||||
(Just (liveRecipsF, actorVerse verse)) `H.HCons` H.HNil
|
||||
|
||||
-- Return remote followers, to whom we need to deliver via HTTP
|
||||
return remoteFollowers
|
||||
|
|
|
|||
|
|
@ -19,12 +19,14 @@
|
|||
|
||||
module Vervis.Actor.Common
|
||||
( actorFollow
|
||||
, actorFollow'
|
||||
, topicAccept
|
||||
, topicReject
|
||||
, componentInvite
|
||||
, componentRemove
|
||||
, topicJoin
|
||||
, topicCreateMe
|
||||
, topicInit
|
||||
, componentGrant
|
||||
, componentAdd
|
||||
, componentRevoke
|
||||
|
|
@ -86,11 +88,13 @@ import Vervis.Data.Actor
|
|||
import Vervis.Data.Collab
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
import Vervis.Web.Collab
|
||||
|
||||
|
|
@ -113,7 +117,24 @@ actorFollow
|
|||
-> 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
|
||||
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
|
||||
followee <- nameExceptT "Follow object" $ do
|
||||
|
|
@ -132,7 +153,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
|||
|
||||
-- Find me in DB
|
||||
recip <- lift $ getJust recipID
|
||||
let recipActorID = grabActor recip
|
||||
recipActorID <- lift $ grabActor recip
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
|
||||
-- Insert the Follow to my inbox
|
||||
|
|
@ -2248,82 +2269,148 @@ topicJoin grabResource topicResource now topicKey (Verse authorIdMsig body) join
|
|||
recipID <- insert $ CollabRecipRemote collabID authorID
|
||||
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
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ResourceId)
|
||||
=> Bool
|
||||
-> Bool
|
||||
-> (topic -> ResourceId)
|
||||
-> (forall f. f topic -> LocalResourceBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> 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
|
||||
|
||||
-- Grab me from DB
|
||||
resourceID <- lift $ grabResource <$> getJust recipKey
|
||||
Resource recipActorID <- lift $ getJust resourceID
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
resourceMeID <- lift $ grabResource <$> getJust meID
|
||||
Resource actorMeID <- lift $ getJust resourceMeID
|
||||
actorMe <- lift $ getJust actorMeID
|
||||
|
||||
-- Verify I'm in the initial just-been-created state
|
||||
creatorActorID <-
|
||||
fromMaybeE
|
||||
(actorJustCreatedBy recipActor)
|
||||
"I already sent the initial Grant, why am I receiving this Create?"
|
||||
-- Verify I'm in initial state
|
||||
creatorActorID <- do
|
||||
create <-
|
||||
lift $
|
||||
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
|
||||
mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID
|
||||
fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently"
|
||||
existingCollabIDs <-
|
||||
lift $ selectList [CollabTopic ==. resourceID] []
|
||||
lift $ selectList [CollabTopic ==. resourceMeID] []
|
||||
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
|
||||
case authorIdMsig of
|
||||
Left (_, actorID, _) | actorID == creatorActorID -> pure ()
|
||||
_ -> 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
|
||||
|
||||
-- Create a Collab record and exit just-been-created state
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insertCollab resourceID creatorPersonID grantID
|
||||
update creatorActorID [ActorJustCreatedBy =. Nothing]
|
||||
-- Create a Collab record
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||
insertCollab resourceMeID creatorPersonID grantID
|
||||
|
||||
-- Prepare a Grant activity and insert to my outbox
|
||||
grant@(actionGrant, _, _, _) <- lift prepareGrant
|
||||
let recipByKey = resourceToActor $ topicResource recipKey
|
||||
let recipByKey = resourceToActor $ meToResource meID
|
||||
_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
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), inboxItemID) -> do
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
doneDB inboxItemID "Created a Collab record and published a Grant"
|
||||
Just (actorMeID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), writes, inboxItemID) -> do
|
||||
let recipByID = resourceToActor $ meToResource meID
|
||||
lift $ do
|
||||
sendActivity
|
||||
recipByID actorMeID localRecipsGrant
|
||||
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
|
||||
|
||||
insertCollab resourceID personID grantID = do
|
||||
collabID <- insert $ Collab AP.RoleAdmin resourceID
|
||||
insertCollab resourceMeID personID grantID = do
|
||||
collabID <- insert $ Collab AP.RoleAdmin resourceMeID
|
||||
insert_ $ CollabEnable collabID grantID
|
||||
insert_ $ CollabRecipLocal collabID personID
|
||||
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
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
audCreator <- makeAudSenderOnly authorIdMsig
|
||||
recipHash <- encodeKeyHashid recipKey
|
||||
recipHash <- encodeKeyHashid meID
|
||||
uCreator <- getActorURI authorIdMsig
|
||||
uCreate <- getActivityURI authorIdMsig
|
||||
let topicByHash = resourceToActor $ topicResource recipHash
|
||||
let topicByHash = resourceToActor $ meToResource recipHash
|
||||
audience =
|
||||
let audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audCreator, audTopic]
|
||||
|
|
@ -2352,6 +2439,167 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body)
|
|||
|
||||
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
|
||||
-- Behavior:
|
||||
-- * If I approved an Add-to-project where I'm the component, and the
|
||||
|
|
|
|||
|
|
@ -107,42 +107,6 @@ deckAdd
|
|||
-> ActE (Text, Act (), Next)
|
||||
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
|
||||
-- Behavior:
|
||||
-- * 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 now deckID (MsgD verse@(Verse _authorIdMsig body)) =
|
||||
deckBehavior now deckID (DeckMsgVerse verse@(Verse _authorIdMsig body)) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
AP.AcceptActivity accept -> deckAccept now deckID verse accept
|
||||
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.GrantActivity grant -> deckGrant now deckID verse grant
|
||||
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.UndoActivity undo -> deckUndo now deckID verse undo
|
||||
_ -> 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
|
||||
actorBehavior' now deckID ve = do
|
||||
|
|
|
|||
|
|
@ -18,43 +18,451 @@ module Vervis.Actor.Factory
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Base
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
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.Either
|
||||
import Data.Foldable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Optics.Core
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Network.FedURI
|
||||
import Web.Actor
|
||||
import Web.Actor.Persist
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Either.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.ActivityPub
|
||||
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.FedURI
|
||||
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
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 now factoryID (MsgF _verse@(Verse _authorIdMsig body)) =
|
||||
factoryBehavior now factoryID (FactoryMsgVerse verse@(Verse _authorIdMsig body)) =
|
||||
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"
|
||||
factoryBehavior now factoryID (FactoryMsgVerified personID) =
|
||||
factoryCheckPerson now factoryID personID
|
||||
|
||||
instance VervisActorLaunch Factory where
|
||||
actorBehavior' now factoryID ve = do
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ import Vervis.Data.Discussion
|
|||
import Vervis.FedURI
|
||||
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model hiding (groupCreate)
|
||||
import Vervis.Model
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Persist.Actor
|
||||
|
|
@ -2441,42 +2441,6 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
|
||||
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
|
||||
-- Behavior:
|
||||
-- * Verify the target is me
|
||||
|
|
@ -5927,11 +5891,10 @@ groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
|||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
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
|
||||
AP.AcceptActivity accept -> groupAccept now groupID verse accept
|
||||
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.GrantActivity grant -> groupGrant now groupID verse grant
|
||||
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.UndoActivity undo -> groupUndo now groupID verse undo
|
||||
_ -> 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
|
||||
actorBehavior' now groupID ve = do
|
||||
|
|
|
|||
|
|
@ -72,11 +72,12 @@ import Vervis.FedURI
|
|||
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.Persist.Follow
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, renderLocalActor)
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Ticket
|
||||
|
||||
|
|
@ -282,13 +283,19 @@ personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
|||
-- Meaning: An actor accepted something
|
||||
-- Behavior:
|
||||
-- * Insert to my inbox
|
||||
--
|
||||
-- * If it's on a Follow I sent to them:
|
||||
-- * Add to my following list in DB
|
||||
--
|
||||
-- * If it's on an Invite-for-me to collaborate on a resource:
|
||||
-- * Verify I haven't yet seen the resource's accept
|
||||
-- * Verify the Accept author is the resource
|
||||
-- * Store it in the Permit record in DB
|
||||
-- * 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
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
|
|
@ -300,6 +307,34 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
|||
-- Check input
|
||||
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
|
||||
|
||||
-- Grab me from DB
|
||||
|
|
@ -314,26 +349,113 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
|||
accepteeDB <- MaybeT $ getActivity acceptee
|
||||
|
||||
let recipActorID = personActor personRecip
|
||||
Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
|
||||
Right <$> tryInvite recipActorID accepteeDB acceptDB
|
||||
Left . Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
|
||||
Left . Right <$> tryInvite recipActorID accepteeDB acceptDB <|>
|
||||
Right <$> tryCreate maybeRightResult recipActorID accepteeDB acceptDB
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (inboxItemID, result) ->
|
||||
case result of
|
||||
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"
|
||||
Just (Right (actorID, sieve)) -> do
|
||||
Just (Left (Right (actorID, sieve))) -> do
|
||||
forwardActivity
|
||||
authorIdMsig body (LocalActorPerson recipPersonID)
|
||||
actorID sieve
|
||||
doneDB inboxItemID
|
||||
"Recorded this Accept on the Invite I've had & \
|
||||
\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
|
||||
|
||||
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
|
||||
Entity key val <-
|
||||
MaybeT $ lift $
|
||||
|
|
@ -435,6 +557,37 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
|||
|
||||
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
|
||||
-- Behavior:
|
||||
-- * Insert to my inbox
|
||||
|
|
@ -806,6 +959,11 @@ personJoin now recipPersonID (Verse authorIdMsig body) join = do
|
|||
-- Behavior:
|
||||
-- * 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:
|
||||
-- * Verify the Permit isn't already enabled
|
||||
-- * Verify the sender is the Permit topic
|
||||
|
|
@ -924,6 +1082,11 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
(personRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipPersonID
|
||||
(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 <-
|
||||
for maybeMine' $
|
||||
|
|
@ -934,39 +1097,45 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
fulfillsDB <- do
|
||||
a <- getActivity fulfills
|
||||
fromMaybeE a "Can't find fulfills in DB"
|
||||
(permitID, maybeGestureID) <- do
|
||||
mp <- runMaybeT $ do
|
||||
x@(pt, mg) <-
|
||||
tryInvite fulfillsDB <|>
|
||||
tryJoin fulfillsDB <|>
|
||||
tryCreate fulfillsDB
|
||||
Permit p role' <- lift . lift $ getJust pt
|
||||
guard $ p == recipPersonID
|
||||
lift $ unless (role == AP.RXRole role') $
|
||||
throwE "Requested and granted roles differ"
|
||||
return x
|
||||
fromMaybeE mp "Can't find a PermitFulfills*"
|
||||
mp <- runMaybeT $ do
|
||||
x@(pt, mg) <-
|
||||
tryInvite fulfillsDB <|>
|
||||
tryJoin fulfillsDB <|>
|
||||
tryCreate fulfillsDB
|
||||
Permit p role' <- lift . lift $ getJust pt
|
||||
guard $ p == recipPersonID
|
||||
lift $ unless (role == AP.RXRole role') $
|
||||
throwE "Requested and granted roles differ"
|
||||
return x
|
||||
case mp of
|
||||
Just (permitID, maybeGestureID) -> do
|
||||
|
||||
-- If Permit fulfills an Invite, verify I've approved
|
||||
-- it
|
||||
gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite"
|
||||
-- If Permit fulfills an Invite, verify I've approved
|
||||
-- it
|
||||
gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite"
|
||||
|
||||
-- Verify the Permit isn't already enabled
|
||||
topic <- lift $ getPermitTopic permitID
|
||||
maybeTopicEnable <-
|
||||
lift $ case bimap fst fst topic of
|
||||
Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
|
||||
Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
|
||||
unless (isNothing maybeTopicEnable) $
|
||||
throwE "I've already received the direct-Grant"
|
||||
-- Verify the Permit isn't already enabled
|
||||
topic <- lift $ getPermitTopic permitID
|
||||
maybeTopicEnable <-
|
||||
lift $ case bimap fst fst topic of
|
||||
Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
|
||||
Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
|
||||
unless (isNothing maybeTopicEnable) $
|
||||
throwE "I've already received the direct-Grant"
|
||||
|
||||
-- Verify the Grant sender is the Permit topic
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
|
||||
(Left la, Left la') | resourceToActor la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> throwE "Grant sender isn't the Permit topic"
|
||||
-- Verify the Grant sender is the Permit topic
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
|
||||
(Left la, Left la') | resourceToActor la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> 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
|
||||
Entity sendID (PermitPersonSendDelegator gestureID _) <- do
|
||||
|
|
@ -990,7 +1159,19 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
fmap (inboxItemID,) $
|
||||
for maybePermit $
|
||||
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
|
||||
case (topic, grantDB) of
|
||||
|
|
@ -1072,7 +1253,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
sendActivity
|
||||
recipByID recipActorID localRecipsDeleg
|
||||
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 ()) ->
|
||||
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
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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 now personID (MsgP (Left verse@(Verse _authorIdMsig body))) =
|
||||
personBehavior now personID (PersonMsgVerse verse@(Verse _authorIdMsig body)) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
AP.AcceptActivity accept -> personAccept now personID verse accept
|
||||
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.UndoActivity undo -> personUndo now personID verse undo
|
||||
_ -> 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
|
||||
actorBehavior' now personID ve = do
|
||||
|
|
|
|||
|
|
@ -358,26 +358,35 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
|
|||
fwdHosts addID action
|
||||
return addID
|
||||
|
||||
-- Meaning: The human wants to create a ticket tracker
|
||||
-- Meaning: The human wants to create an actor via a Factory
|
||||
-- Behavior:
|
||||
-- * Create a deck on DB
|
||||
-- * Create a Permit record in DB
|
||||
-- * Launch a deck actor
|
||||
-- * Record a FollowRequest in DB
|
||||
-- * Create and send Create and Follow to it
|
||||
clientCreateDeck
|
||||
-- * Ensure the origin is addressed
|
||||
-- * Insert Create to outbox
|
||||
-- * Create an open permit record
|
||||
-- * Send the Create to recipients
|
||||
clientCreateActor
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> ClientMsg
|
||||
-> AP.ActorDetail
|
||||
-> FedURI
|
||||
-> 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
|
||||
verifyNothingE maybeCap "Capability not needed"
|
||||
(name, msummary) <- parseTracker tracker
|
||||
_ <- fromMaybeE maybeCap "Capability not provided"
|
||||
_ <- 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
|
||||
(personMe, actorMe) <- lift $ do
|
||||
|
|
@ -385,455 +394,35 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
|||
(p,) <$> getJust (personActor p)
|
||||
let actorMeID = personActor personMe
|
||||
|
||||
-- Insert new deck to DB
|
||||
-- Insert the Create activity to my outbox
|
||||
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||
wid <- findWorkflow
|
||||
(deckID, resourceID, deckFollowerSetID) <-
|
||||
lift $ insertDeck now name msummary createID wid actorMeID
|
||||
_luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID action
|
||||
|
||||
-- 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
|
||||
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
|
||||
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"
|
||||
return (personActor personMe, createID)
|
||||
|
||||
-- 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
|
||||
(LocalActorPerson personMeID) actorMeID localRecips remoteRecips
|
||||
fwdHosts createID action
|
||||
|
||||
return createID
|
||||
|
||||
where
|
||||
|
||||
parseTracker (AP.ActorDetail typ muser mname msummary) = do
|
||||
unless (typ == AP.ActorTypeTicketTracker) $
|
||||
error "createTicketTrackerC: Create object isn't a TicketTracker"
|
||||
verifyNothingE muser "TicketTracker can't have a username"
|
||||
name <- fromMaybeE mname "TicketTracker doesn't specify name"
|
||||
parseDetail (AP.ActorDetail typ muser mname msummary) = do
|
||||
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"
|
||||
|
||||
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
|
||||
-- Behavior:
|
||||
-- * Verify human is allowed to
|
||||
|
|
@ -939,11 +528,10 @@ clientCreateFactory now personMeID (ClientMsg maybeCap localRecips remoteRecips
|
|||
return (name, msummary)
|
||||
|
||||
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
|
||||
fid <- insert Factory
|
||||
{ factoryResource = rid
|
||||
, factoryCreate = obiidCreate
|
||||
}
|
||||
return (fid, rid, actorFollowers a)
|
||||
|
||||
|
|
@ -967,7 +555,7 @@ clientCreateFactory now personMeID (ClientMsg maybeCap localRecips remoteRecips
|
|||
}
|
||||
specific = AP.CreateActivity AP.Create
|
||||
{ AP.createObject = AP.CreateFactory ttdetail (Just (hLocal, ttlocal))
|
||||
, AP.createTarget = Nothing
|
||||
, AP.createOrigin = Nothing
|
||||
}
|
||||
return action { AP.actionSpecific = specific }
|
||||
|
||||
|
|
@ -1000,27 +588,27 @@ clientCreate
|
|||
-> ClientMsg
|
||||
-> AP.Create URIMode
|
||||
-> ActE OutboxItemId
|
||||
clientCreate now personMeID msg (AP.Create object muTarget) =
|
||||
clientCreate now personMeID msg (AP.Create object muOrigin) =
|
||||
case object of
|
||||
|
||||
AP.CreateTicketTracker detail mlocal -> do
|
||||
verifyNothingE mlocal "Tracker id must not be provided"
|
||||
verifyNothingE muTarget "'target' not supported in Create TicketTracker"
|
||||
clientCreateDeck now personMeID msg detail
|
||||
uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
|
||||
clientCreateActor now personMeID msg detail uOrigin
|
||||
|
||||
AP.CreateProject detail mlocal -> do
|
||||
verifyNothingE mlocal "Project id must not be provided"
|
||||
verifyNothingE muTarget "'target' not supported in Create Project"
|
||||
clientCreateProject now personMeID msg detail
|
||||
uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
|
||||
clientCreateActor now personMeID msg detail uOrigin
|
||||
|
||||
AP.CreateTeam detail mlocal -> do
|
||||
verifyNothingE mlocal "Team id must not be provided"
|
||||
verifyNothingE muTarget "'target' not supported in Create Team"
|
||||
clientCreateTeam now personMeID msg detail
|
||||
uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
|
||||
clientCreateActor now personMeID msg detail uOrigin
|
||||
|
||||
AP.CreateFactory detail mlocal -> do
|
||||
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
|
||||
|
||||
_ -> throwE "Unsupported Create object for C2S"
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ import Vervis.Data.Discussion
|
|||
import Vervis.FedURI
|
||||
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model hiding (projectCreate)
|
||||
import Vervis.Model
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Persist.Actor
|
||||
|
|
@ -2755,42 +2755,6 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
|||
Right (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
|
||||
-- Behavior:
|
||||
-- * Verify the target is me
|
||||
|
|
@ -7614,11 +7578,10 @@ projectUndo now recipProjectID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
|||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
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
|
||||
AP.AcceptActivity accept -> projectAccept now projectID verse accept
|
||||
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.GrantActivity grant -> projectGrant now projectID verse grant
|
||||
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.UndoActivity undo -> projectUndo now projectID verse undo
|
||||
_ -> 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
|
||||
actorBehavior' now projectID ve = do
|
||||
|
|
|
|||
|
|
@ -1003,12 +1003,23 @@ createDeck
|
|||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||
createDeck senderHash name desc = do
|
||||
-> FedURI
|
||||
-> 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 =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
audience = [audAuthor]
|
||||
audience = [audAuthor, audFactory]
|
||||
|
||||
detail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypeTicketTracker
|
||||
|
|
@ -1074,12 +1085,23 @@ createProject
|
|||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||
createProject senderHash name desc = do
|
||||
-> FedURI
|
||||
-> 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 =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
audience = [audAuthor]
|
||||
audience = [audAuthor, audFactory]
|
||||
|
||||
detail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypeProject
|
||||
|
|
@ -1095,12 +1117,23 @@ createGroup
|
|||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||
createGroup senderHash name desc = do
|
||||
-> FedURI
|
||||
-> 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 =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
audience = [audAuthor]
|
||||
audience = [audAuthor, audFactory]
|
||||
|
||||
detail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypeTeam
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ module Vervis.Data.Actor
|
|||
, stampRoute
|
||||
, parseStampRoute
|
||||
, grabLocalActorID
|
||||
, grabLocalResourceID
|
||||
, localResourceID
|
||||
, WA.parseLocalURI
|
||||
, parseFedURIOld
|
||||
|
|
@ -72,6 +73,15 @@ import Vervis.Recipient
|
|||
|
||||
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
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> LocalURI
|
||||
|
|
@ -85,14 +95,6 @@ parseLocalActivityURI luAct = do
|
|||
outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
|
||||
actorKey <- unhashLocalActorE actorHash "Invalid actor hash"
|
||||
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'
|
||||
:: LocalURI
|
||||
|
|
@ -106,14 +108,6 @@ parseLocalActivityURI' luAct = do
|
|||
outboxItemID <- WAP.decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
|
||||
actorKey <- VA.unhashLocalActorE actorHash "Invalid actor hash"
|
||||
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
|
||||
-- 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 (LocalResourceFactory (Entity _ f)) = factoryResource f
|
||||
|
||||
grabLocalResourceID :: MonadIO m => LocalResourceBy Entity -> SqlPersistT m ResourceId
|
||||
grabLocalResourceID = pure . localResourceID
|
||||
|
||||
parseFedURIOld
|
||||
:: ( MonadSite m
|
||||
, SiteEnv m ~ site
|
||||
|
|
|
|||
|
|
@ -17,23 +17,30 @@ module Vervis.Field.Person
|
|||
( passField
|
||||
, fedUriField
|
||||
, capField
|
||||
, factoryField
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Char (isDigit)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Database.Esqueleto
|
||||
import Yesod.Core
|
||||
import Yesod.Form.Fields
|
||||
import Yesod.Form.Functions
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Network.FedURI
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Char.Local (isAsciiLetter)
|
||||
|
||||
|
|
@ -43,6 +50,7 @@ import Vervis.FedURI
|
|||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident (text2shr)
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
|
||||
checkPassLength :: Field Handler Text -> Field Handler Text
|
||||
|
|
@ -98,3 +106,56 @@ capField = checkMMap toCap fst fedUriField
|
|||
where
|
||||
toCap 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
|
||||
|
|
|
|||
|
|
@ -55,6 +55,7 @@ import Yesod.Hashids
|
|||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Vervis.FedURI
|
||||
import Vervis.Field.Person
|
||||
import Vervis.Form.Ticket
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
|
@ -63,32 +64,38 @@ import Vervis.Model.Ident
|
|||
data NewDeck = NewDeck
|
||||
{ ndName :: Text
|
||||
, ndDesc :: Text
|
||||
, ndFactory :: (FedURI, FedURI)
|
||||
}
|
||||
|
||||
newDeckForm :: Form NewDeck
|
||||
newDeckForm = renderDivs $ NewDeck
|
||||
newDeckForm :: PersonId -> Form NewDeck
|
||||
newDeckForm p = renderDivs $ NewDeck
|
||||
<$> areq textField "Name*" Nothing
|
||||
<*> areq textField "Description" Nothing
|
||||
<*> areq textField "Description*" Nothing
|
||||
<*> areq (factoryField p) "Factory*" Nothing
|
||||
|
||||
data NewProject = NewProject
|
||||
{ npName :: Text
|
||||
, npDesc :: Text
|
||||
, npFactory :: (FedURI, FedURI)
|
||||
}
|
||||
|
||||
newProjectForm :: Form NewProject
|
||||
newProjectForm = renderDivs $ NewProject
|
||||
newProjectForm :: PersonId -> Form NewProject
|
||||
newProjectForm p = renderDivs $ NewProject
|
||||
<$> areq textField "Name*" Nothing
|
||||
<*> areq textField "Description" Nothing
|
||||
<*> areq textField "Description*" Nothing
|
||||
<*> areq (factoryField p) "Factory*" Nothing
|
||||
|
||||
data NewGroup = NewGroup
|
||||
{ ngName :: Text
|
||||
, ngDesc :: Text
|
||||
, ngFactory :: (FedURI, FedURI)
|
||||
}
|
||||
|
||||
newGroupForm :: Form NewGroup
|
||||
newGroupForm = renderDivs $ NewGroup
|
||||
newGroupForm :: PersonId -> Form NewGroup
|
||||
newGroupForm p = renderDivs $ NewGroup
|
||||
<$> areq textField "Name*" Nothing
|
||||
<*> areq textField "Description" Nothing
|
||||
<*> areq textField "Description*" Nothing
|
||||
<*> areq (factoryField p) "Factory*" Nothing
|
||||
|
||||
data NewLoom = NewLoom
|
||||
{ nlName :: Text
|
||||
|
|
|
|||
|
|
@ -57,6 +57,8 @@ import Yesod.Static
|
|||
|
||||
import qualified Data.Aeson as A
|
||||
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 Database.Esqueleto as E
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
|
|
@ -680,7 +682,6 @@ instance AccountDB AccountPersistDB' where
|
|||
, actorInbox = ibid
|
||||
, actorOutbox = obid
|
||||
, actorFollowers = fsid
|
||||
, actorJustCreatedBy = Nothing
|
||||
, actorErrbox = rbid
|
||||
}
|
||||
aid <- insert actor
|
||||
|
|
@ -719,6 +720,21 @@ instance AccountDB AccountPersistDB' where
|
|||
takeMVar mvarResult
|
||||
unless success $
|
||||
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
|
||||
setNewPasswordKey = (morphAPDB .) . setNewPasswordKey
|
||||
setNewPassword = (morphAPDB .) . setNewPassword
|
||||
|
|
|
|||
|
|
@ -353,34 +353,31 @@ getDeckMessageR _ _ = notFound
|
|||
|
||||
getDeckNewR :: Handler Html
|
||||
getDeckNewR = do
|
||||
((_result, widget), enctype) <- runFormPost newDeckForm
|
||||
p <- requireAuthId
|
||||
((_result, widget), enctype) <- runFormPost $ newDeckForm p
|
||||
defaultLayout $(widgetFile "deck/new")
|
||||
|
||||
postDeckNewR :: Handler Html
|
||||
postDeckNewR = do
|
||||
NewDeck name desc <- runFormPostRedirect DeckNewR newDeckForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
NewDeck name desc (uFactory, uCap) <- runFormPostRedirect DeckNewR $ newDeckForm personID
|
||||
|
||||
personHash <- encodeKeyHashid personID
|
||||
(maybeSummary, audience, detail) <- C.createDeck personHash name desc
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) Nothing
|
||||
result <-
|
||||
runExceptT $
|
||||
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, detail) <- C.createDeck personHash name desc uFactory
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
lift $
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) (Just uFactory)
|
||||
cap <- parseActivityURI uCap
|
||||
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect DeckNewR
|
||||
Right createID -> do
|
||||
maybeDeckID <- runDB $ getKeyBy $ UniqueDeckCreate createID
|
||||
case maybeDeckID of
|
||||
Nothing -> error "Can't find the newly created deck"
|
||||
Just deckID -> do
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
setMessage "New ticket tracker created"
|
||||
redirect $ DeckR deckHash
|
||||
Right _createID -> do
|
||||
setMessage "Create activity sent"
|
||||
redirect HomeR
|
||||
|
||||
postDeckDeleteR :: KeyHashid Deck -> Handler Html
|
||||
postDeckDeleteR _ = error "Temporarily disabled"
|
||||
|
|
|
|||
|
|
@ -126,12 +126,17 @@ import qualified Vervis.Client as C
|
|||
getFactoryR :: KeyHashid Factory -> Handler TypedContent
|
||||
getFactoryR factoryHash = do
|
||||
factoryID <- decodeKeyHashid404 factoryHash
|
||||
(factory, actor, sigKeyIDs) <- runDB $ do
|
||||
mp <- maybeAuthId
|
||||
(factory, actorID, actor, sigKeyIDs, permits) <- runDB $ do
|
||||
f <- get404 factoryID
|
||||
Resource aid <- getJust $ factoryResource f
|
||||
a <- getJust aid
|
||||
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
|
||||
hashSigKey <- getEncodeKeyHashid
|
||||
|
|
@ -166,7 +171,7 @@ getFactoryR factoryHash = do
|
|||
encodeRouteLocal $ FactoryTeamsR factoryHash
|
||||
}
|
||||
|
||||
provideHtmlAndAP factoryAP $ redirectToPrettyJSON $ FactoryR factoryHash
|
||||
provideHtmlAndAP factoryAP $(widgetFile "factory/one")
|
||||
|
||||
grabActorID = fmap resourceActor . getJust . factoryResource
|
||||
|
||||
|
|
@ -221,7 +226,11 @@ postFactoryNewR = do
|
|||
setMessage $ toHtml e
|
||||
redirect FactoryNewR
|
||||
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
|
||||
Nothing -> error "Can't find the newly created factory"
|
||||
Just factoryID -> do
|
||||
|
|
|
|||
|
|
@ -147,34 +147,31 @@ import qualified Vervis.Client as C
|
|||
|
||||
getGroupNewR :: Handler Html
|
||||
getGroupNewR = do
|
||||
((_result, widget), enctype) <- runFormPost newGroupForm
|
||||
p <- requireAuthId
|
||||
((_result, widget), enctype) <- runFormPost $ newGroupForm p
|
||||
defaultLayout $(widgetFile "group/new")
|
||||
|
||||
postGroupNewR :: Handler Html
|
||||
postGroupNewR = do
|
||||
NewGroup name desc <- runFormPostRedirect GroupNewR newGroupForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
NewGroup name desc (uFactory, uCap) <- runFormPostRedirect GroupNewR $ newGroupForm personID
|
||||
|
||||
personHash <- encodeKeyHashid personID
|
||||
(maybeSummary, audience, detail) <- C.createGroup personHash name desc
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) Nothing
|
||||
result <-
|
||||
runExceptT $
|
||||
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, detail) <- C.createGroup personHash name desc uFactory
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
lift $
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) (Just uFactory)
|
||||
cap <- parseActivityURI uCap
|
||||
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect GroupNewR
|
||||
Right createID -> do
|
||||
maybeGroupID <- runDB $ getKeyBy $ UniqueGroupCreate createID
|
||||
case maybeGroupID of
|
||||
Nothing -> error "Can't find the newly created group"
|
||||
Just groupID -> do
|
||||
groupHash <- encodeKeyHashid groupID
|
||||
setMessage "New group created"
|
||||
redirect $ GroupR groupHash
|
||||
Right _createID -> do
|
||||
setMessage "Create activity sent"
|
||||
redirect HomeR
|
||||
|
||||
getGroupR :: KeyHashid Group -> Handler TypedContent
|
||||
getGroupR groupHash = do
|
||||
|
|
|
|||
|
|
@ -362,14 +362,9 @@ postLoomNewR = do
|
|||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect LoomNewR
|
||||
Right createID -> do
|
||||
maybeLoomID <- runDB $ getKeyBy $ UniqueLoomCreate createID
|
||||
case maybeLoomID of
|
||||
Nothing -> error "Can't find the newly created loom"
|
||||
Just loomID -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
setMessage "New patch tracker created"
|
||||
redirect $ LoomR loomHash
|
||||
Right _createID -> do
|
||||
setMessage "Create activity sent"
|
||||
redirect HomeR
|
||||
|
||||
getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent
|
||||
getLoomStampR = servePerActorKey loomActor LocalActorLoom
|
||||
|
|
|
|||
|
|
@ -225,34 +225,31 @@ getProjectMessageR _ _ = notFound
|
|||
|
||||
getProjectNewR :: Handler Html
|
||||
getProjectNewR = do
|
||||
((_result, widget), enctype) <- runFormPost newProjectForm
|
||||
p <- requireAuthId
|
||||
((_result, widget), enctype) <- runFormPost $ newProjectForm p
|
||||
defaultLayout $(widgetFile "project/new")
|
||||
|
||||
postProjectNewR :: Handler Html
|
||||
postProjectNewR = do
|
||||
NewProject name desc <- runFormPostRedirect ProjectNewR newProjectForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
NewProject name desc (uFactory, uCap) <- runFormPostRedirect ProjectNewR $ newProjectForm personID
|
||||
|
||||
personHash <- encodeKeyHashid personID
|
||||
(maybeSummary, audience, detail) <- C.createProject personHash name desc
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) Nothing
|
||||
result <-
|
||||
runExceptT $
|
||||
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, detail) <- C.createProject personHash name desc uFactory
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
lift $
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) (Just uFactory)
|
||||
cap <- parseActivityURI uCap
|
||||
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect ProjectNewR
|
||||
Right createID -> do
|
||||
maybeProjectID <- runDB $ getKeyBy $ UniqueProjectCreate createID
|
||||
case maybeProjectID of
|
||||
Nothing -> error "Can't find the newly created project"
|
||||
Just projectID -> do
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
setMessage "New project created"
|
||||
redirect $ ProjectR projectHash
|
||||
Right _createID -> do
|
||||
setMessage "Create activity sent"
|
||||
redirect HomeR
|
||||
|
||||
getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent
|
||||
getProjectStampR = servePerActorKey projectActor LocalActorProject
|
||||
|
|
|
|||
|
|
@ -472,14 +472,9 @@ postRepoNewR = do
|
|||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect RepoNewR
|
||||
Right createID -> do
|
||||
maybeRepoID <- runDB $ getKeyBy $ UniqueRepoCreate createID
|
||||
case maybeRepoID of
|
||||
Nothing -> error "Can't find the newly created repo"
|
||||
Just repoID -> do
|
||||
repoHash <- encodeKeyHashid repoID
|
||||
setMessage "New repository created"
|
||||
redirect $ RepoR repoHash
|
||||
Right _createID -> do
|
||||
setMessage "Create activity sent"
|
||||
redirect HomeR
|
||||
|
||||
postRepoDeleteR :: KeyHashid Repo -> Handler Html
|
||||
postRepoDeleteR repoHash = do
|
||||
|
|
|
|||
|
|
@ -3850,6 +3850,69 @@ changes hLocal ctx =
|
|||
, addEntities model_648_report
|
||||
-- 649
|
||||
, 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
|
||||
|
|
|
|||
|
|
@ -80,6 +80,7 @@ module Vervis.Migration.Entities
|
|||
, model_639_component_convey
|
||||
, model_648_report
|
||||
, model_649_factory
|
||||
, model_650_fulfills_resident
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -315,3 +316,6 @@ model_648_report = $(schema "648_2024-07-06_report")
|
|||
|
||||
model_649_factory :: [Entity SqlBackend]
|
||||
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")
|
||||
|
|
|
|||
|
|
@ -80,3 +80,6 @@ makeEntitiesMigration "630"
|
|||
|
||||
makeEntitiesMigration "634"
|
||||
$(modelFile "migrations/634_2024-04-29_stem_holder.model")
|
||||
|
||||
makeEntitiesMigration "651"
|
||||
$(modelFile "migrations/651_2024-08-03_actor_create.model")
|
||||
|
|
|
|||
|
|
@ -273,7 +273,7 @@ getRemoteActivityURI act = do
|
|||
object <- getJust $ remoteActivityIdent act
|
||||
getRemoteObjectURI object
|
||||
|
||||
insertActor now name desc mby = do
|
||||
insertActor now name desc create = do
|
||||
ibid <- insert Inbox
|
||||
rbid <- insert Inbox
|
||||
obid <- insert Outbox
|
||||
|
|
@ -285,10 +285,12 @@ insertActor now name desc mby = do
|
|||
, actorInbox = ibid
|
||||
, actorOutbox = obid
|
||||
, actorFollowers = fsid
|
||||
, actorJustCreatedBy = mby
|
||||
, actorErrbox = rbid
|
||||
}
|
||||
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
|
||||
|
||||
updateOutboxItem
|
||||
|
|
|
|||
|
|
@ -158,6 +158,12 @@ data AppSettings = AppSettings
|
|||
, appMail :: Maybe MailSettings
|
||||
-- | People's usernames who are allowed to create Factory actors
|
||||
, 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:
|
||||
--
|
||||
|
|
@ -257,6 +263,7 @@ instance FromJSON AppSettings where
|
|||
appEmailVerification <- o .:? "email-verification" .!= not defaultDev
|
||||
appMail <- o .:? "mail"
|
||||
appCanCreateFactories <- o .:? "can-create-factories" .!= []
|
||||
appResidentFactories <- o .:? "resident-factories" .!= []
|
||||
|
||||
appFederation <- o .:? "federation" .!= False
|
||||
appCapabilitySigningKeyFile <- o .: "capability-signing-key"
|
||||
|
|
|
|||
|
|
@ -2005,6 +2005,7 @@ data CreateObject u
|
|||
| CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
|
||||
| CreateTeam 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 o
|
||||
|
|
@ -2042,6 +2043,11 @@ parseCreateObject o
|
|||
fail "type isn't Factory"
|
||||
ml <- parseActorLocal o
|
||||
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 (CreateNote h note) = toSeries h note
|
||||
|
|
@ -2062,10 +2068,12 @@ encodeCreateObject (CreateTeam d ml) =
|
|||
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
||||
encodeCreateObject (CreateFactory d ml) =
|
||||
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
||||
encodeCreateObject (CreatePerson d ml) =
|
||||
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
||||
|
||||
data Create u = Create
|
||||
{ createObject :: CreateObject u
|
||||
, createTarget :: Maybe (ObjURI u)
|
||||
, createOrigin :: Maybe (ObjURI u)
|
||||
}
|
||||
|
||||
parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u)
|
||||
|
|
@ -2084,12 +2092,13 @@ parseCreate o a luActor = do
|
|||
CreateProject _ _ -> return ()
|
||||
CreateTeam _ _ -> return ()
|
||||
CreateFactory _ _ -> return ()
|
||||
Create obj <$> o .:? "target"
|
||||
CreatePerson _ _ -> return ()
|
||||
Create obj <$> o .:? "origin"
|
||||
|
||||
encodeCreate :: UriMode u => Create u -> Series
|
||||
encodeCreate (Create obj target)
|
||||
encodeCreate (Create obj origin)
|
||||
= "object" `pair` pairs (encodeCreateObject obj)
|
||||
<> "target" .=? target
|
||||
<> "origin" .=? origin
|
||||
|
||||
data Follow u = Follow
|
||||
{ followObject :: ObjURI u
|
||||
|
|
|
|||
|
|
@ -236,4 +236,4 @@ sendHttp (DeliveryTheater manager headers micros logFunc root theater) method re
|
|||
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
|
||||
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
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<div>
|
||||
$if verified
|
||||
<span>
|
||||
[You are logged in as
|
||||
[You are logged in as #
|
||||
$if can
|
||||
<span>👑
|
||||
<span .username>#{personLogin person}</span>]
|
||||
|
|
|
|||
19
templates/factory/one.hamlet
Normal file
19
templates/factory/one.hamlet
Normal 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
41
th/models
|
|
@ -126,13 +126,27 @@ Actor
|
|||
inbox InboxId
|
||||
outbox OutboxId
|
||||
followers FollowerSetId
|
||||
justCreatedBy ActorId Maybe
|
||||
errbox InboxId
|
||||
|
||||
UniqueActorInbox inbox
|
||||
UniqueActorOutbox outbox
|
||||
UniqueActorFollowers followers
|
||||
|
||||
ActorCreateLocal
|
||||
actor ActorId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueActorCreateLocalActor actor
|
||||
UniqueActorCreateLocalCreate create
|
||||
|
||||
ActorCreateRemote
|
||||
actor ActorId
|
||||
create RemoteActivityId
|
||||
sender RemoteActorId
|
||||
|
||||
UniqueActorCreateRemoteActor actor
|
||||
UniqueActorCreateRemoteCreate create
|
||||
|
||||
SigKey
|
||||
actor ActorId
|
||||
material ActorKey
|
||||
|
|
@ -169,10 +183,8 @@ Komponent
|
|||
|
||||
Factory
|
||||
resource ResourceId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueFactory resource
|
||||
UniqueFactoryCreate create
|
||||
|
||||
-- ========================================================================= --
|
||||
-- Delivery
|
||||
|
|
@ -297,10 +309,8 @@ SshKey
|
|||
Group
|
||||
actor ActorId
|
||||
resource ResourceId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueGroupActor actor
|
||||
UniqueGroupCreate create
|
||||
|
||||
GroupMember
|
||||
person PersonId
|
||||
|
|
@ -317,10 +327,8 @@ GroupMember
|
|||
Project
|
||||
actor ActorId
|
||||
resource ResourceId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueProjectActor actor
|
||||
UniqueProjectCreate create
|
||||
|
||||
Deck
|
||||
actor ActorId
|
||||
|
|
@ -329,10 +337,8 @@ Deck
|
|||
workflow WorkflowId
|
||||
nextTicket Int
|
||||
wiki RepoId Maybe
|
||||
create OutboxItemId
|
||||
|
||||
UniqueDeckActor actor
|
||||
UniqueDeckCreate create
|
||||
|
||||
Loom
|
||||
nextTicket Int
|
||||
|
|
@ -340,11 +346,9 @@ Loom
|
|||
resource ResourceId
|
||||
komponent KomponentId
|
||||
repo RepoId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueLoomActor actor
|
||||
UniqueLoomRepo repo
|
||||
UniqueLoomCreate create
|
||||
|
||||
Repo
|
||||
vcs VersionControlSystem
|
||||
|
|
@ -353,11 +357,9 @@ Repo
|
|||
actor ActorId
|
||||
resource ResourceId
|
||||
komponent KomponentId
|
||||
create OutboxItemId
|
||||
loom LoomId Maybe
|
||||
|
||||
UniqueRepoActor actor
|
||||
UniqueRepoCreate create
|
||||
|
||||
-- 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
|
||||
|
|
@ -624,6 +626,11 @@ CollabFulfillsLocalTopicCreation
|
|||
|
||||
UniqueCollabFulfillsLocalTopicCreation collab
|
||||
|
||||
CollabFulfillsResidentFactory
|
||||
collab CollabId
|
||||
|
||||
UniqueCollabFulfillsResidentFactory collab
|
||||
|
||||
CollabFulfillsInvite
|
||||
collab CollabId
|
||||
accept OutboxItemId
|
||||
|
|
@ -776,6 +783,11 @@ PermitFulfillsTopicCreation
|
|||
|
||||
UniquePermitFulfillsTopicCreation permit
|
||||
|
||||
PermitFulfillsResidentFactory
|
||||
permit PermitId
|
||||
|
||||
UniquePermitFulfillsResidentFactory permit
|
||||
|
||||
PermitFulfillsInvite
|
||||
permit PermitId
|
||||
|
||||
|
|
@ -792,6 +804,7 @@ PermitFulfillsJoin
|
|||
-- Invite: Witnesses their approval, seeing the topic's accept, and then
|
||||
-- sending their own accept
|
||||
-- Create: Records the Create activity that created the topic
|
||||
-- Factory: Records the self-Create the Person published
|
||||
|
||||
PermitPersonGesture
|
||||
permit PermitId
|
||||
|
|
@ -852,6 +865,8 @@ PermitTopicAcceptRemote
|
|||
-- Invite: Seeing existing-collaborator's Invite and new-collaborator's Accept,
|
||||
-- the topic has made the link official and sent a direct-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
|
||||
permit PermitPersonGestureId
|
||||
|
|
|
|||
Loading…
Reference in a new issue