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