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
|
# Person usernames who are allowed to create Factory actors
|
||||||
can-create-factories: []
|
can-create-factories: []
|
||||||
|
|
||||||
|
# KeyHashids of local Factory actors who will auto-send a develop-Grant to
|
||||||
|
# every newly created account
|
||||||
|
#
|
||||||
|
# If empty or unset, and there's exactly 1 local factory in DB, it will
|
||||||
|
# automatically become the resident
|
||||||
|
resident-factories: []
|
||||||
|
|
||||||
###############################################################################
|
###############################################################################
|
||||||
# Mail
|
# Mail
|
||||||
###############################################################################
|
###############################################################################
|
||||||
|
|
|
||||||
24
migrations/650_2024-08-03_fulfills_resident.model
Normal file
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
|
:: ( Actor a
|
||||||
, Eq (ActorKey a), Hashable (ActorKey a)
|
, Eq (ActorKey a), Hashable (ActorKey a)
|
||||||
)
|
)
|
||||||
=> (TVar (ActorRefMap a), (HashSet (ActorKey a), ActorMessage a))
|
=> (TVar (ActorRefMap a), Maybe (HashSet (ActorKey a), ActorMessage a))
|
||||||
-> IO ()
|
-> IO ()
|
||||||
hSendTo (tvar, (recips, msg)) = do
|
hSendTo (_ , Nothing) = pure ()
|
||||||
|
hSendTo (tvar, Just (recips, msg)) = do
|
||||||
allActors <- readTVarIO tvar
|
allActors <- readTVarIO tvar
|
||||||
for_ (HM.intersection allActors (HS.toMap recips)) $
|
for_ (HM.intersection allActors (HS.toMap recips)) $
|
||||||
\ actor -> sendIO' actor msg
|
\ actor -> sendIO' actor msg
|
||||||
|
|
@ -497,7 +498,7 @@ data HSendTo = HSendTo
|
||||||
instance
|
instance
|
||||||
( Actor a
|
( Actor a
|
||||||
, Eq (ActorKey a), Hashable (ActorKey a)
|
, Eq (ActorKey a), Hashable (ActorKey a)
|
||||||
, i ~ (TVar (ActorRefMap a), (HashSet (ActorKey a), ActorMessage a))
|
, i ~ (TVar (ActorRefMap a), Maybe (HashSet (ActorKey a), ActorMessage a))
|
||||||
) =>
|
) =>
|
||||||
H.ApplyAB HSendTo i (IO ()) where
|
H.ApplyAB HSendTo i (IO ()) where
|
||||||
applyAB _ a = hSendTo a
|
applyAB _ a = hSendTo a
|
||||||
|
|
@ -509,7 +510,7 @@ type instance Eval (B_ a) =
|
||||||
)
|
)
|
||||||
|
|
||||||
data Set_ :: Type -> Exp Type
|
data Set_ :: Type -> Exp Type
|
||||||
type instance Eval (Set_ a) = (HashSet (ActorKey a), ActorMessage a)
|
type instance Eval (Set_ a) = Maybe (HashSet (ActorKey a), ActorMessage a)
|
||||||
|
|
||||||
data Pair__ :: Type -> Exp Type
|
data Pair__ :: Type -> Exp Type
|
||||||
type instance Eval (Pair__ a) = (Eval (Item_ a), Eval (Set_ a))
|
type instance Eval (Pair__ a) = (Eval (Item_ a), Eval (Set_ a))
|
||||||
|
|
|
||||||
|
|
@ -147,7 +147,7 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
|
||||||
let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap
|
let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap
|
||||||
msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action
|
msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action
|
||||||
maybeResult <-
|
maybeResult <-
|
||||||
liftIO $ callIO theater personID (MsgP $ Right msg)
|
liftIO $ callIO theater personID (PersonMsgClient msg)
|
||||||
itemText <-
|
itemText <-
|
||||||
case maybeResult of
|
case maybeResult of
|
||||||
Nothing -> error "Person not found in theater"
|
Nothing -> error "Person not found in theater"
|
||||||
|
|
@ -1150,7 +1150,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
||||||
|
|
||||||
insertLoom now name msummary obiidCreate repoID = do
|
insertLoom now name msummary obiidCreate repoID = do
|
||||||
actor@(Entity actorID _) <-
|
actor@(Entity actorID _) <-
|
||||||
insertActor now name (fromMaybe "" msummary) (Just $ personActor personUser)
|
insertActor now name (fromMaybe "" msummary) $ Left (error "insertLoom1", error "insertLoom2", obiidCreate)
|
||||||
resourceID <- insert $ Resource actorID
|
resourceID <- insert $ Resource actorID
|
||||||
komponentID <- insert $ Komponent resourceID
|
komponentID <- insert $ Komponent resourceID
|
||||||
loomID <- insert Loom
|
loomID <- insert Loom
|
||||||
|
|
@ -1159,7 +1159,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
||||||
, loomResource = resourceID
|
, loomResource = resourceID
|
||||||
, loomKomponent = komponentID
|
, loomKomponent = komponentID
|
||||||
, loomRepo = repoID
|
, loomRepo = repoID
|
||||||
, loomCreate = obiidCreate
|
--, loomCreate = obiidCreate
|
||||||
}
|
}
|
||||||
return (loomID, resourceID, actor)
|
return (loomID, resourceID, actor)
|
||||||
|
|
||||||
|
|
@ -1185,7 +1185,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
||||||
repo = encodeRouteHome $ RepoR repoHash
|
repo = encodeRouteHome $ RepoR repoHash
|
||||||
specific = CreateActivity Create
|
specific = CreateActivity Create
|
||||||
{ createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal))
|
{ createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal))
|
||||||
, createTarget = Nothing
|
, createOrigin = Nothing
|
||||||
}
|
}
|
||||||
return action { actionSpecific = specific }
|
return action { actionSpecific = specific }
|
||||||
|
|
||||||
|
|
@ -1395,7 +1395,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
||||||
|
|
||||||
insertRepo now name msummary createID = do
|
insertRepo now name msummary createID = do
|
||||||
actor@(Entity actorID _) <-
|
actor@(Entity actorID _) <-
|
||||||
insertActor now name (fromMaybe "" msummary) (Just $ personActor personUser)
|
insertActor now name (fromMaybe "" msummary) $ Left (error "insertRepo1", error "insertRepo2", createID)
|
||||||
resourceID <- insert $ Resource actorID
|
resourceID <- insert $ Resource actorID
|
||||||
komponentID <- insert $ Komponent resourceID
|
komponentID <- insert $ Komponent resourceID
|
||||||
repoID <- insert Repo
|
repoID <- insert Repo
|
||||||
|
|
@ -1405,7 +1405,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
||||||
, repoActor = actorID
|
, repoActor = actorID
|
||||||
, repoResource = resourceID
|
, repoResource = resourceID
|
||||||
, repoKomponent = komponentID
|
, repoKomponent = komponentID
|
||||||
, repoCreate = createID
|
--, repoCreate = createID
|
||||||
, repoLoom = Nothing
|
, repoLoom = Nothing
|
||||||
}
|
}
|
||||||
return (repoID, resourceID, actor)
|
return (repoID, resourceID, actor)
|
||||||
|
|
@ -1430,7 +1430,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
||||||
}
|
}
|
||||||
specific = CreateActivity Create
|
specific = CreateActivity Create
|
||||||
{ createObject = CreateRepository rdetail vcs (Just (hLocal, rlocal))
|
{ createObject = CreateRepository rdetail vcs (Just (hLocal, rlocal))
|
||||||
, createTarget = Nothing
|
, createOrigin = Nothing
|
||||||
}
|
}
|
||||||
return action { actionSpecific = specific }
|
return action { actionSpecific = specific }
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -506,12 +506,17 @@ instance Actor Person where
|
||||||
type ActorStage Person = Staje
|
type ActorStage Person = Staje
|
||||||
type ActorKey Person = PersonId
|
type ActorKey Person = PersonId
|
||||||
type ActorReturn Person = Either Text Text
|
type ActorReturn Person = Either Text Text
|
||||||
data ActorMessage Person = MsgP (Either Verse ClientMsg)
|
data ActorMessage Person
|
||||||
|
= PersonMsgVerse Verse
|
||||||
|
| PersonMsgClient ClientMsg
|
||||||
|
| PersonMsgInit
|
||||||
instance Actor Deck where
|
instance Actor Deck where
|
||||||
type ActorStage Deck = Staje
|
type ActorStage Deck = Staje
|
||||||
type ActorKey Deck = DeckId
|
type ActorKey Deck = DeckId
|
||||||
type ActorReturn Deck = Either Text Text
|
type ActorReturn Deck = Either Text Text
|
||||||
data ActorMessage Deck = MsgD Verse
|
data ActorMessage Deck
|
||||||
|
= DeckMsgVerse Verse
|
||||||
|
| DeckMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
|
||||||
instance Actor Loom where
|
instance Actor Loom where
|
||||||
type ActorStage Loom = Staje
|
type ActorStage Loom = Staje
|
||||||
type ActorKey Loom = LoomId
|
type ActorKey Loom = LoomId
|
||||||
|
|
@ -526,33 +531,40 @@ instance Actor Project where
|
||||||
type ActorStage Project = Staje
|
type ActorStage Project = Staje
|
||||||
type ActorKey Project = ProjectId
|
type ActorKey Project = ProjectId
|
||||||
type ActorReturn Project = Either Text Text
|
type ActorReturn Project = Either Text Text
|
||||||
data ActorMessage Project = MsgJ Verse
|
data ActorMessage Project
|
||||||
|
= ProjectMsgVerse Verse
|
||||||
|
| ProjectMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
|
||||||
instance Actor Group where
|
instance Actor Group where
|
||||||
type ActorStage Group = Staje
|
type ActorStage Group = Staje
|
||||||
type ActorKey Group = GroupId
|
type ActorKey Group = GroupId
|
||||||
type ActorReturn Group = Either Text Text
|
type ActorReturn Group = Either Text Text
|
||||||
data ActorMessage Group = MsgG Verse
|
data ActorMessage Group
|
||||||
|
= TeamMsgVerse Verse
|
||||||
|
| TeamMsgInit (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI))
|
||||||
instance Actor Factory where
|
instance Actor Factory where
|
||||||
type ActorStage Factory = Staje
|
type ActorStage Factory = Staje
|
||||||
type ActorKey Factory = FactoryId
|
type ActorKey Factory = FactoryId
|
||||||
type ActorReturn Factory = Either Text Text
|
type ActorReturn Factory = Either Text Text
|
||||||
data ActorMessage Factory = MsgF Verse
|
data ActorMessage Factory
|
||||||
|
= FactoryMsgVerse Verse
|
||||||
|
| FactoryMsgVerified PersonId
|
||||||
|
|
||||||
instance VervisActor Person where
|
instance VervisActor Person where
|
||||||
actorVerse = MsgP . Left
|
actorVerse = PersonMsgVerse
|
||||||
toVerse (MsgP e) =
|
toVerse (PersonMsgVerse v) = Just v
|
||||||
case e of
|
toVerse _ = Nothing
|
||||||
Left v -> Just v
|
|
||||||
Right _ -> Nothing
|
|
||||||
instance VervisActor Project where
|
instance VervisActor Project where
|
||||||
actorVerse = MsgJ
|
actorVerse = ProjectMsgVerse
|
||||||
toVerse (MsgJ v) = Just v
|
toVerse (ProjectMsgVerse v) = Just v
|
||||||
|
toVerse _ = Nothing
|
||||||
instance VervisActor Group where
|
instance VervisActor Group where
|
||||||
actorVerse = MsgG
|
actorVerse = TeamMsgVerse
|
||||||
toVerse (MsgG v) = Just v
|
toVerse (TeamMsgVerse v) = Just v
|
||||||
|
toVerse _ = Nothing
|
||||||
instance VervisActor Deck where
|
instance VervisActor Deck where
|
||||||
actorVerse = MsgD
|
actorVerse = DeckMsgVerse
|
||||||
toVerse (MsgD v) = Just v
|
toVerse (DeckMsgVerse v) = Just v
|
||||||
|
toVerse _ = Nothing
|
||||||
instance VervisActor Loom where
|
instance VervisActor Loom where
|
||||||
actorVerse = MsgL
|
actorVerse = MsgL
|
||||||
toVerse (MsgL v) = Just v
|
toVerse (MsgL v) = Just v
|
||||||
|
|
@ -563,8 +575,9 @@ instance VervisActor Repo where
|
||||||
Left v -> Just v
|
Left v -> Just v
|
||||||
Right _ -> Nothing
|
Right _ -> Nothing
|
||||||
instance VervisActor Factory where
|
instance VervisActor Factory where
|
||||||
actorVerse = MsgF
|
actorVerse = FactoryMsgVerse
|
||||||
toVerse (MsgF v) = Just v
|
toVerse (FactoryMsgVerse v) = Just v
|
||||||
|
toVerse _ = Nothing
|
||||||
|
|
||||||
instance Stage Staje where
|
instance Stage Staje where
|
||||||
data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env
|
data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env
|
||||||
|
|
@ -594,13 +607,17 @@ instance Stage Staje where
|
||||||
type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo, Factory]
|
type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo, Factory]
|
||||||
|
|
||||||
instance Message (ActorMessage Person) where
|
instance Message (ActorMessage Person) where
|
||||||
summarize (MsgP (Left verse)) = summarizeVerse verse
|
summarize (PersonMsgVerse verse) = summarizeVerse verse
|
||||||
summarize (MsgP (Right _)) = "ClientMsg"
|
summarize (PersonMsgClient _) = "PersonMsgClient"
|
||||||
refer (MsgP (Left verse)) = referVerse verse
|
summarize PersonMsgInit = "PersonMsgInit"
|
||||||
refer (MsgP (Right _)) = "ClientMsg"
|
refer (PersonMsgVerse verse) = referVerse verse
|
||||||
|
refer (PersonMsgClient _) = "PersonMsgClient"
|
||||||
|
refer PersonMsgInit = "PersonMsgInit"
|
||||||
instance Message (ActorMessage Deck) where
|
instance Message (ActorMessage Deck) where
|
||||||
summarize (MsgD verse) = summarizeVerse verse
|
summarize (DeckMsgVerse verse) = summarizeVerse verse
|
||||||
refer (MsgD verse) = referVerse verse
|
summarize (DeckMsgInit _) = "DeckMsgInit"
|
||||||
|
refer (DeckMsgVerse verse) = referVerse verse
|
||||||
|
refer (DeckMsgInit _) = "DeckMsgInit"
|
||||||
instance Message (ActorMessage Loom) where
|
instance Message (ActorMessage Loom) where
|
||||||
summarize (MsgL verse) = summarizeVerse verse
|
summarize (MsgL verse) = summarizeVerse verse
|
||||||
refer (MsgL verse) = referVerse verse
|
refer (MsgL verse) = referVerse verse
|
||||||
|
|
@ -610,14 +627,20 @@ instance Message (ActorMessage Repo) where
|
||||||
refer (MsgR (Left verse)) = referVerse verse
|
refer (MsgR (Left verse)) = referVerse verse
|
||||||
refer (MsgR (Right _)) = "WaitPushCompletion"
|
refer (MsgR (Right _)) = "WaitPushCompletion"
|
||||||
instance Message (ActorMessage Project) where
|
instance Message (ActorMessage Project) where
|
||||||
summarize (MsgJ verse) = summarizeVerse verse
|
summarize (ProjectMsgVerse verse) = summarizeVerse verse
|
||||||
refer (MsgJ verse) = referVerse verse
|
summarize (ProjectMsgInit _) = "ProjectMsgInit"
|
||||||
|
refer (ProjectMsgVerse verse) = referVerse verse
|
||||||
|
refer (ProjectMsgInit _) = "ProjectMsgInit"
|
||||||
instance Message (ActorMessage Group) where
|
instance Message (ActorMessage Group) where
|
||||||
summarize (MsgG verse) = summarizeVerse verse
|
summarize (TeamMsgVerse verse) = summarizeVerse verse
|
||||||
refer (MsgG verse) = referVerse verse
|
summarize (TeamMsgInit _) = "TeamMsgInit"
|
||||||
|
refer (TeamMsgVerse verse) = referVerse verse
|
||||||
|
refer (TeamMsgInit _) = "TeamMsgInit"
|
||||||
instance Message (ActorMessage Factory) where
|
instance Message (ActorMessage Factory) where
|
||||||
summarize (MsgF verse) = summarizeVerse verse
|
summarize (FactoryMsgVerse verse) = summarizeVerse verse
|
||||||
refer (MsgF verse) = referVerse verse
|
summarize (FactoryMsgVerified _) = "FactoryMsgVerified"
|
||||||
|
refer (FactoryMsgVerse verse) = referVerse verse
|
||||||
|
refer (FactoryMsgVerified _) = "FactoryMsgVerified"
|
||||||
|
|
||||||
type YesodRender y = Route y -> [(Text, Text)] -> Text
|
type YesodRender y = Route y -> [(Text, Text)] -> Text
|
||||||
|
|
||||||
|
|
@ -935,13 +958,13 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
||||||
partitionByActor liveRecips
|
partitionByActor liveRecips
|
||||||
verse = Verse authorAndId' body
|
verse = Verse authorAndId' body
|
||||||
sendMany $
|
sendMany $
|
||||||
(liveRecipsP, actorVerse verse) `H.HCons`
|
(Just (liveRecipsP, actorVerse verse)) `H.HCons`
|
||||||
(liveRecipsJ, actorVerse verse) `H.HCons`
|
(Just (liveRecipsJ, actorVerse verse)) `H.HCons`
|
||||||
(liveRecipsG, actorVerse verse) `H.HCons`
|
(Just (liveRecipsG, actorVerse verse)) `H.HCons`
|
||||||
(liveRecipsD, actorVerse verse) `H.HCons`
|
(Just (liveRecipsD, actorVerse verse)) `H.HCons`
|
||||||
(liveRecipsL, actorVerse verse) `H.HCons`
|
(Just (liveRecipsL, actorVerse verse)) `H.HCons`
|
||||||
(liveRecipsR, actorVerse verse) `H.HCons`
|
(Just (liveRecipsR, actorVerse verse)) `H.HCons`
|
||||||
(liveRecipsF, actorVerse verse) `H.HCons` H.HNil
|
(Just (liveRecipsF, actorVerse verse)) `H.HCons` H.HNil
|
||||||
|
|
||||||
-- Return remote followers, to whom we need to deliver via HTTP
|
-- Return remote followers, to whom we need to deliver via HTTP
|
||||||
return remoteFollowers
|
return remoteFollowers
|
||||||
|
|
|
||||||
|
|
@ -19,12 +19,14 @@
|
||||||
|
|
||||||
module Vervis.Actor.Common
|
module Vervis.Actor.Common
|
||||||
( actorFollow
|
( actorFollow
|
||||||
|
, actorFollow'
|
||||||
, topicAccept
|
, topicAccept
|
||||||
, topicReject
|
, topicReject
|
||||||
, componentInvite
|
, componentInvite
|
||||||
, componentRemove
|
, componentRemove
|
||||||
, topicJoin
|
, topicJoin
|
||||||
, topicCreateMe
|
, topicCreateMe
|
||||||
|
, topicInit
|
||||||
, componentGrant
|
, componentGrant
|
||||||
, componentAdd
|
, componentAdd
|
||||||
, componentRevoke
|
, componentRevoke
|
||||||
|
|
@ -86,11 +88,13 @@ import Vervis.Data.Actor
|
||||||
import Vervis.Data.Collab
|
import Vervis.Data.Collab
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
import Vervis.Model.Ident
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
import Vervis.Persist.Collab
|
import Vervis.Persist.Collab
|
||||||
import Vervis.Persist.Discussion
|
import Vervis.Persist.Discussion
|
||||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
|
import Vervis.Settings
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
import Vervis.Web.Collab
|
import Vervis.Web.Collab
|
||||||
|
|
||||||
|
|
@ -113,7 +117,24 @@ actorFollow
|
||||||
-> Verse
|
-> Verse
|
||||||
-> AP.Follow URIMode
|
-> AP.Follow URIMode
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID (Verse authorIdMsig body) (AP.Follow uObject _ hide) = do
|
actorFollow parseFollowee grabActor =
|
||||||
|
actorFollow' parseFollowee (pure . grabActor)
|
||||||
|
|
||||||
|
actorFollow'
|
||||||
|
:: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
|
||||||
|
=> (Route App -> ActE a)
|
||||||
|
-> (r -> ActDB ActorId)
|
||||||
|
-> Bool
|
||||||
|
-> (Actor -> a -> ActDBE FollowerSetId)
|
||||||
|
-> (a -> ActDB RecipientRoutes)
|
||||||
|
-> (forall f. f r -> LocalActorBy f)
|
||||||
|
-> (a -> Act [Aud URIMode])
|
||||||
|
-> UTCTime
|
||||||
|
-> Key r
|
||||||
|
-> Verse
|
||||||
|
-> AP.Follow URIMode
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
actorFollow' parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID (Verse authorIdMsig body) (AP.Follow uObject _ hide) = do
|
||||||
|
|
||||||
-- Check input
|
-- Check input
|
||||||
followee <- nameExceptT "Follow object" $ do
|
followee <- nameExceptT "Follow object" $ do
|
||||||
|
|
@ -132,7 +153,7 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
||||||
|
|
||||||
-- Find me in DB
|
-- Find me in DB
|
||||||
recip <- lift $ getJust recipID
|
recip <- lift $ getJust recipID
|
||||||
let recipActorID = grabActor recip
|
recipActorID <- lift $ grabActor recip
|
||||||
recipActor <- lift $ getJust recipActorID
|
recipActor <- lift $ getJust recipActorID
|
||||||
|
|
||||||
-- Insert the Follow to my inbox
|
-- Insert the Follow to my inbox
|
||||||
|
|
@ -2248,82 +2269,148 @@ topicJoin grabResource topicResource now topicKey (Verse authorIdMsig body) join
|
||||||
recipID <- insert $ CollabRecipRemote collabID authorID
|
recipID <- insert $ CollabRecipRemote collabID authorID
|
||||||
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
|
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
|
||||||
|
|
||||||
|
-- Meaning: Someone has created an actor with my ID URI
|
||||||
|
-- Behavior:
|
||||||
|
-- * Verify I have no Collab records, implying just-been-created state
|
||||||
|
-- * Verify my (local!) creator and the Create sender are the same actor
|
||||||
|
-- * Possibly: Verify the creator is in the can-create-factories list
|
||||||
|
-- * Possibly:
|
||||||
|
-- If I'm the first in my table and listed as resident (or no
|
||||||
|
-- residents are listed),
|
||||||
|
-- send out develop-Grants (and create Collab records) to all verified
|
||||||
|
-- local Persons
|
||||||
|
-- * Create an admin Collab record in DB
|
||||||
|
-- * Send an admin Grant to the creator
|
||||||
topicCreateMe
|
topicCreateMe
|
||||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||||
=> (topic -> ResourceId)
|
=> Bool
|
||||||
|
-> Bool
|
||||||
|
-> (topic -> ResourceId)
|
||||||
-> (forall f. f topic -> LocalResourceBy f)
|
-> (forall f. f topic -> LocalResourceBy f)
|
||||||
-> UTCTime
|
-> UTCTime
|
||||||
-> Key topic
|
-> Key topic
|
||||||
-> Verse
|
-> Verse
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body) = do
|
topicCreateMe checkCan sendGrants grabResource meToResource now meID (Verse authorIdMsig body) = do
|
||||||
|
|
||||||
maybeNew <- withDBExcept $ do
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
-- Grab me from DB
|
-- Grab me from DB
|
||||||
resourceID <- lift $ grabResource <$> getJust recipKey
|
resourceMeID <- lift $ grabResource <$> getJust meID
|
||||||
Resource recipActorID <- lift $ getJust resourceID
|
Resource actorMeID <- lift $ getJust resourceMeID
|
||||||
recipActor <- lift $ getJust recipActorID
|
actorMe <- lift $ getJust actorMeID
|
||||||
|
|
||||||
-- Verify I'm in the initial just-been-created state
|
-- Verify I'm in initial state
|
||||||
creatorActorID <-
|
creatorActorID <- do
|
||||||
fromMaybeE
|
create <-
|
||||||
(actorJustCreatedBy recipActor)
|
lift $
|
||||||
"I already sent the initial Grant, why am I receiving this Create?"
|
requireEitherAlt
|
||||||
|
(getValBy $ UniqueActorCreateLocalActor actorMeID)
|
||||||
|
(getValBy $ UniqueActorCreateRemoteActor actorMeID)
|
||||||
|
"Neither local nor remote"
|
||||||
|
"Both local and remote"
|
||||||
|
case create of
|
||||||
|
Left (ActorCreateLocal _ createID) -> do
|
||||||
|
OutboxItem outboxID _ _ <- lift $ getJust createID
|
||||||
|
mk <- lift $ getKeyBy $ UniqueActorOutbox outboxID
|
||||||
|
fromMaybeE mk "Creator actor not found"
|
||||||
|
Right _ -> error "topicCreateMe used on a remotely-created actor"
|
||||||
creatorPersonID <- do
|
creatorPersonID <- do
|
||||||
mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID
|
mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID
|
||||||
fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently"
|
fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently"
|
||||||
existingCollabIDs <-
|
existingCollabIDs <-
|
||||||
lift $ selectList [CollabTopic ==. resourceID] []
|
lift $ selectList [CollabTopic ==. resourceMeID] []
|
||||||
unless (null existingCollabIDs) $
|
unless (null existingCollabIDs) $
|
||||||
error "Just-been-created but I somehow already have Collabs"
|
throwE "I already have Collab records"
|
||||||
|
|
||||||
-- Verify the Create author is my creator indeed
|
-- Verify the Create author is my creator indeed
|
||||||
case authorIdMsig of
|
case authorIdMsig of
|
||||||
Left (_, actorID, _) | actorID == creatorActorID -> pure ()
|
Left (_, actorID, _) | actorID == creatorActorID -> pure ()
|
||||||
_ -> throwE "Create author isn't why I believe my creator is - is this Create fake?"
|
_ -> throwE "Create author isn't why I believe my creator is - is this Create fake?"
|
||||||
|
|
||||||
maybeCreateDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
-- Verify creator is in can-create-factories list
|
||||||
|
when checkCan $ do
|
||||||
|
u <- lift $ personUsername <$> getJust creatorPersonID
|
||||||
|
cans <- asksEnv $ appCanCreateFactories . envSettings
|
||||||
|
unless (u `elem` map text2username cans) $
|
||||||
|
throwE "Creator person isn't in can-create-factories list"
|
||||||
|
|
||||||
|
maybeCreateDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False
|
||||||
lift $ for maybeCreateDB $ \ (inboxItemID, _createDB) -> do
|
lift $ for maybeCreateDB $ \ (inboxItemID, _createDB) -> do
|
||||||
|
|
||||||
-- Create a Collab record and exit just-been-created state
|
-- Create a Collab record
|
||||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
grantID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||||
insertCollab resourceID creatorPersonID grantID
|
insertCollab resourceMeID creatorPersonID grantID
|
||||||
update creatorActorID [ActorJustCreatedBy =. Nothing]
|
|
||||||
|
|
||||||
-- Prepare a Grant activity and insert to my outbox
|
-- Prepare a Grant activity and insert to my outbox
|
||||||
grant@(actionGrant, _, _, _) <- lift prepareGrant
|
grant@(actionGrant, _, _, _) <- lift prepareGrant
|
||||||
let recipByKey = resourceToActor $ topicResource recipKey
|
let recipByKey = resourceToActor $ meToResource meID
|
||||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||||
|
|
||||||
return (recipActorID, grantID, grant, inboxItemID)
|
writes <-
|
||||||
|
if sendGrants
|
||||||
|
then do
|
||||||
|
residents <- asksEnv $ appResidentFactories . envSettings
|
||||||
|
meHash <- encodeKeyHashid meID
|
||||||
|
let meHashText = keyHashidText meHash
|
||||||
|
ids <- selectKeysList [] []
|
||||||
|
let meResident =
|
||||||
|
null residents || meHashText `elem` residents
|
||||||
|
if meResident && ids == [meID]
|
||||||
|
then do
|
||||||
|
ps <- selectList [PersonId !=. creatorPersonID, PersonVerified ==. True] []
|
||||||
|
for ps $ \ p@(Entity personID _) -> do
|
||||||
|
|
||||||
|
writeID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||||
|
insertResidentCollab resourceMeID personID writeID
|
||||||
|
|
||||||
|
write@(actionWrite, _, _, _) <- prepareResidentGrant p
|
||||||
|
let recipByKey = resourceToActor $ meToResource meID
|
||||||
|
_luWrite <- updateOutboxItem' recipByKey writeID actionWrite
|
||||||
|
|
||||||
|
return (writeID, write)
|
||||||
|
else pure []
|
||||||
|
else pure []
|
||||||
|
|
||||||
|
return (actorMeID, grantID, grant, writes, inboxItemID)
|
||||||
|
|
||||||
case maybeNew of
|
case maybeNew of
|
||||||
Nothing -> done "I already have this activity in my inbox"
|
Nothing -> done "I already have this activity in my inbox"
|
||||||
Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), inboxItemID) -> do
|
Just (actorMeID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), writes, inboxItemID) -> do
|
||||||
let recipByID = resourceToActor $ topicResource recipKey
|
let recipByID = resourceToActor $ meToResource meID
|
||||||
lift $ sendActivity
|
lift $ do
|
||||||
recipByID recipActorID localRecipsGrant
|
sendActivity
|
||||||
|
recipByID actorMeID localRecipsGrant
|
||||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||||
doneDB inboxItemID "Created a Collab record and published a Grant"
|
for_ writes $ \ (writeID, (actionWrite, localRecipsWrite, remoteRecipsWrite, fwdHostsWrite)) ->
|
||||||
|
sendActivity
|
||||||
|
recipByID actorMeID localRecipsWrite
|
||||||
|
remoteRecipsWrite fwdHostsWrite writeID actionWrite
|
||||||
|
doneDB inboxItemID "Created a Collab record and published a Grant, possibly sent write-Grants"
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
insertCollab resourceID personID grantID = do
|
insertCollab resourceMeID personID grantID = do
|
||||||
collabID <- insert $ Collab AP.RoleAdmin resourceID
|
collabID <- insert $ Collab AP.RoleAdmin resourceMeID
|
||||||
insert_ $ CollabEnable collabID grantID
|
insert_ $ CollabEnable collabID grantID
|
||||||
insert_ $ CollabRecipLocal collabID personID
|
insert_ $ CollabRecipLocal collabID personID
|
||||||
insert_ $ CollabFulfillsLocalTopicCreation collabID
|
insert_ $ CollabFulfillsLocalTopicCreation collabID
|
||||||
|
|
||||||
|
insertResidentCollab resourceMeID personID grantID = do
|
||||||
|
collabID <- insert $ Collab AP.RoleWrite resourceMeID
|
||||||
|
insert_ $ CollabEnable collabID grantID
|
||||||
|
insert_ $ CollabRecipLocal collabID personID
|
||||||
|
insert_ $ CollabFulfillsResidentFactory collabID
|
||||||
|
|
||||||
prepareGrant = do
|
prepareGrant = do
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
audCreator <- makeAudSenderOnly authorIdMsig
|
audCreator <- makeAudSenderOnly authorIdMsig
|
||||||
recipHash <- encodeKeyHashid recipKey
|
recipHash <- encodeKeyHashid meID
|
||||||
uCreator <- getActorURI authorIdMsig
|
uCreator <- getActorURI authorIdMsig
|
||||||
uCreate <- getActivityURI authorIdMsig
|
uCreate <- getActivityURI authorIdMsig
|
||||||
let topicByHash = resourceToActor $ topicResource recipHash
|
let topicByHash = resourceToActor $ meToResource recipHash
|
||||||
audience =
|
audience =
|
||||||
let audTopic = AudLocal [] [localActorFollowers topicByHash]
|
let audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||||
in [audCreator, audTopic]
|
in [audCreator, audTopic]
|
||||||
|
|
@ -2352,6 +2439,167 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body)
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
prepareResidentGrant (Entity personID person) = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
personHash <- encodeKeyHashid personID
|
||||||
|
let audPerson = AudLocal [LocalActorPerson personHash] []
|
||||||
|
meHash <- encodeKeyHashid meID
|
||||||
|
uCreate <- do
|
||||||
|
selfCreateID <- do
|
||||||
|
mc <- getValBy $ UniqueActorCreateLocalActor $ personActor person
|
||||||
|
case mc of
|
||||||
|
Nothing -> error "Person doesn't have an ActorCreateLocal record"
|
||||||
|
Just c -> pure $ actorCreateLocalCreate c
|
||||||
|
createHash <- encodeKeyHashid selfCreateID
|
||||||
|
return $ encodeRouteHome $ PersonOutboxItemR personHash createHash
|
||||||
|
let topicByHash = resourceToActor $ meToResource meHash
|
||||||
|
audience =
|
||||||
|
let audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||||
|
in [audPerson, audTopic]
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience audience
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Nothing
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = [uCreate]
|
||||||
|
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||||
|
{ AP.grantObject = AP.RXRole AP.RoleWrite
|
||||||
|
, AP.grantContext =
|
||||||
|
encodeRouteHome $ renderLocalActor topicByHash
|
||||||
|
, AP.grantTarget = encodeRouteHome $ PersonR personHash
|
||||||
|
, AP.grantResult = Nothing
|
||||||
|
, AP.grantStart = Just now
|
||||||
|
, AP.grantEnd = Nothing
|
||||||
|
, AP.grantAllows = AP.Invoke
|
||||||
|
, AP.grantDelegates = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
-- Meaning: I've just been created
|
||||||
|
-- Behavior:
|
||||||
|
-- * Verify my creator and the Create sender are the same actor
|
||||||
|
-- * Create an admin Collab record in DB
|
||||||
|
-- * Send an admin Grant to the creator
|
||||||
|
topicInit
|
||||||
|
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||||
|
=> (topic -> ActDB ResourceId)
|
||||||
|
-> (forall f. f topic -> LocalResourceBy f)
|
||||||
|
-> UTCTime
|
||||||
|
-> Key topic
|
||||||
|
-> Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
topicInit grabResource meToResource now meID creator = do
|
||||||
|
|
||||||
|
(actorMeID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) <- withDBExcept $ do
|
||||||
|
|
||||||
|
-- Grab me from DB
|
||||||
|
resourceMeID <- lift $ grabResource =<< getJust meID
|
||||||
|
Resource actorMeID <- lift $ getJust resourceMeID
|
||||||
|
actorMe <- lift $ getJust actorMeID
|
||||||
|
|
||||||
|
-- Verify I don't have any Collab records
|
||||||
|
collabIDs <- lift $ selectKeysList [CollabTopic ==. resourceMeID] []
|
||||||
|
unless (null collabIDs) $
|
||||||
|
throwE "I already have Collab records"
|
||||||
|
|
||||||
|
-- Verify my creator in DB and the one passed to me are the same actor
|
||||||
|
create <-
|
||||||
|
lift $
|
||||||
|
requireEitherAlt
|
||||||
|
(getValBy $ UniqueActorCreateLocalActor actorMeID)
|
||||||
|
(getValBy $ UniqueActorCreateRemoteActor actorMeID)
|
||||||
|
"Neither local nor remote"
|
||||||
|
"Both local and remote"
|
||||||
|
let create' =
|
||||||
|
bimap actorCreateLocalCreate actorCreateRemoteSender create
|
||||||
|
creator' =
|
||||||
|
bimap (view _3) (remoteAuthorId . fst) creator
|
||||||
|
unless (create' == creator') $
|
||||||
|
throwE "Creator in DB and in argument aren't the same"
|
||||||
|
|
||||||
|
-- If creator is local, verify it's a Person, because the DB schema
|
||||||
|
-- currently allows only Person to be the recipient of a Collab
|
||||||
|
let verifyIsPerson = \case
|
||||||
|
LocalActorPerson p -> pure p
|
||||||
|
_ -> throwE "Local creator isn't a Person"
|
||||||
|
creatorPerson <-
|
||||||
|
traverseOf _Left (traverseOf _1 verifyIsPerson) creator
|
||||||
|
|
||||||
|
-- Create a Collab record
|
||||||
|
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||||
|
lift $ insertCollab resourceMeID creatorPerson grantID
|
||||||
|
|
||||||
|
-- Prepare a Grant activity and insert to my outbox
|
||||||
|
grant@(actionGrant, _, _, _) <- lift $ lift prepareGrant
|
||||||
|
let recipByKey = resourceToActor $ meToResource meID
|
||||||
|
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
|
||||||
|
|
||||||
|
return (actorMeID, grantID, grant)
|
||||||
|
|
||||||
|
let recipByID = resourceToActor $ meToResource meID
|
||||||
|
lift $ sendActivity
|
||||||
|
recipByID actorMeID localRecipsGrant
|
||||||
|
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||||
|
done "Created a Collab record and published a Grant"
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
insertCollab resourceMeID creatorPerson grantID = do
|
||||||
|
collabID <- insert $ Collab AP.RoleAdmin resourceMeID
|
||||||
|
insert_ $ CollabEnable collabID grantID
|
||||||
|
case creatorPerson of
|
||||||
|
Left (personID, _, _) ->
|
||||||
|
insert_ $ CollabRecipLocal collabID personID
|
||||||
|
Right (author, _) ->
|
||||||
|
insert_ $ CollabRecipRemote collabID (remoteAuthorId author)
|
||||||
|
insert_ $ CollabFulfillsLocalTopicCreation collabID
|
||||||
|
|
||||||
|
prepareGrant = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
let creatorMsig = second (\ (ra, lu) -> (ra, lu, Nothing)) creator
|
||||||
|
audCreator <- makeAudSenderOnly creatorMsig
|
||||||
|
meHash <- encodeKeyHashid meID
|
||||||
|
uCreator <- getActorURI creatorMsig
|
||||||
|
uCreate <- getActivityURI creatorMsig
|
||||||
|
let meActorHash = resourceToActor $ meToResource meHash
|
||||||
|
audience =
|
||||||
|
let audMe = AudLocal [] [localActorFollowers meActorHash]
|
||||||
|
in [audCreator, audMe]
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience audience
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Nothing
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = [uCreate]
|
||||||
|
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||||
|
{ AP.grantObject = AP.RXRole AP.RoleAdmin
|
||||||
|
, AP.grantContext =
|
||||||
|
encodeRouteHome $ renderLocalActor meActorHash
|
||||||
|
, AP.grantTarget = uCreator
|
||||||
|
, AP.grantResult = Nothing
|
||||||
|
, AP.grantStart = Just now
|
||||||
|
, AP.grantEnd = Nothing
|
||||||
|
, AP.grantAllows = AP.Invoke
|
||||||
|
, AP.grantDelegates = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
-- Meaning: An actor is granting access-to-some-resource to another actor
|
-- Meaning: An actor is granting access-to-some-resource to another actor
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * If I approved an Add-to-project where I'm the component, and the
|
-- * If I approved an Add-to-project where I'm the component, and the
|
||||||
|
|
|
||||||
|
|
@ -107,42 +107,6 @@ deckAdd
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
deckAdd = componentAdd deckKomponent ComponentDeck
|
deckAdd = componentAdd deckKomponent ComponentDeck
|
||||||
|
|
||||||
-- Meaning: Someone has created a ticket tracker with my ID URI
|
|
||||||
-- Behavior:
|
|
||||||
-- * Verify I'm in a just-been-created state
|
|
||||||
-- * Verify my creator and the Create sender are the same actor
|
|
||||||
-- * Create an admin Collab record in DB
|
|
||||||
-- * Send an admin Grant to the creator
|
|
||||||
-- * Get out of the just-been-created state
|
|
||||||
deckCreateMe
|
|
||||||
:: UTCTime
|
|
||||||
-> DeckId
|
|
||||||
-> Verse
|
|
||||||
-> ActE (Text, Act (), Next)
|
|
||||||
deckCreateMe = topicCreateMe deckResource LocalResourceDeck
|
|
||||||
|
|
||||||
deckCreate
|
|
||||||
:: UTCTime
|
|
||||||
-> DeckId
|
|
||||||
-> Verse
|
|
||||||
-> AP.Create URIMode
|
|
||||||
-> ActE (Text, Act (), Next)
|
|
||||||
deckCreate now deckID verse (AP.Create obj _muTarget) =
|
|
||||||
case obj of
|
|
||||||
|
|
||||||
AP.CreateTicketTracker _ mlocal -> do
|
|
||||||
(h, local) <- fromMaybeE mlocal "No tracker id provided"
|
|
||||||
let luTracker = AP.actorId local
|
|
||||||
uMe <- do
|
|
||||||
deckHash <- encodeKeyHashid deckID
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
return $ encodeRouteHome $ DeckR deckHash
|
|
||||||
unless (uMe == ObjURI h luTracker) $
|
|
||||||
throwE "The created tracker id isn't me"
|
|
||||||
deckCreateMe now deckID verse
|
|
||||||
|
|
||||||
_ -> throwE "Unsupported Create object for Deck"
|
|
||||||
|
|
||||||
-- Meaning: An actor A is offering a ticket or a ticket dependency
|
-- Meaning: An actor A is offering a ticket or a ticket dependency
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Verify I'm the target
|
-- * Verify I'm the target
|
||||||
|
|
@ -822,11 +786,10 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
deckBehavior :: UTCTime -> DeckId -> ActorMessage Deck -> ActE (Text, Act (), Next)
|
deckBehavior :: UTCTime -> DeckId -> ActorMessage Deck -> ActE (Text, Act (), Next)
|
||||||
deckBehavior now deckID (MsgD verse@(Verse _authorIdMsig body)) =
|
deckBehavior now deckID (DeckMsgVerse verse@(Verse _authorIdMsig body)) =
|
||||||
case AP.activitySpecific $ actbActivity body of
|
case AP.activitySpecific $ actbActivity body of
|
||||||
AP.AcceptActivity accept -> deckAccept now deckID verse accept
|
AP.AcceptActivity accept -> deckAccept now deckID verse accept
|
||||||
AP.AddActivity add -> deckAdd now deckID verse add
|
AP.AddActivity add -> deckAdd now deckID verse add
|
||||||
AP.CreateActivity create -> deckCreate now deckID verse create
|
|
||||||
AP.FollowActivity follow -> deckFollow now deckID verse follow
|
AP.FollowActivity follow -> deckFollow now deckID verse follow
|
||||||
AP.GrantActivity grant -> deckGrant now deckID verse grant
|
AP.GrantActivity grant -> deckGrant now deckID verse grant
|
||||||
AP.InviteActivity invite -> deckInvite now deckID verse invite
|
AP.InviteActivity invite -> deckInvite now deckID verse invite
|
||||||
|
|
@ -838,6 +801,9 @@ deckBehavior now deckID (MsgD verse@(Verse _authorIdMsig body)) =
|
||||||
AP.RevokeActivity revoke -> deckRevoke now deckID verse revoke
|
AP.RevokeActivity revoke -> deckRevoke now deckID verse revoke
|
||||||
AP.UndoActivity undo -> deckUndo now deckID verse undo
|
AP.UndoActivity undo -> deckUndo now deckID verse undo
|
||||||
_ -> throwE "Unsupported activity type for Deck"
|
_ -> throwE "Unsupported activity type for Deck"
|
||||||
|
deckBehavior now deckID (DeckMsgInit creator) =
|
||||||
|
let grabResource = fmap komponentResource . getJust . deckKomponent
|
||||||
|
in topicInit grabResource LocalResourceDeck now deckID creator
|
||||||
|
|
||||||
instance VervisActorLaunch Deck where
|
instance VervisActorLaunch Deck where
|
||||||
actorBehavior' now deckID ve = do
|
actorBehavior' now deckID ve = do
|
||||||
|
|
|
||||||
|
|
@ -18,43 +18,451 @@ module Vervis.Actor.Factory
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Exception.Base
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger.CallStack
|
import Control.Monad.Logger.CallStack
|
||||||
import Control.Monad.Trans.Class
|
import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.Maybe
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Control.Monad.Trans.Reader
|
||||||
|
import Data.Barbie
|
||||||
|
import Data.Bifoldable
|
||||||
|
import Data.Bifunctor
|
||||||
|
import Data.Bitraversable
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.Either
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
|
import Data.Maybe
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
|
import Data.Traversable
|
||||||
import Database.Persist
|
import Database.Persist
|
||||||
|
import Database.Persist.Sql
|
||||||
|
import Optics.Core
|
||||||
import Yesod.Persist.Core
|
import Yesod.Persist.Core
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
import Control.Concurrent.Actor
|
import Control.Concurrent.Actor
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
|
import Web.Actor
|
||||||
|
import Web.Actor.Persist
|
||||||
import Yesod.MonadSite
|
import Yesod.MonadSite
|
||||||
|
|
||||||
import qualified Web.ActivityPub as AP
|
import qualified Web.ActivityPub as AP
|
||||||
|
|
||||||
import Control.Monad.Trans.Except.Local
|
import Control.Monad.Trans.Except.Local
|
||||||
|
import Data.Either.Local
|
||||||
import Database.Persist.Local
|
import Database.Persist.Local
|
||||||
|
|
||||||
|
import Vervis.Access
|
||||||
|
import Vervis.ActivityPub
|
||||||
import Vervis.Actor
|
import Vervis.Actor
|
||||||
|
import Vervis.Actor.Common
|
||||||
|
import Vervis.Actor.Deck
|
||||||
|
import Vervis.Actor.Group
|
||||||
|
import Vervis.Actor.Project
|
||||||
|
import Vervis.Actor2
|
||||||
|
import Vervis.Cloth
|
||||||
|
import Vervis.Data.Actor
|
||||||
|
import Vervis.Data.Collab
|
||||||
import Vervis.Data.Discussion
|
import Vervis.Data.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
|
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||||
|
import Vervis.RemoteActorStore
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
|
import Vervis.Persist.Collab
|
||||||
import Vervis.Persist.Discussion
|
import Vervis.Persist.Discussion
|
||||||
|
import Vervis.Settings
|
||||||
|
import Vervis.Ticket
|
||||||
|
import Vervis.Web.Collab
|
||||||
|
|
||||||
|
data NewActor = NADeck | NAProject | NATeam
|
||||||
|
|
||||||
|
factoryCreateMe
|
||||||
|
:: UTCTime
|
||||||
|
-> FactoryId
|
||||||
|
-> Verse
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
factoryCreateMe = topicCreateMe True True factoryResource LocalResourceFactory
|
||||||
|
|
||||||
|
-- Meaning: An actor is asking me to create a new actor
|
||||||
|
-- Behavior:
|
||||||
|
-- * Create a record on DB
|
||||||
|
-- * Launch the actor
|
||||||
|
-- * Forward the Create to followers
|
||||||
|
-- * Send Accept on the Create, with result being the new actor's URI
|
||||||
|
factoryCreateNew
|
||||||
|
:: NewActor
|
||||||
|
-> UTCTime
|
||||||
|
-> FactoryId
|
||||||
|
-> Verse
|
||||||
|
-> AP.ActorDetail
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
factoryCreateNew new now factoryMeID (Verse authorIdMsig body) detail = do
|
||||||
|
|
||||||
|
-- Check input
|
||||||
|
(name, msummary) <- parseDetail detail
|
||||||
|
|
||||||
|
-- Verify that a capability is provided
|
||||||
|
uCap <- do
|
||||||
|
let muCap = AP.activityCapability $ actbActivity body
|
||||||
|
fromMaybeE muCap "No capability provided"
|
||||||
|
|
||||||
|
-- Verify the sender is authorized by me to create actors
|
||||||
|
verifyCapability''
|
||||||
|
uCap
|
||||||
|
authorIdMsig
|
||||||
|
(LocalResourceFactory factoryMeID)
|
||||||
|
AP.RoleWrite
|
||||||
|
|
||||||
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
|
-- Grab me from DB
|
||||||
|
factoryMe <- lift $ getJust factoryMeID
|
||||||
|
let resourceMeID = factoryResource factoryMe
|
||||||
|
Resource actorMeID <- lift $ getJust resourceMeID
|
||||||
|
actorMe <- lift $ getJust actorMeID
|
||||||
|
|
||||||
|
-- Insert the Create to my inbox
|
||||||
|
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorMe) False
|
||||||
|
for mractid $ \ (inboxItemID, createDB) -> do
|
||||||
|
|
||||||
|
-- Insert new actor to DB
|
||||||
|
(newLocalResource, launchNewActor, sendInit, newResourceID) <-
|
||||||
|
insertNewActor now name msummary createDB actorMeID
|
||||||
|
|
||||||
|
-- Prepare forwarding the Create to my followers
|
||||||
|
factoryHash <- encodeKeyHashid factoryMeID
|
||||||
|
let sieve =
|
||||||
|
makeRecipientSet
|
||||||
|
[]
|
||||||
|
[LocalStageFactoryFollowers factoryHash]
|
||||||
|
|
||||||
|
-- Prepare an Accept activity and insert to my outbox
|
||||||
|
acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||||
|
accept@(actionAccept, _, _, _) <- lift $ prepareAccept newLocalResource
|
||||||
|
let recipByKey = LocalActorFactory factoryMeID
|
||||||
|
_luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept
|
||||||
|
|
||||||
|
return (actorMeID, sieve, acceptID, accept, inboxItemID, launchNewActor, sendInit)
|
||||||
|
|
||||||
|
case maybeNew of
|
||||||
|
Nothing -> done "I already have this activity in my inbox"
|
||||||
|
Just (actorMeID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID, launchNewActor, sendInit) -> do
|
||||||
|
|
||||||
|
-- Spawn new actor
|
||||||
|
success <- lift launchNewActor
|
||||||
|
unless success $
|
||||||
|
error "Failed to spawn new actor, somehow ID already in Theater"
|
||||||
|
|
||||||
|
-- Forward Create to my followers
|
||||||
|
forwardActivity
|
||||||
|
authorIdMsig body (LocalActorFactory factoryMeID) actorMeID sieve
|
||||||
|
|
||||||
|
-- Send Accept back to sender
|
||||||
|
lift $ sendActivity
|
||||||
|
(LocalActorFactory factoryMeID) actorMeID localRecipsAccept
|
||||||
|
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||||
|
|
||||||
|
-- Send message to new actor, for it to self-initialize
|
||||||
|
there <- lift sendInit
|
||||||
|
unless there $
|
||||||
|
error "Failed to find new actor, somehow ID not in Theater"
|
||||||
|
|
||||||
|
doneDB inboxItemID "Inserted and launched new actor in just-been-created mode, and sent my Accept"
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
naToActorType = \case
|
||||||
|
NADeck -> AP.ActorTypeTicketTracker
|
||||||
|
NAProject -> AP.ActorTypeProject
|
||||||
|
NATeam -> AP.ActorTypeTeam
|
||||||
|
|
||||||
|
parseDetail (AP.ActorDetail typ muser mname msummary) = do
|
||||||
|
unless (typ == naToActorType new) $
|
||||||
|
error "factoryCreate: Create object not the expected value"
|
||||||
|
verifyNothingE muser "Can't have a username"
|
||||||
|
name <- fromMaybeE mname "Doesn't specify name"
|
||||||
|
return (name, msummary)
|
||||||
|
|
||||||
|
findWorkflow = do
|
||||||
|
mw <- lift $ selectFirst ([] :: [Filter Workflow]) []
|
||||||
|
entityKey <$> fromMaybeE mw "Can't find a workflow"
|
||||||
|
|
||||||
|
insertNewActor now name msummary createDB actorMeID = do
|
||||||
|
wid <- findWorkflow
|
||||||
|
Entity aid a <- lift $ insertActor now name (fromMaybe "" msummary) createDB
|
||||||
|
rid <- lift $ insert $ Resource aid
|
||||||
|
let authorId = second (\ (ra, lu, _) -> (ra, lu)) authorIdMsig
|
||||||
|
(lr, launch, sendInit) <-
|
||||||
|
lift $
|
||||||
|
case new of
|
||||||
|
NADeck -> do
|
||||||
|
kid <- insert $ Komponent rid
|
||||||
|
did <- insert Deck
|
||||||
|
{ deckActor = aid
|
||||||
|
, deckResource = rid
|
||||||
|
, deckKomponent = kid
|
||||||
|
, deckWorkflow = wid
|
||||||
|
, deckNextTicket = 1
|
||||||
|
, deckWiki = Nothing
|
||||||
|
}
|
||||||
|
return
|
||||||
|
( LocalResourceDeck did
|
||||||
|
, launchActor did
|
||||||
|
, send did $ DeckMsgInit authorId
|
||||||
|
)
|
||||||
|
NAProject -> do
|
||||||
|
jid <- insert Project
|
||||||
|
{ projectActor = aid
|
||||||
|
, projectResource = rid
|
||||||
|
}
|
||||||
|
return
|
||||||
|
( LocalResourceProject jid
|
||||||
|
, launchActor jid
|
||||||
|
, send jid $ ProjectMsgInit authorId
|
||||||
|
)
|
||||||
|
NATeam -> do
|
||||||
|
gid <- insert Group
|
||||||
|
{ groupActor = aid
|
||||||
|
, groupResource = rid
|
||||||
|
}
|
||||||
|
return
|
||||||
|
( LocalResourceGroup gid
|
||||||
|
, launchActor gid
|
||||||
|
, send gid $ TeamMsgInit authorId
|
||||||
|
)
|
||||||
|
return (lr, launch, sendInit, rid)
|
||||||
|
|
||||||
|
prepareAccept newLocalResource = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
factoryHash <- encodeKeyHashid factoryMeID
|
||||||
|
newLocalActorHash <- hashLocalActor $ resourceToActor newLocalResource
|
||||||
|
|
||||||
|
audSender <- makeAudSenderWithFollowers authorIdMsig
|
||||||
|
let audMe = AudLocal [] [LocalStageFactoryFollowers factoryHash]
|
||||||
|
--audNew = AudLocal [newLocalActorHash] []
|
||||||
|
|
||||||
|
uCreate <- lift $ getActivityURI authorIdMsig
|
||||||
|
let luNew = encodeRouteLocal $ renderLocalActor newLocalActorHash
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience [audSender, audMe{-, audNew-}]
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Nothing
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = [uCreate]
|
||||||
|
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||||
|
{ AP.acceptObject = uCreate
|
||||||
|
, AP.acceptResult = Just luNew
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
factoryCreate
|
||||||
|
:: UTCTime
|
||||||
|
-> FactoryId
|
||||||
|
-> Verse
|
||||||
|
-> AP.Create URIMode
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
factoryCreate now factoryID verse (AP.Create obj muOrigin) = do
|
||||||
|
uMe <- do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
factoryHash <- encodeKeyHashid factoryID
|
||||||
|
return $ encodeRouteHome $ FactoryR factoryHash
|
||||||
|
|
||||||
|
case obj of
|
||||||
|
AP.CreateTicketTracker detail mlocal -> do
|
||||||
|
verifyNothingE mlocal "Object's id must not be provided"
|
||||||
|
uOrigin <- fromMaybeE muOrigin "'origin' expected in Create-TicketTracker"
|
||||||
|
unless (uOrigin == uMe) $
|
||||||
|
throwE "This Create-TicketTracker isn't for me"
|
||||||
|
factoryCreateNew NADeck now factoryID verse detail
|
||||||
|
|
||||||
|
AP.CreateProject detail mlocal -> do
|
||||||
|
verifyNothingE mlocal "Object's id must not be provided"
|
||||||
|
uOrigin <- fromMaybeE muOrigin "'origin' expected in Create-Project"
|
||||||
|
unless (uOrigin == uMe) $
|
||||||
|
throwE "This Create-Project isn't for me"
|
||||||
|
factoryCreateNew NAProject now factoryID verse detail
|
||||||
|
|
||||||
|
AP.CreateTeam detail mlocal -> do
|
||||||
|
verifyNothingE mlocal "Object's id must not be provided"
|
||||||
|
uOrigin <- fromMaybeE muOrigin "'origin' expected in Create-Team"
|
||||||
|
unless (uOrigin == uMe) $
|
||||||
|
throwE "This Create-Team isn't for me"
|
||||||
|
factoryCreateNew NATeam now factoryID verse detail
|
||||||
|
|
||||||
|
AP.CreateFactory _ mlocal -> do
|
||||||
|
(h, local) <- fromMaybeE mlocal "No factory id provided"
|
||||||
|
let luFactory = AP.actorId local
|
||||||
|
unless (uMe == ObjURI h luFactory) $
|
||||||
|
throwE "The created factory id isn't me"
|
||||||
|
factoryCreateMe now factoryID verse
|
||||||
|
|
||||||
|
_ -> throwE "Unsupported Create object for Factory"
|
||||||
|
|
||||||
|
-- Meaning: A local account just for verified
|
||||||
|
-- Behavior:
|
||||||
|
-- If I’m a resident, OR no-residents-listed-and-I’m-the-only-factory,
|
||||||
|
-- send a write-Grant to new Person and insert Collab record
|
||||||
|
factoryCheckPerson
|
||||||
|
:: UTCTime
|
||||||
|
-> FactoryId
|
||||||
|
-> PersonId
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
factoryCheckPerson now factoryMeID personID = do
|
||||||
|
|
||||||
|
result <- withDBExcept $ do
|
||||||
|
|
||||||
|
-- Grab me from DB
|
||||||
|
factoryMe <- lift $ getJust factoryMeID
|
||||||
|
let resourceMeID = factoryResource factoryMe
|
||||||
|
Resource actorMeID <- lift $ getJust resourceMeID
|
||||||
|
actorMe <- lift $ getJust actorMeID
|
||||||
|
|
||||||
|
existingCollabs <-
|
||||||
|
lift $ E.select $ E.from $ \ (collab `E.InnerJoin` recip) -> do
|
||||||
|
E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
|
||||||
|
E.where_ $
|
||||||
|
collab E.^. CollabTopic E.==. E.val resourceMeID E.&&.
|
||||||
|
recip E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||||
|
return collab
|
||||||
|
|
||||||
|
residents <- asksEnv $ appResidentFactories . envSettings
|
||||||
|
factoryMeHash <- encodeKeyHashid factoryMeID
|
||||||
|
let meHashText = keyHashidText factoryMeHash
|
||||||
|
factoryIDs <- lift $ selectKeysList [] []
|
||||||
|
let meResident =
|
||||||
|
meHashText `elem` residents ||
|
||||||
|
null residents && factoryIDs == [factoryMeID]
|
||||||
|
|
||||||
|
if not meResident
|
||||||
|
then pure $ Left "I'm not a resident, nothing to do"
|
||||||
|
else if not $ null existingCollabs
|
||||||
|
then pure $ Left "I'm a resident but already have a Collab for this person, so nothing to do"
|
||||||
|
else lift $ Right <$> do
|
||||||
|
|
||||||
|
p <- getJust personID
|
||||||
|
|
||||||
|
grantID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||||
|
insertResidentCollab resourceMeID grantID
|
||||||
|
|
||||||
|
grant@(actionGrant, _, _, _) <- prepareResidentGrant p
|
||||||
|
let recipByKey = LocalActorFactory factoryMeID
|
||||||
|
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||||
|
|
||||||
|
return (actorMeID, grantID, grant)
|
||||||
|
|
||||||
|
case result of
|
||||||
|
Left msg -> done msg
|
||||||
|
Right (actorMeID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
|
||||||
|
|
||||||
|
lift $ sendActivity
|
||||||
|
(LocalActorFactory factoryMeID) actorMeID localRecipsGrant
|
||||||
|
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||||
|
|
||||||
|
done "Sent write-Grant to person and inserted Collab record"
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
insertResidentCollab resourceMeID grantID = do
|
||||||
|
collabID <- insert $ Collab AP.RoleWrite resourceMeID
|
||||||
|
insert_ $ CollabEnable collabID grantID
|
||||||
|
insert_ $ CollabRecipLocal collabID personID
|
||||||
|
insert_ $ CollabFulfillsResidentFactory collabID
|
||||||
|
|
||||||
|
prepareResidentGrant person = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
personHash <- encodeKeyHashid personID
|
||||||
|
let audPerson = AudLocal [LocalActorPerson personHash] []
|
||||||
|
meHash <- encodeKeyHashid factoryMeID
|
||||||
|
uCreate <- do
|
||||||
|
selfCreateID <- do
|
||||||
|
mc <- getValBy $ UniqueActorCreateLocalActor $ personActor person
|
||||||
|
case mc of
|
||||||
|
Nothing -> error "Person doesn't have an ActorCreateLocal record"
|
||||||
|
Just c -> pure $ actorCreateLocalCreate c
|
||||||
|
createHash <- encodeKeyHashid selfCreateID
|
||||||
|
return $ encodeRouteHome $ PersonOutboxItemR personHash createHash
|
||||||
|
let topicByHash = LocalActorFactory meHash
|
||||||
|
audience =
|
||||||
|
let audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||||
|
in [audPerson, audTopic]
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience audience
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Nothing
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = [uCreate]
|
||||||
|
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||||
|
{ AP.grantObject = AP.RXRole AP.RoleWrite
|
||||||
|
, AP.grantContext =
|
||||||
|
encodeRouteHome $ renderLocalActor topicByHash
|
||||||
|
, AP.grantTarget = encodeRouteHome $ PersonR personHash
|
||||||
|
, AP.grantResult = Nothing
|
||||||
|
, AP.grantStart = Just now
|
||||||
|
, AP.grantEnd = Nothing
|
||||||
|
, AP.grantAllows = AP.Invoke
|
||||||
|
, AP.grantDelegates = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
-- Meaning: An actor is following someone/something
|
||||||
|
-- Behavior:
|
||||||
|
-- * Verify the target is me
|
||||||
|
-- * Record the follow in DB
|
||||||
|
-- * Publish and send an Accept to the sender and its followers
|
||||||
|
factoryFollow
|
||||||
|
:: UTCTime
|
||||||
|
-> FactoryId
|
||||||
|
-> Verse
|
||||||
|
-> AP.Follow URIMode
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
factoryFollow now recipFactoryID verse follow = do
|
||||||
|
recipFactoryHash <- encodeKeyHashid recipFactoryID
|
||||||
|
actorFollow'
|
||||||
|
(\case
|
||||||
|
FactoryR d | d == recipFactoryHash -> pure ()
|
||||||
|
_ -> throwE "Asking to follow someone else"
|
||||||
|
)
|
||||||
|
(fmap resourceActor . getJust . factoryResource)
|
||||||
|
False
|
||||||
|
(\ recipFactoryActor () -> pure $ actorFollowers recipFactoryActor)
|
||||||
|
(\ _ -> pure $ makeRecipientSet [] [])
|
||||||
|
LocalActorFactory
|
||||||
|
(\ _ -> pure [])
|
||||||
|
now recipFactoryID verse follow
|
||||||
|
|
||||||
factoryBehavior :: UTCTime -> FactoryId -> ActorMessage Factory -> ActE (Text, Act (), Next)
|
factoryBehavior :: UTCTime -> FactoryId -> ActorMessage Factory -> ActE (Text, Act (), Next)
|
||||||
factoryBehavior now factoryID (MsgF _verse@(Verse _authorIdMsig body)) =
|
factoryBehavior now factoryID (FactoryMsgVerse verse@(Verse _authorIdMsig body)) =
|
||||||
case AP.activitySpecific $ actbActivity body of
|
case AP.activitySpecific $ actbActivity body of
|
||||||
|
AP.CreateActivity create -> factoryCreate now factoryID verse create
|
||||||
|
AP.FollowActivity follow -> factoryFollow now factoryID verse follow
|
||||||
_ -> throwE "Unsupported activity type for Factory"
|
_ -> throwE "Unsupported activity type for Factory"
|
||||||
|
factoryBehavior now factoryID (FactoryMsgVerified personID) =
|
||||||
|
factoryCheckPerson now factoryID personID
|
||||||
|
|
||||||
instance VervisActorLaunch Factory where
|
instance VervisActorLaunch Factory where
|
||||||
actorBehavior' now factoryID ve = do
|
actorBehavior' now factoryID ve = do
|
||||||
|
|
|
||||||
|
|
@ -71,7 +71,7 @@ import Vervis.Data.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
|
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model hiding (groupCreate)
|
import Vervis.Model
|
||||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
|
|
@ -2441,42 +2441,6 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
-- Meaning: Someone has created a group with my ID URI
|
|
||||||
-- Behavior:
|
|
||||||
-- * Verify I'm in a just-been-created state
|
|
||||||
-- * Verify my creator and the Create sender are the same actor
|
|
||||||
-- * Create an admin Collab record in DB
|
|
||||||
-- * Send an admin Grant to the creator
|
|
||||||
-- * Get out of the just-been-created state
|
|
||||||
groupCreateMe
|
|
||||||
:: UTCTime
|
|
||||||
-> GroupId
|
|
||||||
-> Verse
|
|
||||||
-> ActE (Text, Act (), Next)
|
|
||||||
groupCreateMe = topicCreateMe groupResource LocalResourceGroup
|
|
||||||
|
|
||||||
groupCreate
|
|
||||||
:: UTCTime
|
|
||||||
-> GroupId
|
|
||||||
-> Verse
|
|
||||||
-> AP.Create URIMode
|
|
||||||
-> ActE (Text, Act (), Next)
|
|
||||||
groupCreate now groupID verse (AP.Create obj _muTarget) =
|
|
||||||
case obj of
|
|
||||||
|
|
||||||
AP.CreateTeam _ mlocal -> do
|
|
||||||
(h, local) <- fromMaybeE mlocal "No group id provided"
|
|
||||||
let luGroup = AP.actorId local
|
|
||||||
uMe <- do
|
|
||||||
groupHash <- encodeKeyHashid groupID
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
return $ encodeRouteHome $ GroupR groupHash
|
|
||||||
unless (uMe == ObjURI h luGroup) $
|
|
||||||
throwE "The created group id isn't me"
|
|
||||||
groupCreateMe now groupID verse
|
|
||||||
|
|
||||||
_ -> throwE "Unsupported Create object for Group"
|
|
||||||
|
|
||||||
-- Meaning: An actor is following someone/something
|
-- Meaning: An actor is following someone/something
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Verify the target is me
|
-- * Verify the target is me
|
||||||
|
|
@ -5927,11 +5891,10 @@ groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
groupBehavior :: UTCTime -> GroupId -> ActorMessage Group -> ActE (Text, Act (), Next)
|
groupBehavior :: UTCTime -> GroupId -> ActorMessage Group -> ActE (Text, Act (), Next)
|
||||||
groupBehavior now groupID (MsgG verse@(Verse _authorIdMsig body)) =
|
groupBehavior now groupID (TeamMsgVerse verse@(Verse _authorIdMsig body)) =
|
||||||
case AP.activitySpecific $ actbActivity body of
|
case AP.activitySpecific $ actbActivity body of
|
||||||
AP.AcceptActivity accept -> groupAccept now groupID verse accept
|
AP.AcceptActivity accept -> groupAccept now groupID verse accept
|
||||||
AP.AddActivity add -> groupAdd now groupID verse add
|
AP.AddActivity add -> groupAdd now groupID verse add
|
||||||
AP.CreateActivity create -> groupCreate now groupID verse create
|
|
||||||
AP.FollowActivity follow -> groupFollow now groupID verse follow
|
AP.FollowActivity follow -> groupFollow now groupID verse follow
|
||||||
AP.GrantActivity grant -> groupGrant now groupID verse grant
|
AP.GrantActivity grant -> groupGrant now groupID verse grant
|
||||||
AP.InviteActivity invite -> groupInvite now groupID verse invite
|
AP.InviteActivity invite -> groupInvite now groupID verse invite
|
||||||
|
|
@ -5941,6 +5904,9 @@ groupBehavior now groupID (MsgG verse@(Verse _authorIdMsig body)) =
|
||||||
AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke
|
AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke
|
||||||
AP.UndoActivity undo -> groupUndo now groupID verse undo
|
AP.UndoActivity undo -> groupUndo now groupID verse undo
|
||||||
_ -> throwE "Unsupported activity type for Group"
|
_ -> throwE "Unsupported activity type for Group"
|
||||||
|
groupBehavior now groupID (TeamMsgInit creator) =
|
||||||
|
let grabResource = pure . groupResource
|
||||||
|
in topicInit grabResource LocalResourceGroup now groupID creator
|
||||||
|
|
||||||
instance VervisActorLaunch Group where
|
instance VervisActorLaunch Group where
|
||||||
actorBehavior' now groupID ve = do
|
actorBehavior' now groupID ve = do
|
||||||
|
|
|
||||||
|
|
@ -72,11 +72,12 @@ import Vervis.FedURI
|
||||||
|
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
import Vervis.Model.Ident
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
import Vervis.Persist.Collab
|
import Vervis.Persist.Collab
|
||||||
import Vervis.Persist.Discussion
|
import Vervis.Persist.Discussion
|
||||||
import Vervis.Persist.Follow
|
import Vervis.Persist.Follow
|
||||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
|
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, renderLocalActor)
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
|
|
||||||
|
|
@ -282,13 +283,19 @@ personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
||||||
-- Meaning: An actor accepted something
|
-- Meaning: An actor accepted something
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Insert to my inbox
|
-- * Insert to my inbox
|
||||||
|
--
|
||||||
-- * If it's on a Follow I sent to them:
|
-- * If it's on a Follow I sent to them:
|
||||||
-- * Add to my following list in DB
|
-- * Add to my following list in DB
|
||||||
|
--
|
||||||
-- * If it's on an Invite-for-me to collaborate on a resource:
|
-- * If it's on an Invite-for-me to collaborate on a resource:
|
||||||
-- * Verify I haven't yet seen the resource's accept
|
-- * Verify I haven't yet seen the resource's accept
|
||||||
-- * Verify the Accept author is the resource
|
-- * Verify the Accept author is the resource
|
||||||
-- * Store it in the Permit record in DB
|
-- * Store it in the Permit record in DB
|
||||||
-- * Forward to my followers
|
-- * Forward to my followers
|
||||||
|
--
|
||||||
|
-- * If it's on a Create-actor-via-factory I'd sent
|
||||||
|
-- * Insert PermitTopic*
|
||||||
|
-- * Send a Follow on the newly created actor
|
||||||
personAccept
|
personAccept
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> PersonId
|
-> PersonId
|
||||||
|
|
@ -300,6 +307,34 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
||||||
-- Check input
|
-- Check input
|
||||||
acceptee <- parseAccept accept
|
acceptee <- parseAccept accept
|
||||||
|
|
||||||
|
-- Discover Accept.result, before DB access since we might use HTTP
|
||||||
|
maybeRightResult <-
|
||||||
|
for (AP.acceptResult accept) $ \ luResult -> lift $ runExceptT $ do
|
||||||
|
let h = objUriAuthority $ AP.acceptObject accept
|
||||||
|
uResult = ObjURI h luResult
|
||||||
|
routeOrRemote <- parseFedURI uResult
|
||||||
|
bitraverse
|
||||||
|
(\ route -> do
|
||||||
|
lr <- parseLocalResourceE' route
|
||||||
|
resourceID <- withDBExcept $ do
|
||||||
|
lre <- getLocalResourceEntityE lr "Local Accept.result actor not found in DB"
|
||||||
|
lift $ grabLocalResourceID lre
|
||||||
|
return (lr, resourceID)
|
||||||
|
)
|
||||||
|
(\ u@(ObjURI h lu) -> do
|
||||||
|
instanceID <-
|
||||||
|
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||||
|
result <-
|
||||||
|
ExceptT $ first (T.pack . displayException) <$>
|
||||||
|
fetchRemoteActor' instanceID h lu
|
||||||
|
case result of
|
||||||
|
Left Nothing -> throwE "Result @id mismatch"
|
||||||
|
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||||
|
Right Nothing -> throwE "Result isn't an actor"
|
||||||
|
Right (Just actor) -> return (u, actor)
|
||||||
|
)
|
||||||
|
routeOrRemote
|
||||||
|
|
||||||
maybeNew <- withDBExcept $ do
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
-- Grab me from DB
|
-- Grab me from DB
|
||||||
|
|
@ -314,26 +349,113 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
||||||
accepteeDB <- MaybeT $ getActivity acceptee
|
accepteeDB <- MaybeT $ getActivity acceptee
|
||||||
|
|
||||||
let recipActorID = personActor personRecip
|
let recipActorID = personActor personRecip
|
||||||
Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
|
Left . Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
|
||||||
Right <$> tryInvite recipActorID accepteeDB acceptDB
|
Left . Right <$> tryInvite recipActorID accepteeDB acceptDB <|>
|
||||||
|
Right <$> tryCreate maybeRightResult recipActorID accepteeDB acceptDB
|
||||||
|
|
||||||
case maybeNew of
|
case maybeNew of
|
||||||
Nothing -> done "I already have this activity in my inbox"
|
Nothing -> done "I already have this activity in my inbox"
|
||||||
Just (inboxItemID, result) ->
|
Just (inboxItemID, result) ->
|
||||||
case result of
|
case result of
|
||||||
Nothing -> doneDB inboxItemID "Not my Follow/Invite; Just inserted to my inbox"
|
Nothing -> doneDB inboxItemID "Not my Follow/Invite; Just inserted to my inbox"
|
||||||
Just (Left ()) ->
|
Just (Left (Left ())) ->
|
||||||
doneDB inboxItemID "Recorded this Accept on the Follow request I sent"
|
doneDB inboxItemID "Recorded this Accept on the Follow request I sent"
|
||||||
Just (Right (actorID, sieve)) -> do
|
Just (Left (Right (actorID, sieve))) -> do
|
||||||
forwardActivity
|
forwardActivity
|
||||||
authorIdMsig body (LocalActorPerson recipPersonID)
|
authorIdMsig body (LocalActorPerson recipPersonID)
|
||||||
actorID sieve
|
actorID sieve
|
||||||
doneDB inboxItemID
|
doneDB inboxItemID
|
||||||
"Recorded this Accept on the Invite I've had & \
|
"Recorded this Accept on the Invite I've had & \
|
||||||
\forwarded to my followers"
|
\forwarded to my followers"
|
||||||
|
Just (Right Nothing) ->
|
||||||
|
doneDB inboxItemID "Inserted PermitTopic*, Follow/Request already exists"
|
||||||
|
Just (Right (Just (actorMeID, followID, follow))) -> do
|
||||||
|
let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
|
||||||
|
lift $ sendActivity
|
||||||
|
(LocalActorPerson recipPersonID) actorMeID localRecipsFollow
|
||||||
|
remoteRecipsFollow fwdHostsFollow followID actionFollow
|
||||||
|
doneDB inboxItemID "Inserted PermitTopic* & sent Follow"
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
|
tryCreate maybeRightResult actorMeID (Left (_, _, outboxItemID)) _ = do
|
||||||
|
|
||||||
|
-- Verify Accept specifies a result
|
||||||
|
result <- do
|
||||||
|
r <- hoistMaybe maybeRightResult
|
||||||
|
case r of
|
||||||
|
Left e -> lift $ throwE e
|
||||||
|
Right actor -> pure actor
|
||||||
|
|
||||||
|
-- Find an admin-Permit-Fulfills-Create I have
|
||||||
|
PermitPersonGesture permitID _ <-
|
||||||
|
MaybeT $ lift $ getValBy $ UniquePermitPersonGestureActivity outboxItemID
|
||||||
|
_ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID
|
||||||
|
Permit p role <- lift $ lift $ getJust permitID
|
||||||
|
guard $ p == recipPersonID
|
||||||
|
guard $ role == AP.RoleAdmin
|
||||||
|
|
||||||
|
-- Grab the Create's origin, verify it's identical to Accept sender
|
||||||
|
AP.Doc _ act <- lift $ lift $ getActivityBody $ Left outboxItemID
|
||||||
|
uOrigin <-
|
||||||
|
case AP.activitySpecific act of
|
||||||
|
AP.CreateActivity (AP.Create _ (Just u)) -> pure u
|
||||||
|
_ -> lift $ throwE "Expected acceptee to be a Create with origin"
|
||||||
|
uAcceptSender <- lift $ lift $ lift $ getActorURI authorIdMsig
|
||||||
|
unless (uAcceptSender == uOrigin) $
|
||||||
|
lift $ throwE "Accept sender isn't the Create.origin"
|
||||||
|
|
||||||
|
-- Verify permit topic is missing
|
||||||
|
mptl <- lift $ lift $ getBy $ UniquePermitTopicLocal permitID
|
||||||
|
mptr <- lift $ lift $ getBy $ UniquePermitTopicRemote permitID
|
||||||
|
unless (isNothing mptl && isNothing mptr) $
|
||||||
|
lift $ throwE "PermitTopic* already exists in DB"
|
||||||
|
|
||||||
|
-- Insert permit topic, the new actor
|
||||||
|
lift $ lift $
|
||||||
|
case result of
|
||||||
|
Left (_, resourceID) ->
|
||||||
|
insert_ $ PermitTopicLocal permitID resourceID
|
||||||
|
Right (_, Entity actorID _) ->
|
||||||
|
insert_ $ PermitTopicRemote permitID actorID
|
||||||
|
|
||||||
|
lift $ lift $ do
|
||||||
|
-- Look for an existing follow/request record in DB
|
||||||
|
existing <-
|
||||||
|
case result of
|
||||||
|
Left (_, resourceID) -> do
|
||||||
|
Resource actorNewID <- getJust resourceID
|
||||||
|
fsID <- actorFollowers <$> getJust actorNewID
|
||||||
|
mf <- getBy $ UniqueFollow actorMeID fsID
|
||||||
|
mfr <- getBy $ UniqueFollowRequest actorMeID fsID
|
||||||
|
return $ isJust mf || isJust mfr
|
||||||
|
Right (uNewActor, _) -> do
|
||||||
|
mf <- getBy $ UniqueFollowRemote actorMeID uNewActor
|
||||||
|
mfr <- getBy $ UniqueFollowRemoteRequest recipPersonID uNewActor
|
||||||
|
return $ isJust mf || isJust mfr
|
||||||
|
|
||||||
|
-- If none, insert request and prepare Follow activity
|
||||||
|
if existing
|
||||||
|
then pure Nothing
|
||||||
|
else Just <$> do
|
||||||
|
actorMe <- getJust actorMeID
|
||||||
|
followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||||
|
|
||||||
|
case result of
|
||||||
|
Left (_, resourceID) -> do
|
||||||
|
Resource actorNewID <- getJust resourceID
|
||||||
|
fsID <- actorFollowers <$> getJust actorNewID
|
||||||
|
insert_ $ FollowRequest actorMeID fsID True followID
|
||||||
|
Right (uNewActor, _) ->
|
||||||
|
insert_ $ FollowRemoteRequest recipPersonID uNewActor Nothing True followID
|
||||||
|
|
||||||
|
follow@(actionFollow, _, _, _) <- lift $ prepareFollow result
|
||||||
|
luFollow <- updateOutboxItem' (LocalActorPerson recipPersonID) followID actionFollow
|
||||||
|
|
||||||
|
return (actorMeID, followID, follow)
|
||||||
|
|
||||||
|
tryCreate _ _ (Right _) _ = mzero
|
||||||
|
|
||||||
tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do
|
tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do
|
||||||
Entity key val <-
|
Entity key val <-
|
||||||
MaybeT $ lift $
|
MaybeT $ lift $
|
||||||
|
|
@ -435,6 +557,37 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
||||||
|
|
||||||
return (recipActorID, sieve)
|
return (recipActorID, sieve)
|
||||||
|
|
||||||
|
prepareFollow result = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
|
||||||
|
(uNewActor, audNewActor) <-
|
||||||
|
case result of
|
||||||
|
Left (lr, _) -> do
|
||||||
|
la <- resourceToActor <$> hashLocalResource lr
|
||||||
|
return
|
||||||
|
( encodeRouteHome $ renderLocalActor la
|
||||||
|
, AudLocal [la] []
|
||||||
|
)
|
||||||
|
Right (u@(ObjURI h lu), _) ->
|
||||||
|
return (u, AudRemote h [lu] [])
|
||||||
|
uAccept <- getActivityURI authorIdMsig
|
||||||
|
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience [audNewActor]
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Nothing
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = [uAccept]
|
||||||
|
, AP.actionSpecific = AP.FollowActivity AP.Follow
|
||||||
|
{ AP.followObject = uNewActor
|
||||||
|
, AP.followContext = Nothing
|
||||||
|
, AP.followHide = False
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
-- Meaning: An actor rejected something
|
-- Meaning: An actor rejected something
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Insert to my inbox
|
-- * Insert to my inbox
|
||||||
|
|
@ -806,6 +959,11 @@ personJoin now recipPersonID (Verse authorIdMsig body) join = do
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Insert to my inbox
|
-- * Insert to my inbox
|
||||||
--
|
--
|
||||||
|
-- * If it's a developer direct-Grant from a local Factory, and there's no
|
||||||
|
-- Permit record:
|
||||||
|
-- * Insert a Permit record, storing the direct-Grant
|
||||||
|
-- * Forward the direct-Grant to my followers
|
||||||
|
--
|
||||||
-- * If it's a direct-Grant that fulfills a Permit I have:
|
-- * If it's a direct-Grant that fulfills a Permit I have:
|
||||||
-- * Verify the Permit isn't already enabled
|
-- * Verify the Permit isn't already enabled
|
||||||
-- * Verify the sender is the Permit topic
|
-- * Verify the sender is the Permit topic
|
||||||
|
|
@ -924,6 +1082,11 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
||||||
(personRecip, actorRecip) <- lift $ do
|
(personRecip, actorRecip) <- lift $ do
|
||||||
p <- getJust recipPersonID
|
p <- getJust recipPersonID
|
||||||
(p,) <$> getJust (personActor p)
|
(p,) <$> getJust (personActor p)
|
||||||
|
selfCreateID <- lift $ do
|
||||||
|
mc <- getValBy $ UniqueActorCreateLocalActor $ personActor personRecip
|
||||||
|
case mc of
|
||||||
|
Nothing -> error "I don't have an ActorCreateLocal record"
|
||||||
|
Just c -> pure $ actorCreateLocalCreate c
|
||||||
|
|
||||||
maybePermit <-
|
maybePermit <-
|
||||||
for maybeMine' $
|
for maybeMine' $
|
||||||
|
|
@ -934,7 +1097,6 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
||||||
fulfillsDB <- do
|
fulfillsDB <- do
|
||||||
a <- getActivity fulfills
|
a <- getActivity fulfills
|
||||||
fromMaybeE a "Can't find fulfills in DB"
|
fromMaybeE a "Can't find fulfills in DB"
|
||||||
(permitID, maybeGestureID) <- do
|
|
||||||
mp <- runMaybeT $ do
|
mp <- runMaybeT $ do
|
||||||
x@(pt, mg) <-
|
x@(pt, mg) <-
|
||||||
tryInvite fulfillsDB <|>
|
tryInvite fulfillsDB <|>
|
||||||
|
|
@ -945,7 +1107,8 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
||||||
lift $ unless (role == AP.RXRole role') $
|
lift $ unless (role == AP.RXRole role') $
|
||||||
throwE "Requested and granted roles differ"
|
throwE "Requested and granted roles differ"
|
||||||
return x
|
return x
|
||||||
fromMaybeE mp "Can't find a PermitFulfills*"
|
case mp of
|
||||||
|
Just (permitID, maybeGestureID) -> do
|
||||||
|
|
||||||
-- If Permit fulfills an Invite, verify I've approved
|
-- If Permit fulfills an Invite, verify I've approved
|
||||||
-- it
|
-- it
|
||||||
|
|
@ -966,7 +1129,13 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
||||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||||
_ -> throwE "Grant sender isn't the Permit topic"
|
_ -> throwE "Grant sender isn't the Permit topic"
|
||||||
|
|
||||||
return (gestureID, bimap fst fst topic)
|
return $ Left (gestureID, bimap fst fst topic)
|
||||||
|
|
||||||
|
Nothing -> do
|
||||||
|
case (authorIdMsig, role) of
|
||||||
|
(Left (LocalActorFactory factoryID, actorID, grantID), AP.RXRole AP.RoleWrite) ->
|
||||||
|
return $ Right (factoryID, actorID, grantID)
|
||||||
|
_ -> throwE "No Permit found & sender-and-role not local-Factory-and-write"
|
||||||
)
|
)
|
||||||
(\ (resourceDB, role, delegatorID) -> do
|
(\ (resourceDB, role, delegatorID) -> do
|
||||||
Entity sendID (PermitPersonSendDelegator gestureID _) <- do
|
Entity sendID (PermitPersonSendDelegator gestureID _) <- do
|
||||||
|
|
@ -990,7 +1159,19 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
||||||
fmap (inboxItemID,) $
|
fmap (inboxItemID,) $
|
||||||
for maybePermit $
|
for maybePermit $
|
||||||
bitraverse
|
bitraverse
|
||||||
(\ (gestureID, topic) -> lift $ do
|
(\ mode -> lift $ do
|
||||||
|
|
||||||
|
-- In factory-mode, we need to create a Permit record
|
||||||
|
(gestureID, topic) <-
|
||||||
|
case mode of
|
||||||
|
Left permit -> pure permit
|
||||||
|
Right (factoryID, _actorID, _grantID) -> do
|
||||||
|
resourceID <- factoryResource <$> getJust factoryID
|
||||||
|
permitID <- insert $ Permit recipPersonID AP.RoleWrite
|
||||||
|
topicID <- insert $ PermitTopicLocal permitID resourceID
|
||||||
|
insert_ $ PermitFulfillsResidentFactory permitID
|
||||||
|
gestureID <- insert $ PermitPersonGesture permitID selfCreateID
|
||||||
|
return (gestureID, Left topicID)
|
||||||
|
|
||||||
-- Update the Permit record, storing the direct-Grant
|
-- Update the Permit record, storing the direct-Grant
|
||||||
case (topic, grantDB) of
|
case (topic, grantDB) of
|
||||||
|
|
@ -1072,7 +1253,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
||||||
sendActivity
|
sendActivity
|
||||||
recipByID recipActorID localRecipsDeleg
|
recipByID recipActorID localRecipsDeleg
|
||||||
remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg
|
remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg
|
||||||
doneDB inboxItemID "Forwarded the direct-Grant, updated Permit, maybe published delegator-Grant"
|
doneDB inboxItemID "Forwarded the direct-Grant, created/updated Permit, maybe published delegator-Grant"
|
||||||
Just (Right ()) ->
|
Just (Right ()) ->
|
||||||
doneDB inboxItemID "Got an extension-Grant, updated Permit"
|
doneDB inboxItemID "Got an extension-Grant, updated Permit"
|
||||||
|
|
||||||
|
|
@ -1316,8 +1497,80 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
|
||||||
-- Main behavior function
|
-- Main behavior function
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- Meaning: I've just been verified
|
||||||
|
-- Behavior: Publish a Create-self activity & record ActorCreateLocal in DB
|
||||||
|
personInit
|
||||||
|
:: UTCTime
|
||||||
|
-> PersonId
|
||||||
|
-> ActE (Text, Act (), Next)
|
||||||
|
personInit now personMeID = do
|
||||||
|
|
||||||
|
_ <- withDBExcept $ do
|
||||||
|
|
||||||
|
-- Grab me from DB
|
||||||
|
personMe <- lift $ getJust personMeID
|
||||||
|
let actorMeID = personActor personMe
|
||||||
|
actorMe <- lift $ getJust actorMeID
|
||||||
|
|
||||||
|
-- Grab ActorCreate* record, make sure it doesn't exist
|
||||||
|
ml <- lift $ getKeyBy $ UniqueActorCreateLocalActor actorMeID
|
||||||
|
mr <- lift $ getKeyBy $ UniqueActorCreateRemoteActor actorMeID
|
||||||
|
unless (isNothing ml && isNothing mr) $
|
||||||
|
throwE "ActorCreate* already exists"
|
||||||
|
|
||||||
|
-- Prepare a Create activity and insert to my outbox
|
||||||
|
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||||
|
create@(actionCreate, _, _, _) <- lift $ lift $ prepareCreate personMe actorMe
|
||||||
|
_luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
|
||||||
|
|
||||||
|
return (actorMeID, createID, create)
|
||||||
|
|
||||||
|
-- Not sending the activity anywhere
|
||||||
|
done "Published a Create-self activity"
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
prepareCreate personMe actorMe = do
|
||||||
|
hLocal <- asksEnv stageInstanceHost
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
personMeHash <- encodeKeyHashid personMeID
|
||||||
|
let audMe = AudLocal [] [LocalStagePersonFollowers personMeHash]
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience [audMe]
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
|
||||||
|
pdetail = AP.ActorDetail
|
||||||
|
{ AP.actorType = AP.ActorTypeTicketTracker
|
||||||
|
, AP.actorUsername = Just $ username2text $ personUsername personMe
|
||||||
|
, AP.actorName = Just $ actorName actorMe
|
||||||
|
, AP.actorSummary = Just $ actorDesc actorMe
|
||||||
|
}
|
||||||
|
plocal = AP.ActorLocal
|
||||||
|
{ AP.actorId = encodeRouteLocal $ PersonR personMeHash
|
||||||
|
, AP.actorInbox = encodeRouteLocal $ PersonInboxR personMeHash
|
||||||
|
, AP.actorOutbox = Nothing
|
||||||
|
, AP.actorFollowers = Nothing
|
||||||
|
, AP.actorFollowing = Nothing
|
||||||
|
, AP.actorPublicKeys = []
|
||||||
|
, AP.actorSshKeys = []
|
||||||
|
}
|
||||||
|
action = AP.Action
|
||||||
|
{ AP.actionCapability = Nothing
|
||||||
|
, AP.actionSummary = Nothing
|
||||||
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||||
|
, AP.actionFulfills = []
|
||||||
|
, AP.actionSpecific = AP.CreateActivity AP.Create
|
||||||
|
{ AP.createObject = AP.CreatePerson pdetail (Just (hLocal, plocal))
|
||||||
|
, AP.createOrigin = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
personBehavior :: UTCTime -> PersonId -> ActorMessage Person -> ActE (Text, Act (), Next)
|
personBehavior :: UTCTime -> PersonId -> ActorMessage Person -> ActE (Text, Act (), Next)
|
||||||
personBehavior now personID (MsgP (Left verse@(Verse _authorIdMsig body))) =
|
personBehavior now personID (PersonMsgVerse verse@(Verse _authorIdMsig body)) =
|
||||||
case AP.activitySpecific $ actbActivity body of
|
case AP.activitySpecific $ actbActivity body of
|
||||||
AP.AcceptActivity accept -> personAccept now personID verse accept
|
AP.AcceptActivity accept -> personAccept now personID verse accept
|
||||||
AP.AddActivity add -> personAdd now personID verse add
|
AP.AddActivity add -> personAdd now personID verse add
|
||||||
|
|
@ -1337,7 +1590,8 @@ personBehavior now personID (MsgP (Left verse@(Verse _authorIdMsig body))) =
|
||||||
AP.RevokeActivity revoke -> personRevoke now personID verse revoke
|
AP.RevokeActivity revoke -> personRevoke now personID verse revoke
|
||||||
AP.UndoActivity undo -> personUndo now personID verse undo
|
AP.UndoActivity undo -> personUndo now personID verse undo
|
||||||
_ -> throwE "Unsupported activity type for Person"
|
_ -> throwE "Unsupported activity type for Person"
|
||||||
personBehavior now personID (MsgP (Right msg)) = clientBehavior now personID msg
|
personBehavior now personID (PersonMsgClient msg) = clientBehavior now personID msg
|
||||||
|
personBehavior now personID PersonMsgInit = personInit now personID
|
||||||
|
|
||||||
instance VervisActorLaunch Person where
|
instance VervisActorLaunch Person where
|
||||||
actorBehavior' now personID ve = do
|
actorBehavior' now personID ve = do
|
||||||
|
|
|
||||||
|
|
@ -358,26 +358,35 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
|
||||||
fwdHosts addID action
|
fwdHosts addID action
|
||||||
return addID
|
return addID
|
||||||
|
|
||||||
-- Meaning: The human wants to create a ticket tracker
|
-- Meaning: The human wants to create an actor via a Factory
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Create a deck on DB
|
-- * Ensure the origin is addressed
|
||||||
-- * Create a Permit record in DB
|
-- * Insert Create to outbox
|
||||||
-- * Launch a deck actor
|
-- * Create an open permit record
|
||||||
-- * Record a FollowRequest in DB
|
-- * Send the Create to recipients
|
||||||
-- * Create and send Create and Follow to it
|
clientCreateActor
|
||||||
clientCreateDeck
|
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> PersonId
|
-> PersonId
|
||||||
-> ClientMsg
|
-> ClientMsg
|
||||||
-> AP.ActorDetail
|
-> AP.ActorDetail
|
||||||
|
-> FedURI
|
||||||
-> ActE OutboxItemId
|
-> ActE OutboxItemId
|
||||||
clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do
|
clientCreateActor now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) detail uOrigin = do
|
||||||
|
|
||||||
-- Check input
|
-- Check input
|
||||||
verifyNothingE maybeCap "Capability not needed"
|
_ <- fromMaybeE maybeCap "Capability not provided"
|
||||||
(name, msummary) <- parseTracker tracker
|
_ <- parseDetail detail
|
||||||
|
origin <- do
|
||||||
|
routeOrRemote <- parseFedURI uOrigin
|
||||||
|
bitraverse parseLocalActorE' pure routeOrRemote
|
||||||
|
|
||||||
(actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, deckID) <- withDBExcept $ do
|
-- Verify origin is addressed
|
||||||
|
bitraverse_
|
||||||
|
(verifyActorAddressed localRecips)
|
||||||
|
(verifyRemoteAddressed remoteRecips)
|
||||||
|
origin
|
||||||
|
|
||||||
|
(actorMeID, createID) <- withDBExcept $ do
|
||||||
|
|
||||||
-- Grab me from DB
|
-- Grab me from DB
|
||||||
(personMe, actorMe) <- lift $ do
|
(personMe, actorMe) <- lift $ do
|
||||||
|
|
@ -385,455 +394,35 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
||||||
(p,) <$> getJust (personActor p)
|
(p,) <$> getJust (personActor p)
|
||||||
let actorMeID = personActor personMe
|
let actorMeID = personActor personMe
|
||||||
|
|
||||||
-- Insert new deck to DB
|
-- Insert the Create activity to my outbox
|
||||||
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||||
wid <- findWorkflow
|
_luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID action
|
||||||
(deckID, resourceID, deckFollowerSetID) <-
|
|
||||||
lift $ insertDeck now name msummary createID wid actorMeID
|
|
||||||
|
|
||||||
-- Insert a Permit record
|
-- Insert a partial Permit record, i.e. without topic
|
||||||
|
-- (Is this a good idea?
|
||||||
|
-- It's a way to remember the createID for when the Accept from the
|
||||||
|
-- Factory arrives, which is when we insert the missing topic)
|
||||||
lift $ do
|
lift $ do
|
||||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
||||||
topicID <- insert $ PermitTopicLocal permitID resourceID
|
|
||||||
insert_ $ PermitFulfillsTopicCreation permitID
|
insert_ $ PermitFulfillsTopicCreation permitID
|
||||||
insert_ $ PermitPersonGesture permitID createID
|
insert_ $ PermitPersonGesture permitID createID
|
||||||
|
|
||||||
-- Insert the Create activity to my outbox
|
return (personActor personMe, createID)
|
||||||
deckHash <- encodeKeyHashid deckID
|
|
||||||
actionCreate <- prepareCreate name msummary deckHash
|
|
||||||
luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
|
|
||||||
|
|
||||||
-- Prepare recipient sieve for sending the Create
|
|
||||||
personMeHash <- lift $ encodeKeyHashid personMeID
|
|
||||||
let sieve =
|
|
||||||
makeRecipientSet
|
|
||||||
[LocalActorDeck deckHash]
|
|
||||||
[LocalStagePersonFollowers personMeHash]
|
|
||||||
onlyDeck = DeckFamilyRoutes (DeckRoutes True False) []
|
|
||||||
addMe' decks = (deckHash, onlyDeck) : decks
|
|
||||||
addMe rs = rs { recipDecks = addMe' $ recipDecks rs }
|
|
||||||
|
|
||||||
-- Insert a follow request, since I'm about to send a Follow
|
|
||||||
followID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
|
||||||
lift $ insert_ $ FollowRequest actorMeID deckFollowerSetID True followID
|
|
||||||
|
|
||||||
-- Insert a Follow to my outbox
|
|
||||||
follow@(actionFollow, _, _, _) <- lift $ lift $ prepareFollow deckID luCreate
|
|
||||||
_luFollow <- lift $ updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
|
|
||||||
|
|
||||||
return
|
|
||||||
( personActor personMe
|
|
||||||
, localRecipSieve sieve False $ addMe localRecips
|
|
||||||
, createID
|
|
||||||
, actionCreate
|
|
||||||
, followID
|
|
||||||
, follow
|
|
||||||
, deckID
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Spawn new Deck actor
|
|
||||||
success <- lift $ launchActor deckID
|
|
||||||
unless success $
|
|
||||||
error "Failed to spawn new Deck, somehow ID already in Theater"
|
|
||||||
|
|
||||||
-- Send the Create
|
-- Send the Create
|
||||||
lift $ sendActivity
|
lift $ sendActivity
|
||||||
(LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
|
(LocalActorPerson personMeID) actorMeID localRecips remoteRecips
|
||||||
fwdHosts createID actionCreate
|
fwdHosts createID action
|
||||||
|
|
||||||
-- Send the Follow
|
|
||||||
let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
|
|
||||||
lift $ sendActivity
|
|
||||||
(LocalActorPerson personMeID) actorMeID localRecipsFollow
|
|
||||||
remoteRecipsFollow fwdHostsFollow followID actionFollow
|
|
||||||
|
|
||||||
return createID
|
return createID
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
parseTracker (AP.ActorDetail typ muser mname msummary) = do
|
parseDetail (AP.ActorDetail typ muser mname msummary) = do
|
||||||
unless (typ == AP.ActorTypeTicketTracker) $
|
verifyNothingE muser "Can't have a username"
|
||||||
error "createTicketTrackerC: Create object isn't a TicketTracker"
|
name <- fromMaybeE mname "Doesn't specify name"
|
||||||
verifyNothingE muser "TicketTracker can't have a username"
|
|
||||||
name <- fromMaybeE mname "TicketTracker doesn't specify name"
|
|
||||||
return (name, msummary)
|
return (name, msummary)
|
||||||
|
|
||||||
findWorkflow = do
|
|
||||||
mw <- lift $ selectFirst ([] :: [Filter Workflow]) []
|
|
||||||
entityKey <$> fromMaybeE mw "Can't find a workflow"
|
|
||||||
|
|
||||||
insertDeck now name msummary obiidCreate wid actorMeID = do
|
|
||||||
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID)
|
|
||||||
rid <- insert $ Resource aid
|
|
||||||
kid <- insert $ Komponent rid
|
|
||||||
did <- insert Deck
|
|
||||||
{ deckActor = aid
|
|
||||||
, deckResource = rid
|
|
||||||
, deckKomponent = kid
|
|
||||||
, deckWorkflow = wid
|
|
||||||
, deckNextTicket = 1
|
|
||||||
, deckWiki = Nothing
|
|
||||||
, deckCreate = obiidCreate
|
|
||||||
}
|
|
||||||
return (did, rid, actorFollowers a)
|
|
||||||
|
|
||||||
prepareCreate name msummary deckHash = do
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
|
||||||
hLocal <- asksEnv stageInstanceHost
|
|
||||||
let ttdetail = AP.ActorDetail
|
|
||||||
{ AP.actorType = AP.ActorTypeTicketTracker
|
|
||||||
, AP.actorUsername = Nothing
|
|
||||||
, AP.actorName = Just name
|
|
||||||
, AP.actorSummary = msummary
|
|
||||||
}
|
|
||||||
ttlocal = AP.ActorLocal
|
|
||||||
{ AP.actorId = encodeRouteLocal $ DeckR deckHash
|
|
||||||
, AP.actorInbox = encodeRouteLocal $ DeckInboxR deckHash
|
|
||||||
, AP.actorOutbox = Nothing
|
|
||||||
, AP.actorFollowers = Nothing
|
|
||||||
, AP.actorFollowing = Nothing
|
|
||||||
, AP.actorPublicKeys = []
|
|
||||||
, AP.actorSshKeys = []
|
|
||||||
}
|
|
||||||
specific = AP.CreateActivity AP.Create
|
|
||||||
{ AP.createObject = AP.CreateTicketTracker ttdetail (Just (hLocal, ttlocal))
|
|
||||||
, AP.createTarget = Nothing
|
|
||||||
}
|
|
||||||
return action { AP.actionSpecific = specific }
|
|
||||||
|
|
||||||
prepareFollow deckID luCreate = do
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
h <- asksEnv stageInstanceHost
|
|
||||||
deckHash <- encodeKeyHashid deckID
|
|
||||||
|
|
||||||
let audTopic = AudLocal [LocalActorDeck deckHash] []
|
|
||||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
|
||||||
collectAudience [audTopic]
|
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
action = AP.Action
|
|
||||||
{ AP.actionCapability = Nothing
|
|
||||||
, AP.actionSummary = Nothing
|
|
||||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
|
||||||
, AP.actionFulfills = [ObjURI h luCreate]
|
|
||||||
, AP.actionSpecific = AP.FollowActivity AP.Follow
|
|
||||||
{ AP.followObject = encodeRouteHome $ DeckR deckHash
|
|
||||||
, AP.followContext = Nothing
|
|
||||||
, AP.followHide = False
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
|
||||||
|
|
||||||
-- Meaning: The human wants to create a project
|
|
||||||
-- Behavior:
|
|
||||||
-- * Create a project on DB
|
|
||||||
-- * Create a Permit record in DB
|
|
||||||
-- * Launch a project actor
|
|
||||||
-- * Record a FollowRequest in DB
|
|
||||||
-- * Create and send Create and Follow to it
|
|
||||||
clientCreateProject
|
|
||||||
:: UTCTime
|
|
||||||
-> PersonId
|
|
||||||
-> ClientMsg
|
|
||||||
-> AP.ActorDetail
|
|
||||||
-> ActE OutboxItemId
|
|
||||||
clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do
|
|
||||||
|
|
||||||
-- Check input
|
|
||||||
verifyNothingE maybeCap "Capability not needed"
|
|
||||||
(name, msummary) <- parseTracker tracker
|
|
||||||
|
|
||||||
(actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, projectID) <- lift $ withDB $ do
|
|
||||||
|
|
||||||
-- Grab me from DB
|
|
||||||
(personMe, actorMe) <- do
|
|
||||||
p <- getJust personMeID
|
|
||||||
(p,) <$> getJust (personActor p)
|
|
||||||
let actorMeID = personActor personMe
|
|
||||||
|
|
||||||
-- Insert new project to DB
|
|
||||||
createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
|
||||||
(projectID, resourceID, projectFollowerSetID) <-
|
|
||||||
insertProject now name msummary createID actorMeID
|
|
||||||
|
|
||||||
-- Insert a Permit record
|
|
||||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
|
||||||
topicID <- insert $ PermitTopicLocal permitID resourceID
|
|
||||||
insert_ $ PermitFulfillsTopicCreation permitID
|
|
||||||
insert_ $ PermitPersonGesture permitID createID
|
|
||||||
|
|
||||||
-- Insert the Create activity to my outbox
|
|
||||||
projectHash <- lift $ encodeKeyHashid projectID
|
|
||||||
actionCreate <- lift $ prepareCreate name msummary projectHash
|
|
||||||
luCreate <- updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
|
|
||||||
|
|
||||||
-- Prepare recipient sieve for sending the Create
|
|
||||||
personMeHash <- lift $ encodeKeyHashid personMeID
|
|
||||||
let sieve =
|
|
||||||
makeRecipientSet
|
|
||||||
[LocalActorProject projectHash]
|
|
||||||
[LocalStagePersonFollowers personMeHash]
|
|
||||||
onlyProject = ProjectRoutes True False
|
|
||||||
addMe' projects = (projectHash, onlyProject) : projects
|
|
||||||
addMe rs = rs { recipProjects = addMe' $ recipProjects rs }
|
|
||||||
|
|
||||||
-- Insert a follow request, since I'm about to send a Follow
|
|
||||||
followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
|
||||||
insert_ $ FollowRequest actorMeID projectFollowerSetID True followID
|
|
||||||
|
|
||||||
-- Insert a Follow to my outbox
|
|
||||||
follow@(actionFollow, _, _, _) <- lift $ prepareFollow projectID luCreate
|
|
||||||
_luFollow <- updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
|
|
||||||
|
|
||||||
return
|
|
||||||
( personActor personMe
|
|
||||||
, localRecipSieve sieve False $ addMe localRecips
|
|
||||||
, createID
|
|
||||||
, actionCreate
|
|
||||||
, followID
|
|
||||||
, follow
|
|
||||||
, projectID
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Spawn new Project actor
|
|
||||||
success <- lift $ launchActor projectID
|
|
||||||
unless success $
|
|
||||||
error "Failed to spawn new Project, somehow ID already in Theater"
|
|
||||||
|
|
||||||
-- Send the Create
|
|
||||||
lift $ sendActivity
|
|
||||||
(LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
|
|
||||||
fwdHosts createID actionCreate
|
|
||||||
|
|
||||||
-- Send the Follow
|
|
||||||
let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
|
|
||||||
lift $ sendActivity
|
|
||||||
(LocalActorPerson personMeID) actorMeID localRecipsFollow
|
|
||||||
remoteRecipsFollow fwdHostsFollow followID actionFollow
|
|
||||||
|
|
||||||
return createID
|
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
parseTracker (AP.ActorDetail typ muser mname msummary) = do
|
|
||||||
unless (typ == AP.ActorTypeProject) $
|
|
||||||
error "clientCreateProject: Create object isn't a Project"
|
|
||||||
verifyNothingE muser "Project can't have a username"
|
|
||||||
name <- fromMaybeE mname "Project doesn't specify name"
|
|
||||||
return (name, msummary)
|
|
||||||
|
|
||||||
insertProject now name msummary obiidCreate actorMeID = do
|
|
||||||
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID)
|
|
||||||
rid <- insert $ Resource aid
|
|
||||||
did <- insert Project
|
|
||||||
{ projectActor = aid
|
|
||||||
, projectResource = rid
|
|
||||||
, projectCreate = obiidCreate
|
|
||||||
}
|
|
||||||
return (did, rid, actorFollowers a)
|
|
||||||
|
|
||||||
prepareCreate name msummary projectHash = do
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
|
||||||
hLocal <- asksEnv stageInstanceHost
|
|
||||||
let ttdetail = AP.ActorDetail
|
|
||||||
{ AP.actorType = AP.ActorTypeProject
|
|
||||||
, AP.actorUsername = Nothing
|
|
||||||
, AP.actorName = Just name
|
|
||||||
, AP.actorSummary = msummary
|
|
||||||
}
|
|
||||||
ttlocal = AP.ActorLocal
|
|
||||||
{ AP.actorId = encodeRouteLocal $ ProjectR projectHash
|
|
||||||
, AP.actorInbox = encodeRouteLocal $ ProjectInboxR projectHash
|
|
||||||
, AP.actorOutbox = Nothing
|
|
||||||
, AP.actorFollowers = Nothing
|
|
||||||
, AP.actorFollowing = Nothing
|
|
||||||
, AP.actorPublicKeys = []
|
|
||||||
, AP.actorSshKeys = []
|
|
||||||
}
|
|
||||||
specific = AP.CreateActivity AP.Create
|
|
||||||
{ AP.createObject = AP.CreateProject ttdetail (Just (hLocal, ttlocal))
|
|
||||||
, AP.createTarget = Nothing
|
|
||||||
}
|
|
||||||
return action { AP.actionSpecific = specific }
|
|
||||||
|
|
||||||
prepareFollow projectID luCreate = do
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
h <- asksEnv stageInstanceHost
|
|
||||||
projectHash <- encodeKeyHashid projectID
|
|
||||||
|
|
||||||
let audTopic = AudLocal [LocalActorProject projectHash] []
|
|
||||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
|
||||||
collectAudience [audTopic]
|
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
action = AP.Action
|
|
||||||
{ AP.actionCapability = Nothing
|
|
||||||
, AP.actionSummary = Nothing
|
|
||||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
|
||||||
, AP.actionFulfills = [ObjURI h luCreate]
|
|
||||||
, AP.actionSpecific = AP.FollowActivity AP.Follow
|
|
||||||
{ AP.followObject = encodeRouteHome $ ProjectR projectHash
|
|
||||||
, AP.followContext = Nothing
|
|
||||||
, AP.followHide = False
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
|
||||||
|
|
||||||
-- Meaning: The human wants to create a team
|
|
||||||
-- Behavior:
|
|
||||||
-- * Create a team on DB
|
|
||||||
-- * Create a Permit record in DB
|
|
||||||
-- * Launch a team actor
|
|
||||||
-- * Record a FollowRequest in DB
|
|
||||||
-- * Create and send Create and Follow to it
|
|
||||||
clientCreateTeam
|
|
||||||
:: UTCTime
|
|
||||||
-> PersonId
|
|
||||||
-> ClientMsg
|
|
||||||
-> AP.ActorDetail
|
|
||||||
-> ActE OutboxItemId
|
|
||||||
clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do
|
|
||||||
|
|
||||||
-- Check input
|
|
||||||
verifyNothingE maybeCap "Capability not needed"
|
|
||||||
(name, msummary) <- parseTracker tracker
|
|
||||||
|
|
||||||
(actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, groupID) <- lift $ withDB $ do
|
|
||||||
|
|
||||||
-- Grab me from DB
|
|
||||||
(personMe, actorMe) <- do
|
|
||||||
p <- getJust personMeID
|
|
||||||
(p,) <$> getJust (personActor p)
|
|
||||||
let actorMeID = personActor personMe
|
|
||||||
|
|
||||||
-- Insert new team to DB
|
|
||||||
createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
|
||||||
(groupID, resourceID, projectFollowerSetID) <-
|
|
||||||
insertTeam now name msummary createID actorMeID
|
|
||||||
|
|
||||||
-- Insert a Permit record
|
|
||||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
|
||||||
topicID <- insert $ PermitTopicLocal permitID resourceID
|
|
||||||
insert_ $ PermitFulfillsTopicCreation permitID
|
|
||||||
insert_ $ PermitPersonGesture permitID createID
|
|
||||||
|
|
||||||
-- Insert the Create activity to my outbox
|
|
||||||
groupHash <- lift $ encodeKeyHashid groupID
|
|
||||||
actionCreate <- lift $ prepareCreate name msummary groupHash
|
|
||||||
luCreate <- updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
|
|
||||||
|
|
||||||
-- Prepare recipient sieve for sending the Create
|
|
||||||
personMeHash <- lift $ encodeKeyHashid personMeID
|
|
||||||
let sieve =
|
|
||||||
makeRecipientSet
|
|
||||||
[LocalActorGroup groupHash]
|
|
||||||
[LocalStagePersonFollowers personMeHash]
|
|
||||||
onlyGroup = GroupRoutes True False
|
|
||||||
addMe' groups = (groupHash, onlyGroup) : groups
|
|
||||||
addMe rs = rs { recipGroups = addMe' $ recipGroups rs }
|
|
||||||
|
|
||||||
-- Insert a follow request, since I'm about to send a Follow
|
|
||||||
followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
|
||||||
insert_ $ FollowRequest actorMeID projectFollowerSetID True followID
|
|
||||||
|
|
||||||
-- Insert a Follow to my outbox
|
|
||||||
follow@(actionFollow, _, _, _) <- lift $ prepareFollow groupID luCreate
|
|
||||||
_luFollow <- updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
|
|
||||||
|
|
||||||
return
|
|
||||||
( personActor personMe
|
|
||||||
, localRecipSieve sieve False $ addMe localRecips
|
|
||||||
, createID
|
|
||||||
, actionCreate
|
|
||||||
, followID
|
|
||||||
, follow
|
|
||||||
, groupID
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Spawn new Group actor
|
|
||||||
success <- lift $ launchActor groupID
|
|
||||||
unless success $
|
|
||||||
error "Failed to spawn new Group, somehow ID already in Theater"
|
|
||||||
|
|
||||||
-- Send the Create
|
|
||||||
lift $ sendActivity
|
|
||||||
(LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
|
|
||||||
fwdHosts createID actionCreate
|
|
||||||
|
|
||||||
-- Send the Follow
|
|
||||||
let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
|
|
||||||
lift $ sendActivity
|
|
||||||
(LocalActorPerson personMeID) actorMeID localRecipsFollow
|
|
||||||
remoteRecipsFollow fwdHostsFollow followID actionFollow
|
|
||||||
|
|
||||||
return createID
|
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
parseTracker (AP.ActorDetail typ muser mname msummary) = do
|
|
||||||
unless (typ == AP.ActorTypeTeam) $
|
|
||||||
error "clientCreateTeam: Create object isn't a Team"
|
|
||||||
verifyNothingE muser "Team can't have a username"
|
|
||||||
name <- fromMaybeE mname "Team doesn't specify name"
|
|
||||||
return (name, msummary)
|
|
||||||
|
|
||||||
insertTeam now name msummary obiidCreate actorMeID = do
|
|
||||||
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID)
|
|
||||||
rid <- insert $ Resource aid
|
|
||||||
gid <- insert Group
|
|
||||||
{ groupActor = aid
|
|
||||||
, groupResource = rid
|
|
||||||
, groupCreate = obiidCreate
|
|
||||||
}
|
|
||||||
return (gid, rid, actorFollowers a)
|
|
||||||
|
|
||||||
prepareCreate name msummary groupHash = do
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
|
||||||
hLocal <- asksEnv stageInstanceHost
|
|
||||||
let ttdetail = AP.ActorDetail
|
|
||||||
{ AP.actorType = AP.ActorTypeTeam
|
|
||||||
, AP.actorUsername = Nothing
|
|
||||||
, AP.actorName = Just name
|
|
||||||
, AP.actorSummary = msummary
|
|
||||||
}
|
|
||||||
ttlocal = AP.ActorLocal
|
|
||||||
{ AP.actorId = encodeRouteLocal $ GroupR groupHash
|
|
||||||
, AP.actorInbox = encodeRouteLocal $ GroupInboxR groupHash
|
|
||||||
, AP.actorOutbox = Nothing
|
|
||||||
, AP.actorFollowers = Nothing
|
|
||||||
, AP.actorFollowing = Nothing
|
|
||||||
, AP.actorPublicKeys = []
|
|
||||||
, AP.actorSshKeys = []
|
|
||||||
}
|
|
||||||
specific = AP.CreateActivity AP.Create
|
|
||||||
{ AP.createObject = AP.CreateTeam ttdetail (Just (hLocal, ttlocal))
|
|
||||||
, AP.createTarget = Nothing
|
|
||||||
}
|
|
||||||
return action { AP.actionSpecific = specific }
|
|
||||||
|
|
||||||
prepareFollow groupID luCreate = do
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
h <- asksEnv stageInstanceHost
|
|
||||||
groupHash <- encodeKeyHashid groupID
|
|
||||||
|
|
||||||
let audTopic = AudLocal [LocalActorGroup groupHash] []
|
|
||||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
|
||||||
collectAudience [audTopic]
|
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
|
||||||
action = AP.Action
|
|
||||||
{ AP.actionCapability = Nothing
|
|
||||||
, AP.actionSummary = Nothing
|
|
||||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
|
||||||
, AP.actionFulfills = [ObjURI h luCreate]
|
|
||||||
, AP.actionSpecific = AP.FollowActivity AP.Follow
|
|
||||||
{ AP.followObject = encodeRouteHome $ GroupR groupHash
|
|
||||||
, AP.followContext = Nothing
|
|
||||||
, AP.followHide = False
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
|
||||||
|
|
||||||
-- Meaning: The human wants to create a factory
|
-- Meaning: The human wants to create a factory
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Verify human is allowed to
|
-- * Verify human is allowed to
|
||||||
|
|
@ -939,11 +528,10 @@ clientCreateFactory now personMeID (ClientMsg maybeCap localRecips remoteRecips
|
||||||
return (name, msummary)
|
return (name, msummary)
|
||||||
|
|
||||||
insertFactory now name msummary obiidCreate actorMeID = do
|
insertFactory now name msummary obiidCreate actorMeID = do
|
||||||
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Just actorMeID)
|
Entity aid a <- insertActor now name (fromMaybe "" msummary) (Left (LocalActorPerson personMeID, actorMeID, obiidCreate))
|
||||||
rid <- insert $ Resource aid
|
rid <- insert $ Resource aid
|
||||||
fid <- insert Factory
|
fid <- insert Factory
|
||||||
{ factoryResource = rid
|
{ factoryResource = rid
|
||||||
, factoryCreate = obiidCreate
|
|
||||||
}
|
}
|
||||||
return (fid, rid, actorFollowers a)
|
return (fid, rid, actorFollowers a)
|
||||||
|
|
||||||
|
|
@ -967,7 +555,7 @@ clientCreateFactory now personMeID (ClientMsg maybeCap localRecips remoteRecips
|
||||||
}
|
}
|
||||||
specific = AP.CreateActivity AP.Create
|
specific = AP.CreateActivity AP.Create
|
||||||
{ AP.createObject = AP.CreateFactory ttdetail (Just (hLocal, ttlocal))
|
{ AP.createObject = AP.CreateFactory ttdetail (Just (hLocal, ttlocal))
|
||||||
, AP.createTarget = Nothing
|
, AP.createOrigin = Nothing
|
||||||
}
|
}
|
||||||
return action { AP.actionSpecific = specific }
|
return action { AP.actionSpecific = specific }
|
||||||
|
|
||||||
|
|
@ -1000,27 +588,27 @@ clientCreate
|
||||||
-> ClientMsg
|
-> ClientMsg
|
||||||
-> AP.Create URIMode
|
-> AP.Create URIMode
|
||||||
-> ActE OutboxItemId
|
-> ActE OutboxItemId
|
||||||
clientCreate now personMeID msg (AP.Create object muTarget) =
|
clientCreate now personMeID msg (AP.Create object muOrigin) =
|
||||||
case object of
|
case object of
|
||||||
|
|
||||||
AP.CreateTicketTracker detail mlocal -> do
|
AP.CreateTicketTracker detail mlocal -> do
|
||||||
verifyNothingE mlocal "Tracker id must not be provided"
|
verifyNothingE mlocal "Tracker id must not be provided"
|
||||||
verifyNothingE muTarget "'target' not supported in Create TicketTracker"
|
uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
|
||||||
clientCreateDeck now personMeID msg detail
|
clientCreateActor now personMeID msg detail uOrigin
|
||||||
|
|
||||||
AP.CreateProject detail mlocal -> do
|
AP.CreateProject detail mlocal -> do
|
||||||
verifyNothingE mlocal "Project id must not be provided"
|
verifyNothingE mlocal "Project id must not be provided"
|
||||||
verifyNothingE muTarget "'target' not supported in Create Project"
|
uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
|
||||||
clientCreateProject now personMeID msg detail
|
clientCreateActor now personMeID msg detail uOrigin
|
||||||
|
|
||||||
AP.CreateTeam detail mlocal -> do
|
AP.CreateTeam detail mlocal -> do
|
||||||
verifyNothingE mlocal "Team id must not be provided"
|
verifyNothingE mlocal "Team id must not be provided"
|
||||||
verifyNothingE muTarget "'target' not supported in Create Team"
|
uOrigin <- fromMaybeE muOrigin "'origin' required for Create TicketTracker"
|
||||||
clientCreateTeam now personMeID msg detail
|
clientCreateActor now personMeID msg detail uOrigin
|
||||||
|
|
||||||
AP.CreateFactory detail mlocal -> do
|
AP.CreateFactory detail mlocal -> do
|
||||||
verifyNothingE mlocal "Factory id must not be provided"
|
verifyNothingE mlocal "Factory id must not be provided"
|
||||||
verifyNothingE muTarget "'target' not supported in Create Factory"
|
verifyNothingE muOrigin "'target' not supported in Create Factory"
|
||||||
clientCreateFactory now personMeID msg detail
|
clientCreateFactory now personMeID msg detail
|
||||||
|
|
||||||
_ -> throwE "Unsupported Create object for C2S"
|
_ -> throwE "Unsupported Create object for C2S"
|
||||||
|
|
|
||||||
|
|
@ -71,7 +71,7 @@ import Vervis.Data.Discussion
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
|
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model hiding (projectCreate)
|
import Vervis.Model
|
||||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
|
|
@ -2755,42 +2755,6 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
Right (author, _, addID) ->
|
Right (author, _, addID) ->
|
||||||
insert_ $ SquadThemGestureRemote themID (remoteAuthorId author) addID
|
insert_ $ SquadThemGestureRemote themID (remoteAuthorId author) addID
|
||||||
|
|
||||||
-- Meaning: Someone has created a project with my ID URI
|
|
||||||
-- Behavior:
|
|
||||||
-- * Verify I'm in a just-been-created state
|
|
||||||
-- * Verify my creator and the Create sender are the same actor
|
|
||||||
-- * Create an admin Collab record in DB
|
|
||||||
-- * Send an admin Grant to the creator
|
|
||||||
-- * Get out of the just-been-created state
|
|
||||||
projectCreateMe
|
|
||||||
:: UTCTime
|
|
||||||
-> ProjectId
|
|
||||||
-> Verse
|
|
||||||
-> ActE (Text, Act (), Next)
|
|
||||||
projectCreateMe = topicCreateMe projectResource LocalResourceProject
|
|
||||||
|
|
||||||
projectCreate
|
|
||||||
:: UTCTime
|
|
||||||
-> ProjectId
|
|
||||||
-> Verse
|
|
||||||
-> AP.Create URIMode
|
|
||||||
-> ActE (Text, Act (), Next)
|
|
||||||
projectCreate now projectID verse (AP.Create obj _muTarget) =
|
|
||||||
case obj of
|
|
||||||
|
|
||||||
AP.CreateProject _ mlocal -> do
|
|
||||||
(h, local) <- fromMaybeE mlocal "No project id provided"
|
|
||||||
let luProject = AP.actorId local
|
|
||||||
uMe <- do
|
|
||||||
projectHash <- encodeKeyHashid projectID
|
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
|
||||||
return $ encodeRouteHome $ ProjectR projectHash
|
|
||||||
unless (uMe == ObjURI h luProject) $
|
|
||||||
throwE "The created project id isn't me"
|
|
||||||
projectCreateMe now projectID verse
|
|
||||||
|
|
||||||
_ -> throwE "Unsupported Create object for Project"
|
|
||||||
|
|
||||||
-- Meaning: An actor is following someone/something
|
-- Meaning: An actor is following someone/something
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Verify the target is me
|
-- * Verify the target is me
|
||||||
|
|
@ -7614,11 +7578,10 @@ projectUndo now recipProjectID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
projectBehavior :: UTCTime -> ProjectId -> ActorMessage Project -> ActE (Text, Act (), Next)
|
projectBehavior :: UTCTime -> ProjectId -> ActorMessage Project -> ActE (Text, Act (), Next)
|
||||||
projectBehavior now projectID (MsgJ verse@(Verse _authorIdMsig body)) =
|
projectBehavior now projectID (ProjectMsgVerse verse@(Verse _authorIdMsig body)) =
|
||||||
case AP.activitySpecific $ actbActivity body of
|
case AP.activitySpecific $ actbActivity body of
|
||||||
AP.AcceptActivity accept -> projectAccept now projectID verse accept
|
AP.AcceptActivity accept -> projectAccept now projectID verse accept
|
||||||
AP.AddActivity add -> projectAdd now projectID verse add
|
AP.AddActivity add -> projectAdd now projectID verse add
|
||||||
AP.CreateActivity create -> projectCreate now projectID verse create
|
|
||||||
AP.FollowActivity follow -> projectFollow now projectID verse follow
|
AP.FollowActivity follow -> projectFollow now projectID verse follow
|
||||||
AP.GrantActivity grant -> projectGrant now projectID verse grant
|
AP.GrantActivity grant -> projectGrant now projectID verse grant
|
||||||
AP.InviteActivity invite -> projectInvite now projectID verse invite
|
AP.InviteActivity invite -> projectInvite now projectID verse invite
|
||||||
|
|
@ -7628,6 +7591,9 @@ projectBehavior now projectID (MsgJ verse@(Verse _authorIdMsig body)) =
|
||||||
AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke
|
AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke
|
||||||
AP.UndoActivity undo -> projectUndo now projectID verse undo
|
AP.UndoActivity undo -> projectUndo now projectID verse undo
|
||||||
_ -> throwE "Unsupported activity type for Project"
|
_ -> throwE "Unsupported activity type for Project"
|
||||||
|
projectBehavior now projectID (ProjectMsgInit creator) =
|
||||||
|
let grabResource = pure . projectResource
|
||||||
|
in topicInit grabResource LocalResourceProject now projectID creator
|
||||||
|
|
||||||
instance VervisActorLaunch Project where
|
instance VervisActorLaunch Project where
|
||||||
actorBehavior' now projectID ve = do
|
actorBehavior' now projectID ve = do
|
||||||
|
|
|
||||||
|
|
@ -1003,12 +1003,23 @@ createDeck
|
||||||
=> KeyHashid Person
|
=> KeyHashid Person
|
||||||
-> Text
|
-> Text
|
||||||
-> Text
|
-> Text
|
||||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
-> FedURI
|
||||||
createDeck senderHash name desc = do
|
-> ExceptT Text m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||||
|
createDeck senderHash name desc uFactory = do
|
||||||
|
audFactory <- do
|
||||||
|
routeOrRemote <- parseFedURIOld uFactory
|
||||||
|
actorOrRemote <- bitraverse parseLocalActorE pure routeOrRemote
|
||||||
|
case actorOrRemote of
|
||||||
|
Left la -> do
|
||||||
|
h <- VR.hashLocalActor la
|
||||||
|
return $ AudLocal [h] []
|
||||||
|
Right (ObjURI h lu) ->
|
||||||
|
pure $ AudRemote h [lu] []
|
||||||
|
|
||||||
let audAuthor =
|
let audAuthor =
|
||||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||||
|
|
||||||
audience = [audAuthor]
|
audience = [audAuthor, audFactory]
|
||||||
|
|
||||||
detail = AP.ActorDetail
|
detail = AP.ActorDetail
|
||||||
{ AP.actorType = AP.ActorTypeTicketTracker
|
{ AP.actorType = AP.ActorTypeTicketTracker
|
||||||
|
|
@ -1074,12 +1085,23 @@ createProject
|
||||||
=> KeyHashid Person
|
=> KeyHashid Person
|
||||||
-> Text
|
-> Text
|
||||||
-> Text
|
-> Text
|
||||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
-> FedURI
|
||||||
createProject senderHash name desc = do
|
-> ExceptT Text m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||||
|
createProject senderHash name desc uFactory = do
|
||||||
|
audFactory <- do
|
||||||
|
routeOrRemote <- parseFedURIOld uFactory
|
||||||
|
actorOrRemote <- bitraverse parseLocalActorE pure routeOrRemote
|
||||||
|
case actorOrRemote of
|
||||||
|
Left la -> do
|
||||||
|
h <- VR.hashLocalActor la
|
||||||
|
return $ AudLocal [h] []
|
||||||
|
Right (ObjURI h lu) ->
|
||||||
|
pure $ AudRemote h [lu] []
|
||||||
|
|
||||||
let audAuthor =
|
let audAuthor =
|
||||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||||
|
|
||||||
audience = [audAuthor]
|
audience = [audAuthor, audFactory]
|
||||||
|
|
||||||
detail = AP.ActorDetail
|
detail = AP.ActorDetail
|
||||||
{ AP.actorType = AP.ActorTypeProject
|
{ AP.actorType = AP.ActorTypeProject
|
||||||
|
|
@ -1095,12 +1117,23 @@ createGroup
|
||||||
=> KeyHashid Person
|
=> KeyHashid Person
|
||||||
-> Text
|
-> Text
|
||||||
-> Text
|
-> Text
|
||||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
-> FedURI
|
||||||
createGroup senderHash name desc = do
|
-> ExceptT Text m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||||
|
createGroup senderHash name desc uFactory = do
|
||||||
|
audFactory <- do
|
||||||
|
routeOrRemote <- parseFedURIOld uFactory
|
||||||
|
actorOrRemote <- bitraverse parseLocalActorE pure routeOrRemote
|
||||||
|
case actorOrRemote of
|
||||||
|
Left la -> do
|
||||||
|
h <- VR.hashLocalActor la
|
||||||
|
return $ AudLocal [h] []
|
||||||
|
Right (ObjURI h lu) ->
|
||||||
|
pure $ AudRemote h [lu] []
|
||||||
|
|
||||||
let audAuthor =
|
let audAuthor =
|
||||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||||
|
|
||||||
audience = [audAuthor]
|
audience = [audAuthor, audFactory]
|
||||||
|
|
||||||
detail = AP.ActorDetail
|
detail = AP.ActorDetail
|
||||||
{ AP.actorType = AP.ActorTypeTeam
|
{ AP.actorType = AP.ActorTypeTeam
|
||||||
|
|
|
||||||
|
|
@ -22,6 +22,7 @@ module Vervis.Data.Actor
|
||||||
, stampRoute
|
, stampRoute
|
||||||
, parseStampRoute
|
, parseStampRoute
|
||||||
, grabLocalActorID
|
, grabLocalActorID
|
||||||
|
, grabLocalResourceID
|
||||||
, localResourceID
|
, localResourceID
|
||||||
, WA.parseLocalURI
|
, WA.parseLocalURI
|
||||||
, parseFedURIOld
|
, parseFedURIOld
|
||||||
|
|
@ -72,6 +73,15 @@ import Vervis.Recipient
|
||||||
|
|
||||||
import qualified Vervis.Actor as VA
|
import qualified Vervis.Actor as VA
|
||||||
|
|
||||||
|
parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
|
||||||
|
parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i)
|
||||||
|
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
|
||||||
|
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
|
||||||
|
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
|
||||||
|
parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i)
|
||||||
|
parseOutboxItemRoute (FactoryOutboxItemR r i) = Just (LocalActorFactory r, i)
|
||||||
|
parseOutboxItemRoute _ = Nothing
|
||||||
|
|
||||||
parseLocalActivityURI
|
parseLocalActivityURI
|
||||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||||
=> LocalURI
|
=> LocalURI
|
||||||
|
|
@ -85,14 +95,6 @@ parseLocalActivityURI luAct = do
|
||||||
outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
|
outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
|
||||||
actorKey <- unhashLocalActorE actorHash "Invalid actor hash"
|
actorKey <- unhashLocalActorE actorHash "Invalid actor hash"
|
||||||
return (actorKey, actorHash, outboxItemID)
|
return (actorKey, actorHash, outboxItemID)
|
||||||
where
|
|
||||||
parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
|
|
||||||
parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i)
|
|
||||||
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
|
|
||||||
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
|
|
||||||
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
|
|
||||||
parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i)
|
|
||||||
parseOutboxItemRoute _ = Nothing
|
|
||||||
|
|
||||||
parseLocalActivityURI'
|
parseLocalActivityURI'
|
||||||
:: LocalURI
|
:: LocalURI
|
||||||
|
|
@ -106,14 +108,6 @@ parseLocalActivityURI' luAct = do
|
||||||
outboxItemID <- WAP.decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
|
outboxItemID <- WAP.decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
|
||||||
actorKey <- VA.unhashLocalActorE actorHash "Invalid actor hash"
|
actorKey <- VA.unhashLocalActorE actorHash "Invalid actor hash"
|
||||||
return (actorKey, actorHash, outboxItemID)
|
return (actorKey, actorHash, outboxItemID)
|
||||||
where
|
|
||||||
parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
|
|
||||||
parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i)
|
|
||||||
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
|
|
||||||
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
|
|
||||||
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
|
|
||||||
parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i)
|
|
||||||
parseOutboxItemRoute _ = Nothing
|
|
||||||
|
|
||||||
-- | If the given URI is remote, return as is. If the URI is local, verify that
|
-- | If the given URI is remote, return as is. If the URI is local, verify that
|
||||||
-- it parses as an activity URI, i.e. an outbox item route, and return the
|
-- it parses as an activity URI, i.e. an outbox item route, and return the
|
||||||
|
|
@ -194,6 +188,9 @@ localResourceID (LocalResourceLoom (Entity _ l)) = loomResource l
|
||||||
localResourceID (LocalResourceProject (Entity _ r)) = projectResource r
|
localResourceID (LocalResourceProject (Entity _ r)) = projectResource r
|
||||||
localResourceID (LocalResourceFactory (Entity _ f)) = factoryResource f
|
localResourceID (LocalResourceFactory (Entity _ f)) = factoryResource f
|
||||||
|
|
||||||
|
grabLocalResourceID :: MonadIO m => LocalResourceBy Entity -> SqlPersistT m ResourceId
|
||||||
|
grabLocalResourceID = pure . localResourceID
|
||||||
|
|
||||||
parseFedURIOld
|
parseFedURIOld
|
||||||
:: ( MonadSite m
|
:: ( MonadSite m
|
||||||
, SiteEnv m ~ site
|
, SiteEnv m ~ site
|
||||||
|
|
|
||||||
|
|
@ -17,23 +17,30 @@ module Vervis.Field.Person
|
||||||
( passField
|
( passField
|
||||||
, fedUriField
|
, fedUriField
|
||||||
, capField
|
, capField
|
||||||
|
, factoryField
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Data.Char (isDigit)
|
import Data.Char (isDigit)
|
||||||
|
import Data.Maybe
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Database.Esqueleto
|
import Database.Esqueleto
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
import Yesod.Form.Fields
|
import Yesod.Form.Fields
|
||||||
import Yesod.Form.Functions
|
import Yesod.Form.Functions
|
||||||
import Yesod.Form.Types
|
import Yesod.Form.Types
|
||||||
|
import Yesod.Persist.Core
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
|
import Yesod.FedURI
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
|
|
||||||
|
import qualified Web.ActivityPub as AP
|
||||||
|
|
||||||
import Control.Monad.Trans.Except.Local
|
import Control.Monad.Trans.Except.Local
|
||||||
import Data.Char.Local (isAsciiLetter)
|
import Data.Char.Local (isAsciiLetter)
|
||||||
|
|
||||||
|
|
@ -43,6 +50,7 @@ import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Ident (text2shr)
|
import Vervis.Model.Ident (text2shr)
|
||||||
|
import Vervis.Recipient
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
|
|
||||||
checkPassLength :: Field Handler Text -> Field Handler Text
|
checkPassLength :: Field Handler Text -> Field Handler Text
|
||||||
|
|
@ -98,3 +106,56 @@ capField = checkMMap toCap fst fedUriField
|
||||||
where
|
where
|
||||||
toCap u =
|
toCap u =
|
||||||
runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u)
|
runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u)
|
||||||
|
|
||||||
|
factoryField personID = selectField $ do
|
||||||
|
l <- runDB $ do
|
||||||
|
local <-
|
||||||
|
E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` factory `E.InnerJoin` resource `E.InnerJoin` actor) -> do
|
||||||
|
E.on $ resource E.^. ResourceActor E.==. actor E.^. ActorId
|
||||||
|
E.on $ factory E.^. FactoryResource E.==. resource E.^. ResourceId
|
||||||
|
E.on $ topic E.^. PermitTopicLocalTopic E.==. factory E.^. FactoryResource
|
||||||
|
E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
|
||||||
|
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
|
||||||
|
E.where_ $
|
||||||
|
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||||
|
permit E.^. PermitRole `E.in_` E.valList [AP.RoleWrite, AP.RoleMaintain, AP.RoleAdmin]
|
||||||
|
return (factory E.^. FactoryId, actor E.^. ActorName, enable E.^. PermitTopicEnableLocalGrant)
|
||||||
|
remote <-
|
||||||
|
E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` actor `E.InnerJoin` object `E.InnerJoin` i `E.InnerJoin` ract `E.InnerJoin` ro) -> do
|
||||||
|
E.on $ ract E.^. RemoteActivityIdent E.==. ro E.^. RemoteObjectId
|
||||||
|
E.on $ enable E.^. PermitTopicEnableRemoteGrant E.==. ract E.^. RemoteActivityId
|
||||||
|
E.on $ object E.^. RemoteObjectInstance E.==. i E.^. InstanceId
|
||||||
|
E.on $ actor E.^. RemoteActorIdent E.==. object E.^. RemoteObjectId
|
||||||
|
E.on $ topic E.^. PermitTopicRemoteActor E.==. actor E.^. RemoteActorId
|
||||||
|
E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
|
||||||
|
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
|
||||||
|
E.where_ $
|
||||||
|
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||||
|
actor E.^. RemoteActorType E.==. E.val AP.ActorTypeFactory E.&&.
|
||||||
|
permit E.^. PermitRole `E.in_` E.valList [AP.RoleWrite, AP.RoleMaintain, AP.RoleAdmin]
|
||||||
|
return (i E.^. InstanceHost, object E.^. RemoteObjectIdent, actor E.^. RemoteActorName, ro E.^. RemoteObjectIdent)
|
||||||
|
return $ map Left local ++ map Right remote
|
||||||
|
hashFactory <- getEncodeKeyHashid
|
||||||
|
hashItem <- getEncodeKeyHashid
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
optionsPairs $
|
||||||
|
map (\case
|
||||||
|
Left (E.Value factoryID, E.Value name, E.Value grantID) ->
|
||||||
|
( T.concat
|
||||||
|
[ "*", keyHashidText $ hashFactory factoryID
|
||||||
|
, " ", name
|
||||||
|
]
|
||||||
|
, ( encodeRouteHome $ FactoryR $ hashFactory factoryID
|
||||||
|
, encodeRouteHome $ FactoryOutboxItemR (hashFactory factoryID) (hashItem grantID)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
Right (E.Value h, E.Value lu, E.Value mname, E.Value luGrant) ->
|
||||||
|
( T.concat
|
||||||
|
[ renderObjURI $ ObjURI h lu
|
||||||
|
, " "
|
||||||
|
, fromMaybe "(?)" mname
|
||||||
|
]
|
||||||
|
, (ObjURI h lu, ObjURI h luGrant)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
l
|
||||||
|
|
|
||||||
|
|
@ -55,6 +55,7 @@ import Yesod.Hashids
|
||||||
import qualified Web.ActivityPub as AP
|
import qualified Web.ActivityPub as AP
|
||||||
|
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
|
import Vervis.Field.Person
|
||||||
import Vervis.Form.Ticket
|
import Vervis.Form.Ticket
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
|
|
@ -63,32 +64,38 @@ import Vervis.Model.Ident
|
||||||
data NewDeck = NewDeck
|
data NewDeck = NewDeck
|
||||||
{ ndName :: Text
|
{ ndName :: Text
|
||||||
, ndDesc :: Text
|
, ndDesc :: Text
|
||||||
|
, ndFactory :: (FedURI, FedURI)
|
||||||
}
|
}
|
||||||
|
|
||||||
newDeckForm :: Form NewDeck
|
newDeckForm :: PersonId -> Form NewDeck
|
||||||
newDeckForm = renderDivs $ NewDeck
|
newDeckForm p = renderDivs $ NewDeck
|
||||||
<$> areq textField "Name*" Nothing
|
<$> areq textField "Name*" Nothing
|
||||||
<*> areq textField "Description" Nothing
|
<*> areq textField "Description*" Nothing
|
||||||
|
<*> areq (factoryField p) "Factory*" Nothing
|
||||||
|
|
||||||
data NewProject = NewProject
|
data NewProject = NewProject
|
||||||
{ npName :: Text
|
{ npName :: Text
|
||||||
, npDesc :: Text
|
, npDesc :: Text
|
||||||
|
, npFactory :: (FedURI, FedURI)
|
||||||
}
|
}
|
||||||
|
|
||||||
newProjectForm :: Form NewProject
|
newProjectForm :: PersonId -> Form NewProject
|
||||||
newProjectForm = renderDivs $ NewProject
|
newProjectForm p = renderDivs $ NewProject
|
||||||
<$> areq textField "Name*" Nothing
|
<$> areq textField "Name*" Nothing
|
||||||
<*> areq textField "Description" Nothing
|
<*> areq textField "Description*" Nothing
|
||||||
|
<*> areq (factoryField p) "Factory*" Nothing
|
||||||
|
|
||||||
data NewGroup = NewGroup
|
data NewGroup = NewGroup
|
||||||
{ ngName :: Text
|
{ ngName :: Text
|
||||||
, ngDesc :: Text
|
, ngDesc :: Text
|
||||||
|
, ngFactory :: (FedURI, FedURI)
|
||||||
}
|
}
|
||||||
|
|
||||||
newGroupForm :: Form NewGroup
|
newGroupForm :: PersonId -> Form NewGroup
|
||||||
newGroupForm = renderDivs $ NewGroup
|
newGroupForm p = renderDivs $ NewGroup
|
||||||
<$> areq textField "Name*" Nothing
|
<$> areq textField "Name*" Nothing
|
||||||
<*> areq textField "Description" Nothing
|
<*> areq textField "Description*" Nothing
|
||||||
|
<*> areq (factoryField p) "Factory*" Nothing
|
||||||
|
|
||||||
data NewLoom = NewLoom
|
data NewLoom = NewLoom
|
||||||
{ nlName :: Text
|
{ nlName :: Text
|
||||||
|
|
|
||||||
|
|
@ -57,6 +57,8 @@ import Yesod.Static
|
||||||
|
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
import qualified Data.ByteString.Lazy as BL (ByteString)
|
import qualified Data.ByteString.Lazy as BL (ByteString)
|
||||||
|
import qualified Data.HashSet as HS
|
||||||
|
import qualified Data.HList as H
|
||||||
import qualified Data.Time.Units as U
|
import qualified Data.Time.Units as U
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
import qualified Yesod.Core.Unsafe as Unsafe
|
import qualified Yesod.Core.Unsafe as Unsafe
|
||||||
|
|
@ -680,7 +682,6 @@ instance AccountDB AccountPersistDB' where
|
||||||
, actorInbox = ibid
|
, actorInbox = ibid
|
||||||
, actorOutbox = obid
|
, actorOutbox = obid
|
||||||
, actorFollowers = fsid
|
, actorFollowers = fsid
|
||||||
, actorJustCreatedBy = Nothing
|
|
||||||
, actorErrbox = rbid
|
, actorErrbox = rbid
|
||||||
}
|
}
|
||||||
aid <- insert actor
|
aid <- insert actor
|
||||||
|
|
@ -719,6 +720,21 @@ instance AccountDB AccountPersistDB' where
|
||||||
takeMVar mvarResult
|
takeMVar mvarResult
|
||||||
unless success $
|
unless success $
|
||||||
error "Failed to spawn new Person, somehow ID already in Theater"
|
error "Failed to spawn new Person, somehow ID already in Theater"
|
||||||
|
AccountPersistDB' $ do
|
||||||
|
theater <- asksSite appTheater
|
||||||
|
there <- liftIO $ sendIO theater personID PersonMsgInit
|
||||||
|
unless there $
|
||||||
|
error "Failed to find new Person, somehow ID not in Theater"
|
||||||
|
factoryIDs <- runDB $ selectKeysList [] []
|
||||||
|
let package = (HS.fromList factoryIDs, FactoryMsgVerified personID)
|
||||||
|
liftIO $ sendManyIO theater $
|
||||||
|
Nothing `H.HCons`
|
||||||
|
Nothing `H.HCons`
|
||||||
|
Nothing `H.HCons`
|
||||||
|
Nothing `H.HCons`
|
||||||
|
Nothing `H.HCons`
|
||||||
|
Nothing `H.HCons`
|
||||||
|
Just package `H.HCons` H.HNil
|
||||||
setVerifyKey = (morphAPDB .) . setVerifyKey
|
setVerifyKey = (morphAPDB .) . setVerifyKey
|
||||||
setNewPasswordKey = (morphAPDB .) . setNewPasswordKey
|
setNewPasswordKey = (morphAPDB .) . setNewPasswordKey
|
||||||
setNewPassword = (morphAPDB .) . setNewPassword
|
setNewPassword = (morphAPDB .) . setNewPassword
|
||||||
|
|
|
||||||
|
|
@ -353,34 +353,31 @@ getDeckMessageR _ _ = notFound
|
||||||
|
|
||||||
getDeckNewR :: Handler Html
|
getDeckNewR :: Handler Html
|
||||||
getDeckNewR = do
|
getDeckNewR = do
|
||||||
((_result, widget), enctype) <- runFormPost newDeckForm
|
p <- requireAuthId
|
||||||
|
((_result, widget), enctype) <- runFormPost $ newDeckForm p
|
||||||
defaultLayout $(widgetFile "deck/new")
|
defaultLayout $(widgetFile "deck/new")
|
||||||
|
|
||||||
postDeckNewR :: Handler Html
|
postDeckNewR :: Handler Html
|
||||||
postDeckNewR = do
|
postDeckNewR = do
|
||||||
NewDeck name desc <- runFormPostRedirect DeckNewR newDeckForm
|
|
||||||
|
|
||||||
personEntity@(Entity personID person) <- requireAuth
|
personEntity@(Entity personID person) <- requireAuth
|
||||||
|
NewDeck name desc (uFactory, uCap) <- runFormPostRedirect DeckNewR $ newDeckForm personID
|
||||||
|
|
||||||
personHash <- encodeKeyHashid personID
|
personHash <- encodeKeyHashid personID
|
||||||
(maybeSummary, audience, detail) <- C.createDeck personHash name desc
|
result <- runExceptT $ do
|
||||||
|
(maybeSummary, audience, detail) <- C.createDeck personHash name desc uFactory
|
||||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) Nothing
|
lift $
|
||||||
result <-
|
C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) (Just uFactory)
|
||||||
runExceptT $
|
cap <- parseActivityURI uCap
|
||||||
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||||
|
|
||||||
case result of
|
case result of
|
||||||
Left e -> do
|
Left e -> do
|
||||||
setMessage $ toHtml e
|
setMessage $ toHtml e
|
||||||
redirect DeckNewR
|
redirect DeckNewR
|
||||||
Right createID -> do
|
Right _createID -> do
|
||||||
maybeDeckID <- runDB $ getKeyBy $ UniqueDeckCreate createID
|
setMessage "Create activity sent"
|
||||||
case maybeDeckID of
|
redirect HomeR
|
||||||
Nothing -> error "Can't find the newly created deck"
|
|
||||||
Just deckID -> do
|
|
||||||
deckHash <- encodeKeyHashid deckID
|
|
||||||
setMessage "New ticket tracker created"
|
|
||||||
redirect $ DeckR deckHash
|
|
||||||
|
|
||||||
postDeckDeleteR :: KeyHashid Deck -> Handler Html
|
postDeckDeleteR :: KeyHashid Deck -> Handler Html
|
||||||
postDeckDeleteR _ = error "Temporarily disabled"
|
postDeckDeleteR _ = error "Temporarily disabled"
|
||||||
|
|
|
||||||
|
|
@ -126,12 +126,17 @@ import qualified Vervis.Client as C
|
||||||
getFactoryR :: KeyHashid Factory -> Handler TypedContent
|
getFactoryR :: KeyHashid Factory -> Handler TypedContent
|
||||||
getFactoryR factoryHash = do
|
getFactoryR factoryHash = do
|
||||||
factoryID <- decodeKeyHashid404 factoryHash
|
factoryID <- decodeKeyHashid404 factoryHash
|
||||||
(factory, actor, sigKeyIDs) <- runDB $ do
|
mp <- maybeAuthId
|
||||||
|
(factory, actorID, actor, sigKeyIDs, permits) <- runDB $ do
|
||||||
f <- get404 factoryID
|
f <- get404 factoryID
|
||||||
Resource aid <- getJust $ factoryResource f
|
Resource aid <- getJust $ factoryResource f
|
||||||
a <- getJust aid
|
a <- getJust aid
|
||||||
sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
|
sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
|
||||||
return (f, a, sigKeys)
|
permits <-
|
||||||
|
case mp of
|
||||||
|
Nothing -> pure []
|
||||||
|
Just personID -> getPermitsForResource personID (Left $ factoryResource f)
|
||||||
|
return (f, aid, a, sigKeys, permits)
|
||||||
|
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
hashSigKey <- getEncodeKeyHashid
|
hashSigKey <- getEncodeKeyHashid
|
||||||
|
|
@ -166,7 +171,7 @@ getFactoryR factoryHash = do
|
||||||
encodeRouteLocal $ FactoryTeamsR factoryHash
|
encodeRouteLocal $ FactoryTeamsR factoryHash
|
||||||
}
|
}
|
||||||
|
|
||||||
provideHtmlAndAP factoryAP $ redirectToPrettyJSON $ FactoryR factoryHash
|
provideHtmlAndAP factoryAP $(widgetFile "factory/one")
|
||||||
|
|
||||||
grabActorID = fmap resourceActor . getJust . factoryResource
|
grabActorID = fmap resourceActor . getJust . factoryResource
|
||||||
|
|
||||||
|
|
@ -221,7 +226,11 @@ postFactoryNewR = do
|
||||||
setMessage $ toHtml e
|
setMessage $ toHtml e
|
||||||
redirect FactoryNewR
|
redirect FactoryNewR
|
||||||
Right createID -> do
|
Right createID -> do
|
||||||
maybeFactoryID <- runDB $ getKeyBy $ UniqueFactoryCreate createID
|
maybeFactoryID <- runDB $ runMaybeT $ do
|
||||||
|
ActorCreateLocal actorID _ <-
|
||||||
|
MaybeT $ getValBy $ UniqueActorCreateLocalCreate createID
|
||||||
|
resourceID <- MaybeT $ getKeyBy $ UniqueResource actorID
|
||||||
|
MaybeT $ getKeyBy $ UniqueFactory resourceID
|
||||||
case maybeFactoryID of
|
case maybeFactoryID of
|
||||||
Nothing -> error "Can't find the newly created factory"
|
Nothing -> error "Can't find the newly created factory"
|
||||||
Just factoryID -> do
|
Just factoryID -> do
|
||||||
|
|
|
||||||
|
|
@ -147,34 +147,31 @@ import qualified Vervis.Client as C
|
||||||
|
|
||||||
getGroupNewR :: Handler Html
|
getGroupNewR :: Handler Html
|
||||||
getGroupNewR = do
|
getGroupNewR = do
|
||||||
((_result, widget), enctype) <- runFormPost newGroupForm
|
p <- requireAuthId
|
||||||
|
((_result, widget), enctype) <- runFormPost $ newGroupForm p
|
||||||
defaultLayout $(widgetFile "group/new")
|
defaultLayout $(widgetFile "group/new")
|
||||||
|
|
||||||
postGroupNewR :: Handler Html
|
postGroupNewR :: Handler Html
|
||||||
postGroupNewR = do
|
postGroupNewR = do
|
||||||
NewGroup name desc <- runFormPostRedirect GroupNewR newGroupForm
|
|
||||||
|
|
||||||
personEntity@(Entity personID person) <- requireAuth
|
personEntity@(Entity personID person) <- requireAuth
|
||||||
|
NewGroup name desc (uFactory, uCap) <- runFormPostRedirect GroupNewR $ newGroupForm personID
|
||||||
|
|
||||||
personHash <- encodeKeyHashid personID
|
personHash <- encodeKeyHashid personID
|
||||||
(maybeSummary, audience, detail) <- C.createGroup personHash name desc
|
result <- runExceptT $ do
|
||||||
|
(maybeSummary, audience, detail) <- C.createGroup personHash name desc uFactory
|
||||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) Nothing
|
lift $
|
||||||
result <-
|
C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) (Just uFactory)
|
||||||
runExceptT $
|
cap <- parseActivityURI uCap
|
||||||
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||||
|
|
||||||
case result of
|
case result of
|
||||||
Left e -> do
|
Left e -> do
|
||||||
setMessage $ toHtml e
|
setMessage $ toHtml e
|
||||||
redirect GroupNewR
|
redirect GroupNewR
|
||||||
Right createID -> do
|
Right _createID -> do
|
||||||
maybeGroupID <- runDB $ getKeyBy $ UniqueGroupCreate createID
|
setMessage "Create activity sent"
|
||||||
case maybeGroupID of
|
redirect HomeR
|
||||||
Nothing -> error "Can't find the newly created group"
|
|
||||||
Just groupID -> do
|
|
||||||
groupHash <- encodeKeyHashid groupID
|
|
||||||
setMessage "New group created"
|
|
||||||
redirect $ GroupR groupHash
|
|
||||||
|
|
||||||
getGroupR :: KeyHashid Group -> Handler TypedContent
|
getGroupR :: KeyHashid Group -> Handler TypedContent
|
||||||
getGroupR groupHash = do
|
getGroupR groupHash = do
|
||||||
|
|
|
||||||
|
|
@ -362,14 +362,9 @@ postLoomNewR = do
|
||||||
Left e -> do
|
Left e -> do
|
||||||
setMessage $ toHtml e
|
setMessage $ toHtml e
|
||||||
redirect LoomNewR
|
redirect LoomNewR
|
||||||
Right createID -> do
|
Right _createID -> do
|
||||||
maybeLoomID <- runDB $ getKeyBy $ UniqueLoomCreate createID
|
setMessage "Create activity sent"
|
||||||
case maybeLoomID of
|
redirect HomeR
|
||||||
Nothing -> error "Can't find the newly created loom"
|
|
||||||
Just loomID -> do
|
|
||||||
loomHash <- encodeKeyHashid loomID
|
|
||||||
setMessage "New patch tracker created"
|
|
||||||
redirect $ LoomR loomHash
|
|
||||||
|
|
||||||
getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent
|
getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent
|
||||||
getLoomStampR = servePerActorKey loomActor LocalActorLoom
|
getLoomStampR = servePerActorKey loomActor LocalActorLoom
|
||||||
|
|
|
||||||
|
|
@ -225,34 +225,31 @@ getProjectMessageR _ _ = notFound
|
||||||
|
|
||||||
getProjectNewR :: Handler Html
|
getProjectNewR :: Handler Html
|
||||||
getProjectNewR = do
|
getProjectNewR = do
|
||||||
((_result, widget), enctype) <- runFormPost newProjectForm
|
p <- requireAuthId
|
||||||
|
((_result, widget), enctype) <- runFormPost $ newProjectForm p
|
||||||
defaultLayout $(widgetFile "project/new")
|
defaultLayout $(widgetFile "project/new")
|
||||||
|
|
||||||
postProjectNewR :: Handler Html
|
postProjectNewR :: Handler Html
|
||||||
postProjectNewR = do
|
postProjectNewR = do
|
||||||
NewProject name desc <- runFormPostRedirect ProjectNewR newProjectForm
|
|
||||||
|
|
||||||
personEntity@(Entity personID person) <- requireAuth
|
personEntity@(Entity personID person) <- requireAuth
|
||||||
|
NewProject name desc (uFactory, uCap) <- runFormPostRedirect ProjectNewR $ newProjectForm personID
|
||||||
|
|
||||||
personHash <- encodeKeyHashid personID
|
personHash <- encodeKeyHashid personID
|
||||||
(maybeSummary, audience, detail) <- C.createProject personHash name desc
|
result <- runExceptT $ do
|
||||||
|
(maybeSummary, audience, detail) <- C.createProject personHash name desc uFactory
|
||||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) Nothing
|
lift $
|
||||||
result <-
|
C.makeServerInput (Just uCap) maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) (Just uFactory)
|
||||||
runExceptT $
|
cap <- parseActivityURI uCap
|
||||||
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
handleViaActor personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||||
|
|
||||||
case result of
|
case result of
|
||||||
Left e -> do
|
Left e -> do
|
||||||
setMessage $ toHtml e
|
setMessage $ toHtml e
|
||||||
redirect ProjectNewR
|
redirect ProjectNewR
|
||||||
Right createID -> do
|
Right _createID -> do
|
||||||
maybeProjectID <- runDB $ getKeyBy $ UniqueProjectCreate createID
|
setMessage "Create activity sent"
|
||||||
case maybeProjectID of
|
redirect HomeR
|
||||||
Nothing -> error "Can't find the newly created project"
|
|
||||||
Just projectID -> do
|
|
||||||
projectHash <- encodeKeyHashid projectID
|
|
||||||
setMessage "New project created"
|
|
||||||
redirect $ ProjectR projectHash
|
|
||||||
|
|
||||||
getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent
|
getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent
|
||||||
getProjectStampR = servePerActorKey projectActor LocalActorProject
|
getProjectStampR = servePerActorKey projectActor LocalActorProject
|
||||||
|
|
|
||||||
|
|
@ -472,14 +472,9 @@ postRepoNewR = do
|
||||||
Left e -> do
|
Left e -> do
|
||||||
setMessage $ toHtml e
|
setMessage $ toHtml e
|
||||||
redirect RepoNewR
|
redirect RepoNewR
|
||||||
Right createID -> do
|
Right _createID -> do
|
||||||
maybeRepoID <- runDB $ getKeyBy $ UniqueRepoCreate createID
|
setMessage "Create activity sent"
|
||||||
case maybeRepoID of
|
redirect HomeR
|
||||||
Nothing -> error "Can't find the newly created repo"
|
|
||||||
Just repoID -> do
|
|
||||||
repoHash <- encodeKeyHashid repoID
|
|
||||||
setMessage "New repository created"
|
|
||||||
redirect $ RepoR repoHash
|
|
||||||
|
|
||||||
postRepoDeleteR :: KeyHashid Repo -> Handler Html
|
postRepoDeleteR :: KeyHashid Repo -> Handler Html
|
||||||
postRepoDeleteR repoHash = do
|
postRepoDeleteR repoHash = do
|
||||||
|
|
|
||||||
|
|
@ -3850,6 +3850,69 @@ changes hLocal ctx =
|
||||||
, addEntities model_648_report
|
, addEntities model_648_report
|
||||||
-- 649
|
-- 649
|
||||||
, addEntities model_649_factory
|
, addEntities model_649_factory
|
||||||
|
-- 650
|
||||||
|
, addEntities model_650_fulfills_resident
|
||||||
|
-- 651
|
||||||
|
, unchecked $ lift $ do
|
||||||
|
ps <- selectList [Person651Verified ==. True] []
|
||||||
|
let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
|
||||||
|
for_ ps $ \ (Entity pid p) -> do
|
||||||
|
let aid = person651Actor p
|
||||||
|
obid <- actor651Outbox <$> getJust aid
|
||||||
|
createID <- insert $ OutboxItem651 obid doc defaultTime
|
||||||
|
insert_ $ ActorCreateLocal651 aid createID
|
||||||
|
|
||||||
|
rs <- map entityVal <$> selectList [] []
|
||||||
|
ds <- map entityVal <$> selectList [] []
|
||||||
|
ls <- map entityVal <$> selectList [] []
|
||||||
|
js <- map entityVal <$> selectList [] []
|
||||||
|
gs <- map entityVal <$> selectList [] []
|
||||||
|
let l = concat
|
||||||
|
[ map (\ r -> (repo651Actor r, repo651Create r)) rs
|
||||||
|
, map (\ d -> (deck651Actor d, deck651Create d)) ds
|
||||||
|
, map (\ l -> (loom651Actor l, loom651Create l)) ls
|
||||||
|
, map (\ j -> (project651Actor j, project651Create j)) js
|
||||||
|
, map (\ g -> (group651Actor g, group651Create g)) gs
|
||||||
|
]
|
||||||
|
insertMany_ $ map (uncurry ActorCreateLocal651) l
|
||||||
|
|
||||||
|
{-
|
||||||
|
inboxID <- insert Inbox651
|
||||||
|
errboxID <- insert Inbox651
|
||||||
|
outboxID <- insert Outbox651
|
||||||
|
fsID <- insert FollowerSet651
|
||||||
|
actorID <- insert $ Actor651 "Default factory" "" defaultTime inboxID outboxID fsID Nothing errboxID
|
||||||
|
resourceID <- insert $ Resource651 actorID
|
||||||
|
createID <- insert $ OutboxItem651 outboxID doc defaultTime
|
||||||
|
insert_ $ Factory651 resourceID createID
|
||||||
|
insert_ $ ActorCreateLocal651 actorID createID
|
||||||
|
-}
|
||||||
|
-- 652
|
||||||
|
, removeField "Actor" "justCreatedBy"
|
||||||
|
-- 653
|
||||||
|
, removeUnique' "Deck" "Create"
|
||||||
|
-- 654
|
||||||
|
, removeUnique' "Loom" "Create"
|
||||||
|
-- 655
|
||||||
|
, removeUnique' "Repo" "Create"
|
||||||
|
-- 656
|
||||||
|
, removeUnique' "Project" "Create"
|
||||||
|
-- 657
|
||||||
|
, removeUnique' "Group" "Create"
|
||||||
|
-- 658
|
||||||
|
, removeUnique' "Factory" "Create"
|
||||||
|
-- 659
|
||||||
|
, removeField "Deck" "create"
|
||||||
|
-- 660
|
||||||
|
, removeField "Loom" "create"
|
||||||
|
-- 661
|
||||||
|
, removeField "Repo" "create"
|
||||||
|
-- 662
|
||||||
|
, removeField "Project" "create"
|
||||||
|
-- 663
|
||||||
|
, removeField "Group" "create"
|
||||||
|
-- 664
|
||||||
|
, removeField "Factory" "create"
|
||||||
]
|
]
|
||||||
|
|
||||||
migrateDB
|
migrateDB
|
||||||
|
|
|
||||||
|
|
@ -80,6 +80,7 @@ module Vervis.Migration.Entities
|
||||||
, model_639_component_convey
|
, model_639_component_convey
|
||||||
, model_648_report
|
, model_648_report
|
||||||
, model_649_factory
|
, model_649_factory
|
||||||
|
, model_650_fulfills_resident
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -315,3 +316,6 @@ model_648_report = $(schema "648_2024-07-06_report")
|
||||||
|
|
||||||
model_649_factory :: [Entity SqlBackend]
|
model_649_factory :: [Entity SqlBackend]
|
||||||
model_649_factory = $(schema "649_2024-07-29_factory")
|
model_649_factory = $(schema "649_2024-07-29_factory")
|
||||||
|
|
||||||
|
model_650_fulfills_resident :: [Entity SqlBackend]
|
||||||
|
model_650_fulfills_resident = $(schema "650_2024-08-03_fulfills_resident")
|
||||||
|
|
|
||||||
|
|
@ -80,3 +80,6 @@ makeEntitiesMigration "630"
|
||||||
|
|
||||||
makeEntitiesMigration "634"
|
makeEntitiesMigration "634"
|
||||||
$(modelFile "migrations/634_2024-04-29_stem_holder.model")
|
$(modelFile "migrations/634_2024-04-29_stem_holder.model")
|
||||||
|
|
||||||
|
makeEntitiesMigration "651"
|
||||||
|
$(modelFile "migrations/651_2024-08-03_actor_create.model")
|
||||||
|
|
|
||||||
|
|
@ -273,7 +273,7 @@ getRemoteActivityURI act = do
|
||||||
object <- getJust $ remoteActivityIdent act
|
object <- getJust $ remoteActivityIdent act
|
||||||
getRemoteObjectURI object
|
getRemoteObjectURI object
|
||||||
|
|
||||||
insertActor now name desc mby = do
|
insertActor now name desc create = do
|
||||||
ibid <- insert Inbox
|
ibid <- insert Inbox
|
||||||
rbid <- insert Inbox
|
rbid <- insert Inbox
|
||||||
obid <- insert Outbox
|
obid <- insert Outbox
|
||||||
|
|
@ -285,10 +285,12 @@ insertActor now name desc mby = do
|
||||||
, actorInbox = ibid
|
, actorInbox = ibid
|
||||||
, actorOutbox = obid
|
, actorOutbox = obid
|
||||||
, actorFollowers = fsid
|
, actorFollowers = fsid
|
||||||
, actorJustCreatedBy = mby
|
|
||||||
, actorErrbox = rbid
|
, actorErrbox = rbid
|
||||||
}
|
}
|
||||||
actorID <- insert actor
|
actorID <- insert actor
|
||||||
|
case create of
|
||||||
|
Left (_, _, obiid) -> insert_ $ ActorCreateLocal actorID obiid
|
||||||
|
Right (ra, _, act) -> insert_ $ ActorCreateRemote actorID act (VA.remoteAuthorId ra)
|
||||||
return $ Entity actorID actor
|
return $ Entity actorID actor
|
||||||
|
|
||||||
updateOutboxItem
|
updateOutboxItem
|
||||||
|
|
|
||||||
|
|
@ -158,6 +158,12 @@ data AppSettings = AppSettings
|
||||||
, appMail :: Maybe MailSettings
|
, appMail :: Maybe MailSettings
|
||||||
-- | People's usernames who are allowed to create Factory actors
|
-- | People's usernames who are allowed to create Factory actors
|
||||||
, appCanCreateFactories :: [Text]
|
, appCanCreateFactories :: [Text]
|
||||||
|
-- | KeyHashids of local Factory actors who will auto-send a
|
||||||
|
-- develop-Grant to every newly created account.
|
||||||
|
--
|
||||||
|
-- If empty, and there's exactly 1 local factory in DB, it will
|
||||||
|
-- automatically become the resident.
|
||||||
|
, appResidentFactories :: [Text]
|
||||||
|
|
||||||
-- | Whether to support federation. This includes:
|
-- | Whether to support federation. This includes:
|
||||||
--
|
--
|
||||||
|
|
@ -257,6 +263,7 @@ instance FromJSON AppSettings where
|
||||||
appEmailVerification <- o .:? "email-verification" .!= not defaultDev
|
appEmailVerification <- o .:? "email-verification" .!= not defaultDev
|
||||||
appMail <- o .:? "mail"
|
appMail <- o .:? "mail"
|
||||||
appCanCreateFactories <- o .:? "can-create-factories" .!= []
|
appCanCreateFactories <- o .:? "can-create-factories" .!= []
|
||||||
|
appResidentFactories <- o .:? "resident-factories" .!= []
|
||||||
|
|
||||||
appFederation <- o .:? "federation" .!= False
|
appFederation <- o .:? "federation" .!= False
|
||||||
appCapabilitySigningKeyFile <- o .: "capability-signing-key"
|
appCapabilitySigningKeyFile <- o .: "capability-signing-key"
|
||||||
|
|
|
||||||
|
|
@ -2005,6 +2005,7 @@ data CreateObject u
|
||||||
| CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
|
| CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
|
||||||
| CreateTeam ActorDetail (Maybe (Authority u, ActorLocal u))
|
| CreateTeam ActorDetail (Maybe (Authority u, ActorLocal u))
|
||||||
| CreateFactory ActorDetail (Maybe (Authority u, ActorLocal u))
|
| CreateFactory ActorDetail (Maybe (Authority u, ActorLocal u))
|
||||||
|
| CreatePerson ActorDetail (Maybe (Authority u, ActorLocal u))
|
||||||
|
|
||||||
parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
|
parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
|
||||||
parseCreateObject o
|
parseCreateObject o
|
||||||
|
|
@ -2042,6 +2043,11 @@ parseCreateObject o
|
||||||
fail "type isn't Factory"
|
fail "type isn't Factory"
|
||||||
ml <- parseActorLocal o
|
ml <- parseActorLocal o
|
||||||
return $ CreateFactory f ml
|
return $ CreateFactory f ml
|
||||||
|
<|> do f <- parseActorDetail o
|
||||||
|
unless (actorType f == ActorTypePerson) $
|
||||||
|
fail "type isn't Person"
|
||||||
|
ml <- parseActorLocal o
|
||||||
|
return $ CreatePerson f ml
|
||||||
|
|
||||||
encodeCreateObject :: UriMode u => CreateObject u -> Series
|
encodeCreateObject :: UriMode u => CreateObject u -> Series
|
||||||
encodeCreateObject (CreateNote h note) = toSeries h note
|
encodeCreateObject (CreateNote h note) = toSeries h note
|
||||||
|
|
@ -2062,10 +2068,12 @@ encodeCreateObject (CreateTeam d ml) =
|
||||||
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
||||||
encodeCreateObject (CreateFactory d ml) =
|
encodeCreateObject (CreateFactory d ml) =
|
||||||
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
||||||
|
encodeCreateObject (CreatePerson d ml) =
|
||||||
|
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
||||||
|
|
||||||
data Create u = Create
|
data Create u = Create
|
||||||
{ createObject :: CreateObject u
|
{ createObject :: CreateObject u
|
||||||
, createTarget :: Maybe (ObjURI u)
|
, createOrigin :: Maybe (ObjURI u)
|
||||||
}
|
}
|
||||||
|
|
||||||
parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u)
|
parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u)
|
||||||
|
|
@ -2084,12 +2092,13 @@ parseCreate o a luActor = do
|
||||||
CreateProject _ _ -> return ()
|
CreateProject _ _ -> return ()
|
||||||
CreateTeam _ _ -> return ()
|
CreateTeam _ _ -> return ()
|
||||||
CreateFactory _ _ -> return ()
|
CreateFactory _ _ -> return ()
|
||||||
Create obj <$> o .:? "target"
|
CreatePerson _ _ -> return ()
|
||||||
|
Create obj <$> o .:? "origin"
|
||||||
|
|
||||||
encodeCreate :: UriMode u => Create u -> Series
|
encodeCreate :: UriMode u => Create u -> Series
|
||||||
encodeCreate (Create obj target)
|
encodeCreate (Create obj origin)
|
||||||
= "object" `pair` pairs (encodeCreateObject obj)
|
= "object" `pair` pairs (encodeCreateObject obj)
|
||||||
<> "target" .=? target
|
<> "origin" .=? origin
|
||||||
|
|
||||||
data Follow u = Follow
|
data Follow u = Follow
|
||||||
{ followObject :: ObjURI u
|
{ followObject :: ObjURI u
|
||||||
|
|
|
||||||
|
|
@ -236,4 +236,4 @@ sendHttp (DeliveryTheater manager headers micros logFunc root theater) method re
|
||||||
for_ recips $ \ u ->
|
for_ recips $ \ u ->
|
||||||
let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root </>) . T.unpack >>= mkEnv (manager, headers, micros) logFunc
|
let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root </>) . T.unpack >>= mkEnv (manager, headers, micros) logFunc
|
||||||
in void $ spawnIO theater u makeEnv
|
in void $ spawnIO theater u makeEnv
|
||||||
sendManyIO theater $ (HS.fromList recips, method) `H.HCons` H.HNil
|
sendManyIO theater $ Just (HS.fromList recips, method) `H.HCons` H.HNil
|
||||||
|
|
|
||||||
|
|
@ -17,7 +17,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
<div>
|
<div>
|
||||||
$if verified
|
$if verified
|
||||||
<span>
|
<span>
|
||||||
[You are logged in as
|
[You are logged in as #
|
||||||
$if can
|
$if can
|
||||||
<span>👑
|
<span>👑
|
||||||
<span .username>#{personLogin person}</span>]
|
<span .username>#{personLogin person}</span>]
|
||||||
|
|
|
||||||
19
templates/factory/one.hamlet
Normal file
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
|
inbox InboxId
|
||||||
outbox OutboxId
|
outbox OutboxId
|
||||||
followers FollowerSetId
|
followers FollowerSetId
|
||||||
justCreatedBy ActorId Maybe
|
|
||||||
errbox InboxId
|
errbox InboxId
|
||||||
|
|
||||||
UniqueActorInbox inbox
|
UniqueActorInbox inbox
|
||||||
UniqueActorOutbox outbox
|
UniqueActorOutbox outbox
|
||||||
UniqueActorFollowers followers
|
UniqueActorFollowers followers
|
||||||
|
|
||||||
|
ActorCreateLocal
|
||||||
|
actor ActorId
|
||||||
|
create OutboxItemId
|
||||||
|
|
||||||
|
UniqueActorCreateLocalActor actor
|
||||||
|
UniqueActorCreateLocalCreate create
|
||||||
|
|
||||||
|
ActorCreateRemote
|
||||||
|
actor ActorId
|
||||||
|
create RemoteActivityId
|
||||||
|
sender RemoteActorId
|
||||||
|
|
||||||
|
UniqueActorCreateRemoteActor actor
|
||||||
|
UniqueActorCreateRemoteCreate create
|
||||||
|
|
||||||
SigKey
|
SigKey
|
||||||
actor ActorId
|
actor ActorId
|
||||||
material ActorKey
|
material ActorKey
|
||||||
|
|
@ -169,10 +183,8 @@ Komponent
|
||||||
|
|
||||||
Factory
|
Factory
|
||||||
resource ResourceId
|
resource ResourceId
|
||||||
create OutboxItemId
|
|
||||||
|
|
||||||
UniqueFactory resource
|
UniqueFactory resource
|
||||||
UniqueFactoryCreate create
|
|
||||||
|
|
||||||
-- ========================================================================= --
|
-- ========================================================================= --
|
||||||
-- Delivery
|
-- Delivery
|
||||||
|
|
@ -297,10 +309,8 @@ SshKey
|
||||||
Group
|
Group
|
||||||
actor ActorId
|
actor ActorId
|
||||||
resource ResourceId
|
resource ResourceId
|
||||||
create OutboxItemId
|
|
||||||
|
|
||||||
UniqueGroupActor actor
|
UniqueGroupActor actor
|
||||||
UniqueGroupCreate create
|
|
||||||
|
|
||||||
GroupMember
|
GroupMember
|
||||||
person PersonId
|
person PersonId
|
||||||
|
|
@ -317,10 +327,8 @@ GroupMember
|
||||||
Project
|
Project
|
||||||
actor ActorId
|
actor ActorId
|
||||||
resource ResourceId
|
resource ResourceId
|
||||||
create OutboxItemId
|
|
||||||
|
|
||||||
UniqueProjectActor actor
|
UniqueProjectActor actor
|
||||||
UniqueProjectCreate create
|
|
||||||
|
|
||||||
Deck
|
Deck
|
||||||
actor ActorId
|
actor ActorId
|
||||||
|
|
@ -329,10 +337,8 @@ Deck
|
||||||
workflow WorkflowId
|
workflow WorkflowId
|
||||||
nextTicket Int
|
nextTicket Int
|
||||||
wiki RepoId Maybe
|
wiki RepoId Maybe
|
||||||
create OutboxItemId
|
|
||||||
|
|
||||||
UniqueDeckActor actor
|
UniqueDeckActor actor
|
||||||
UniqueDeckCreate create
|
|
||||||
|
|
||||||
Loom
|
Loom
|
||||||
nextTicket Int
|
nextTicket Int
|
||||||
|
|
@ -340,11 +346,9 @@ Loom
|
||||||
resource ResourceId
|
resource ResourceId
|
||||||
komponent KomponentId
|
komponent KomponentId
|
||||||
repo RepoId
|
repo RepoId
|
||||||
create OutboxItemId
|
|
||||||
|
|
||||||
UniqueLoomActor actor
|
UniqueLoomActor actor
|
||||||
UniqueLoomRepo repo
|
UniqueLoomRepo repo
|
||||||
UniqueLoomCreate create
|
|
||||||
|
|
||||||
Repo
|
Repo
|
||||||
vcs VersionControlSystem
|
vcs VersionControlSystem
|
||||||
|
|
@ -353,11 +357,9 @@ Repo
|
||||||
actor ActorId
|
actor ActorId
|
||||||
resource ResourceId
|
resource ResourceId
|
||||||
komponent KomponentId
|
komponent KomponentId
|
||||||
create OutboxItemId
|
|
||||||
loom LoomId Maybe
|
loom LoomId Maybe
|
||||||
|
|
||||||
UniqueRepoActor actor
|
UniqueRepoActor actor
|
||||||
UniqueRepoCreate create
|
|
||||||
|
|
||||||
-- I removed the 'sharer' field so Workflows don't specify who controls them
|
-- I removed the 'sharer' field so Workflows don't specify who controls them
|
||||||
-- For now there's no way to create new ones, and what's already in the DB can
|
-- For now there's no way to create new ones, and what's already in the DB can
|
||||||
|
|
@ -624,6 +626,11 @@ CollabFulfillsLocalTopicCreation
|
||||||
|
|
||||||
UniqueCollabFulfillsLocalTopicCreation collab
|
UniqueCollabFulfillsLocalTopicCreation collab
|
||||||
|
|
||||||
|
CollabFulfillsResidentFactory
|
||||||
|
collab CollabId
|
||||||
|
|
||||||
|
UniqueCollabFulfillsResidentFactory collab
|
||||||
|
|
||||||
CollabFulfillsInvite
|
CollabFulfillsInvite
|
||||||
collab CollabId
|
collab CollabId
|
||||||
accept OutboxItemId
|
accept OutboxItemId
|
||||||
|
|
@ -776,6 +783,11 @@ PermitFulfillsTopicCreation
|
||||||
|
|
||||||
UniquePermitFulfillsTopicCreation permit
|
UniquePermitFulfillsTopicCreation permit
|
||||||
|
|
||||||
|
PermitFulfillsResidentFactory
|
||||||
|
permit PermitId
|
||||||
|
|
||||||
|
UniquePermitFulfillsResidentFactory permit
|
||||||
|
|
||||||
PermitFulfillsInvite
|
PermitFulfillsInvite
|
||||||
permit PermitId
|
permit PermitId
|
||||||
|
|
||||||
|
|
@ -792,6 +804,7 @@ PermitFulfillsJoin
|
||||||
-- Invite: Witnesses their approval, seeing the topic's accept, and then
|
-- Invite: Witnesses their approval, seeing the topic's accept, and then
|
||||||
-- sending their own accept
|
-- sending their own accept
|
||||||
-- Create: Records the Create activity that created the topic
|
-- Create: Records the Create activity that created the topic
|
||||||
|
-- Factory: Records the self-Create the Person published
|
||||||
|
|
||||||
PermitPersonGesture
|
PermitPersonGesture
|
||||||
permit PermitId
|
permit PermitId
|
||||||
|
|
@ -852,6 +865,8 @@ PermitTopicAcceptRemote
|
||||||
-- Invite: Seeing existing-collaborator's Invite and new-collaborator's Accept,
|
-- Invite: Seeing existing-collaborator's Invite and new-collaborator's Accept,
|
||||||
-- the topic has made the link official and sent a direct-grant
|
-- the topic has made the link official and sent a direct-grant
|
||||||
-- Create: Upon being created, topic has sent its creator an admin-Grant
|
-- Create: Upon being created, topic has sent its creator an admin-Grant
|
||||||
|
-- Factory: A factory that became active sent me a Grant (usually because I've
|
||||||
|
-- just created a new account)
|
||||||
|
|
||||||
PermitTopicEnableLocal
|
PermitTopicEnableLocal
|
||||||
permit PermitPersonGestureId
|
permit PermitPersonGestureId
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue