Port deck creation to the new actor system
This commit is contained in:
Pere Lev
parent
0bd2ca8d5d
commit
cc87b6e17d
7 changed files with 353 additions and 248 deletions
|
|
@ -25,7 +25,6 @@ module Vervis.API
|
|||
, createNoteC
|
||||
, createPatchTrackerC
|
||||
, createRepositoryC
|
||||
, createTicketTrackerC
|
||||
, followC
|
||||
, offerTicketC
|
||||
--, offerDepC
|
||||
|
|
@ -1510,247 +1509,6 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
|||
hook
|
||||
(renderAuthority host)
|
||||
|
||||
createTicketTrackerC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe
|
||||
(Either
|
||||
(LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
|
||||
FedURI
|
||||
)
|
||||
-> RecipientRoutes
|
||||
-> [(Host, NonEmpty LocalURI)]
|
||||
-> [Host]
|
||||
-> AP.Action URIMode
|
||||
-> AP.ActorDetail
|
||||
-> Maybe (Host, AP.ActorLocal URIMode)
|
||||
-> Maybe FedURI
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips remoteRecips fwdHosts action tracker mlocal muTarget = do
|
||||
|
||||
-- Check input
|
||||
verifyNothingE maybeCap "Capability not needed"
|
||||
verifyNothingE mlocal "'id' not allowed in new TicketTracker to create"
|
||||
(name, msummary) <- parseTracker tracker
|
||||
senderHash <- encodeKeyHashid pidUser
|
||||
now <- liftIO getCurrentTime
|
||||
verifyNothingE muTarget "'target' not supported in Create TicketTracker"
|
||||
|
||||
(deckID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
|
||||
|
||||
-- Insert new deck to DB
|
||||
obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
wid <- findWorkflow
|
||||
(jid, obidDeck, ibidDeck, aidDeck, fsidDeck) <- lift $ insertDeck now name msummary obiidCreate wid
|
||||
|
||||
-- Insert the Create activity to author's outbox
|
||||
deckHash <- encodeKeyHashid jid
|
||||
actionCreate <- prepareCreate name msummary deckHash
|
||||
_luCreate <- lift $ updateOutboxItem (LocalActorPerson pidUser) obiidCreate actionCreate
|
||||
|
||||
-- Deliver the Create activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
deliverHttpCreate <- do
|
||||
let sieve =
|
||||
makeRecipientSet [] [LocalStagePersonFollowers senderHash]
|
||||
localRecipsFinal = localRecipSieve sieve False localRecips
|
||||
deliverActivityDB
|
||||
(LocalActorPerson senderHash) (personActor personUser)
|
||||
localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate
|
||||
|
||||
-- Insert collaboration access for deck's creator
|
||||
obiidGrant <- lift $ insertEmptyOutboxItem obidDeck now
|
||||
lift $ insertCollab jid obiidGrant
|
||||
|
||||
-- Insert a Grant activity to deck's outbox
|
||||
let grantRecipActors = [LocalActorPerson senderHash]
|
||||
grantRecipStages = [LocalStagePersonFollowers senderHash]
|
||||
actionGrant <- prepareGrant senderHash deckHash obiidCreate grantRecipActors grantRecipStages
|
||||
_luGrant <- lift $ updateOutboxItem (LocalActorDeck jid) obiidGrant actionGrant
|
||||
|
||||
-- Deliver the Grant activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
deliverHttpGrant <- do
|
||||
let localRecipsGrant =
|
||||
makeRecipientSet grantRecipActors grantRecipStages
|
||||
deliverActivityDB
|
||||
(LocalActorDeck deckHash) aidDeck localRecipsGrant [] []
|
||||
obiidGrant actionGrant
|
||||
|
||||
-- Insert follow record
|
||||
obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
obiidAccept <- lift $ insertEmptyOutboxItem obidDeck now
|
||||
lift $ insert_ $ Follow (personActor personUser) fsidDeck True obiidFollow obiidAccept
|
||||
|
||||
-- Insert a Follow activity to sender's outbox, and an Accept to the
|
||||
-- deck's outbox
|
||||
luFollow <- lift $ insertFollowToOutbox senderHash deckHash obiidFollow
|
||||
lift $ insertAcceptToOutbox senderHash deckHash obiidAccept luFollow
|
||||
|
||||
-- Deliver the Follow and Accept by simply manually inserting them to
|
||||
-- deck and sender inboxes respectively
|
||||
lift $ do
|
||||
ibiidF <- insert $ InboxItem False now
|
||||
insert_ $ InboxItemLocal ibidDeck obiidFollow ibiidF
|
||||
ibiidA <- insert $ InboxItem False now
|
||||
insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return (jid, obiidCreate, deliverHttpCreate, deliverHttpGrant)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of Create and Grant
|
||||
lift $ do
|
||||
forkWorker "createTicketTrackerC: async HTTP Create delivery" deliverHttpCreate
|
||||
forkWorker "createTicketTrackerC: async HTTP Grant delivery" deliverHttpGrant
|
||||
|
||||
-- Spawn new Deck actor
|
||||
success <- do
|
||||
theater <- asksSite appTheater
|
||||
env <- asksSite appEnv
|
||||
liftIO $ launchActorIO theater env LocalActorDeck deckID
|
||||
unless success $
|
||||
error "Failed to spawn new Deck, somehow ID already in Theater"
|
||||
|
||||
return obiid
|
||||
where
|
||||
parseTracker (AP.ActorDetail typ muser mname msummary) = do
|
||||
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"
|
||||
return (name, msummary)
|
||||
|
||||
findWorkflow = do
|
||||
mw <- lift $ selectFirst ([] :: [Filter Workflow]) []
|
||||
entityKey <$> fromMaybeE mw "Can't find a workflow"
|
||||
|
||||
insertDeck now name msummary obiidCreate wid = do
|
||||
ibid <- insert Inbox
|
||||
obid <- insert Outbox
|
||||
fsid <- insert FollowerSet
|
||||
aid <- insert Actor
|
||||
{ actorName = name
|
||||
, actorDesc = fromMaybe "" msummary
|
||||
, actorCreatedAt = now
|
||||
, actorInbox = ibid
|
||||
, actorOutbox = obid
|
||||
, actorFollowers = fsid
|
||||
, actorJustCreatedBy = Just $ personActor personUser
|
||||
}
|
||||
did <- insert Deck
|
||||
{ deckActor = aid
|
||||
, deckWorkflow = wid
|
||||
, deckNextTicket = 1
|
||||
, deckWiki = Nothing
|
||||
, deckCreate = obiidCreate
|
||||
}
|
||||
return (did, obid, ibid, aid, fsid)
|
||||
|
||||
prepareCreate name msummary deckHash = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
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 = CreateActivity Create
|
||||
{ createObject = CreateTicketTracker ttdetail (Just (hLocal, ttlocal))
|
||||
, createTarget = Nothing
|
||||
}
|
||||
return action { actionSpecific = specific }
|
||||
|
||||
insertCollab did obiidGrant = do
|
||||
cid <- insert $ Collab RoleAdmin
|
||||
insert_ $ CollabTopicDeck cid did
|
||||
insert_ $ CollabEnable cid obiidGrant
|
||||
insert_ $ CollabRecipLocal cid pidUser
|
||||
insert_ $ CollabFulfillsLocalTopicCreation cid
|
||||
|
||||
prepareGrant adminHash deckHash obiidCreate actors stages = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
obikhidCreate <- encodeKeyHashid obiidCreate
|
||||
let recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalStage stages
|
||||
return Action
|
||||
{ actionCapability = Nothing
|
||||
, actionSummary = Nothing
|
||||
, actionAudience = Audience recips [] [] [] [] []
|
||||
, actionFulfills =
|
||||
[encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
|
||||
, actionSpecific = GrantActivity Grant
|
||||
{ grantObject = RoleAdmin
|
||||
, grantContext = encodeRouteLocal $ DeckR deckHash
|
||||
, grantTarget = encodeRouteHome $ PersonR adminHash
|
||||
, grantResult = Nothing
|
||||
, grantStart = Nothing
|
||||
, grantEnd = Nothing
|
||||
, grantAllows = Invoke
|
||||
, grantDelegates = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
insertFollowToOutbox senderHash deckHash obiidFollow = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
obikhid <- encodeKeyHashid obiidFollow
|
||||
let luFollow = encodeRouteLocal $ PersonOutboxItemR senderHash obikhid
|
||||
recips = [encodeRouteHome $ DeckR deckHash]
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just luFollow
|
||||
, activityActor = encodeRouteLocal $ PersonR senderHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = AP.Audience recips [] [] [] [] []
|
||||
, activityFulfills = []
|
||||
, activityProof = Nothing
|
||||
, activitySpecific = FollowActivity AP.Follow
|
||||
{ AP.followObject = encodeRouteHome $ DeckR deckHash
|
||||
, AP.followContext = Nothing
|
||||
, AP.followHide = False
|
||||
}
|
||||
}
|
||||
update obiidFollow [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return luFollow
|
||||
|
||||
insertAcceptToOutbox senderHash deckHash obiidAccept luFollow = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
obikhid <- encodeKeyHashid obiidAccept
|
||||
|
||||
let recips = [encodeRouteHome $ PersonR senderHash]
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just $ encodeRouteLocal $ DeckOutboxItemR deckHash obikhid
|
||||
, activityActor = encodeRouteLocal $ DeckR deckHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activityFulfills = []
|
||||
, activityProof = Nothing
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luFollow
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
|
||||
followC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ module Vervis.Actor.Common
|
|||
, topicInvite
|
||||
, topicRemove
|
||||
, topicJoin
|
||||
, topicCreateMe
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1137,3 +1138,113 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
|
|||
let authorID = remoteAuthorId author
|
||||
recipID <- insert $ CollabRecipRemote collabID authorID
|
||||
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
|
||||
|
||||
topicCreateMe
|
||||
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
|
||||
, PersistRecordBackend ct SqlBackend
|
||||
)
|
||||
=> (topic -> ActorId)
|
||||
-> (forall f. f topic -> GrantResourceBy f)
|
||||
-> EntityField ct (Key topic)
|
||||
-> (CollabId -> Key topic -> ct)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now recipKey (Verse authorIdMsig body) = do
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = topicActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- 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?"
|
||||
creatorPersonID <- do
|
||||
mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID
|
||||
fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently"
|
||||
existingCollabIDs <-
|
||||
lift $ selectList [collabTopicFieldTopic ==. recipKey] []
|
||||
unless (null existingCollabIDs) $
|
||||
error "Just-been-created but I somehow already have Collabs"
|
||||
|
||||
-- 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
|
||||
lift $ for maybeCreateDB $ \ _createDB -> do
|
||||
|
||||
-- Create a Collab record and exit just-been-created state
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insertCollab creatorPersonID grantID
|
||||
update creatorActorID [ActorJustCreatedBy =. Nothing]
|
||||
|
||||
-- Prepare a Grant activity and insert to my outbox
|
||||
grant@(actionGrant, _, _, _) <- lift prepareGrant
|
||||
let recipByKey = grantResourceLocalActor $ topicResource recipKey
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
|
||||
return (recipActorID, grantID, grant)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
|
||||
let recipByID = grantResourceLocalActor $ topicResource recipKey
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "Created a Collab record and published a Grant"
|
||||
|
||||
where
|
||||
|
||||
insertCollab personID grantID = do
|
||||
collabID <- insert $ Collab AP.RoleAdmin
|
||||
insert_ $ collabTopicCtor collabID recipKey
|
||||
insert_ $ CollabEnable collabID grantID
|
||||
insert_ $ CollabRecipLocal collabID personID
|
||||
insert_ $ CollabFulfillsLocalTopicCreation collabID
|
||||
|
||||
prepareGrant = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
audCreator <- makeAudSenderOnly authorIdMsig
|
||||
recipHash <- encodeKeyHashid recipKey
|
||||
uCreator <- getActorURI authorIdMsig
|
||||
uCreate <- getActivityURI authorIdMsig
|
||||
let topicByHash = grantResourceLocalActor $ topicResource recipHash
|
||||
audience =
|
||||
let audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audCreator, 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.RoleAdmin
|
||||
, AP.grantContext =
|
||||
encodeRouteLocal $ renderLocalActor topicByHash
|
||||
, 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)
|
||||
|
|
|
|||
|
|
@ -63,13 +63,51 @@ import Vervis.Data.Discussion
|
|||
import Vervis.FedURI
|
||||
import Vervis.Federation.Util
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model hiding (deckCreate)
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.Ticket
|
||||
|
||||
-- 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
|
||||
deckActor GrantResourceDeck CollabTopicDeckDeck CollabTopicDeck
|
||||
|
||||
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"
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Following
|
||||
------------------------------------------------------------------------------
|
||||
|
|
@ -433,6 +471,7 @@ deckBehavior :: UTCTime -> DeckId -> VerseExt -> ActE (Text, Act (), Next)
|
|||
deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
AP.AcceptActivity accept -> deckAccept now deckID verse accept
|
||||
AP.CreateActivity create -> deckCreate now deckID verse create
|
||||
AP.FollowActivity follow -> deckFollow now deckID verse follow
|
||||
AP.InviteActivity invite -> deckInvite now deckID verse invite
|
||||
AP.JoinActivity join -> deckJoin now deckID verse join
|
||||
|
|
|
|||
|
|
@ -273,6 +273,18 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
|||
unless (authorByKey == targetByKey) $
|
||||
lift $ throwE "You're Accepting a Follow I sent to someone else"
|
||||
lift $ lift $ delete key
|
||||
-- The followee already inserted a Follow, so we just make sure it
|
||||
-- already exists
|
||||
followKey <- do
|
||||
mf <- lift $ lift $ getKeyBy $ UniqueFollowAccept acceptID
|
||||
lift $ fromMaybeE mf "Can't find a Follow record in DB"
|
||||
mf1 <-
|
||||
lift $ lift $ getKeyBy $ UniqueFollow actorID (followRequestTarget val)
|
||||
mf2 <-
|
||||
lift $ lift $ getKeyBy $ UniqueFollowFollow outboxItemID
|
||||
unless (mf1 == Just followKey && mf2 == Just followKey) $
|
||||
lift $ throwE "Weird inconsistency with Follow uniques"
|
||||
{-
|
||||
lift $ lift $ insert_ Follow
|
||||
{ followActor = actorID
|
||||
, followTarget = followRequestTarget val
|
||||
|
|
@ -280,6 +292,7 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
|||
, followFollow = outboxItemID
|
||||
, followAccept = acceptID
|
||||
}
|
||||
-}
|
||||
tryFollow _ (Right _) _ = mzero
|
||||
|
||||
-- Meaning: An actor rejected something
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@ import Vervis.Access
|
|||
import Vervis.ActivityPub
|
||||
import Vervis.Actor
|
||||
import Vervis.Actor2
|
||||
import Vervis.Actor.Deck
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
|
|
@ -108,6 +109,187 @@ verifyRemoteAddressed remoteRecips u =
|
|||
lus <- lookup h remoteRecips
|
||||
guard $ lu `elem` lus
|
||||
|
||||
-- Meaning: The human wants to create a ticket tracker
|
||||
-- Behavior:
|
||||
-- * Create a deck on DB
|
||||
-- * Launch a deck actor
|
||||
-- * Record a FollowRequest in DB
|
||||
-- * Create and send Create and Follow to it
|
||||
clientCreateDeck
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> ClientMsg
|
||||
-> AP.ActorDetail
|
||||
-> ActE OutboxItemId
|
||||
clientCreateDeck 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, deckID) <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(personMe, actorMe) <- lift $ do
|
||||
p <- getJust personMeID
|
||||
(p,) <$> getJust (personActor p)
|
||||
let actorMeID = personActor personMe
|
||||
|
||||
-- Insert new deck to DB
|
||||
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||
wid <- findWorkflow
|
||||
(deckID, deckFollowerSetID) <-
|
||||
lift $ insertDeck now name msummary createID wid actorMeID
|
||||
|
||||
-- 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 LocalActorDeck deckID
|
||||
unless success $
|
||||
error "Failed to spawn new Deck, 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.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"
|
||||
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
|
||||
ibid <- insert Inbox
|
||||
obid <- insert Outbox
|
||||
fsid <- insert FollowerSet
|
||||
aid <- insert Actor
|
||||
{ actorName = name
|
||||
, actorDesc = fromMaybe "" msummary
|
||||
, actorCreatedAt = now
|
||||
, actorInbox = ibid
|
||||
, actorOutbox = obid
|
||||
, actorFollowers = fsid
|
||||
, actorJustCreatedBy = Just actorMeID
|
||||
}
|
||||
did <- insert Deck
|
||||
{ deckActor = aid
|
||||
, deckWorkflow = wid
|
||||
, deckNextTicket = 1
|
||||
, deckWiki = Nothing
|
||||
, deckCreate = obiidCreate
|
||||
}
|
||||
return (did, fsid)
|
||||
|
||||
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)
|
||||
|
||||
clientCreate
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> ClientMsg
|
||||
-> AP.Create URIMode
|
||||
-> ActE OutboxItemId
|
||||
clientCreate now personMeID msg (AP.Create object muTarget) =
|
||||
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
|
||||
|
||||
_ -> throwE "Unsupported Create object for C2S"
|
||||
|
||||
-- Meaning: The human wants to invite someone A to a resource R
|
||||
-- Behavior:
|
||||
-- * Some basic sanity checks
|
||||
|
|
@ -334,6 +516,7 @@ clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next)
|
|||
clientBehavior now personID msg =
|
||||
done . T.pack . show =<<
|
||||
case AP.actionSpecific $ cmAction msg of
|
||||
AP.CreateActivity create -> clientCreate now personID msg create
|
||||
AP.InviteActivity invite -> clientInvite now personID msg invite
|
||||
AP.RemoveActivity remove -> clientRemove now personID msg remove
|
||||
_ -> throwE "Unsupported activity type for C2S"
|
||||
|
|
|
|||
|
|
@ -340,9 +340,9 @@ postDeckNewR = do
|
|||
(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
|
||||
actor <- runDB $ getJust $ personActor person
|
||||
result <-
|
||||
runExceptT $ createTicketTrackerC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail Nothing Nothing
|
||||
runExceptT $
|
||||
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
|
|
|
|||
|
|
@ -228,13 +228,14 @@ postPersonOutboxR personHash = do
|
|||
case obj of
|
||||
AP.CreateNote _ note ->
|
||||
run createNoteC note mtarget
|
||||
AP.CreateTicketTracker detail mlocal ->
|
||||
run createTicketTrackerC detail mlocal mtarget
|
||||
AP.CreateRepository detail vcs mlocal ->
|
||||
run createRepositoryC detail vcs mlocal mtarget
|
||||
AP.CreatePatchTracker detail repos mlocal ->
|
||||
run createPatchTrackerC detail repos mlocal mtarget
|
||||
_ -> throwE "Unsupported Create 'object' type"
|
||||
_ ->
|
||||
handleViaActor
|
||||
(entityKey eperson) maybeCap localRecips remoteRecips
|
||||
fwdHosts action
|
||||
{-
|
||||
AddActivity (AP.Add obj target) ->
|
||||
case obj of
|
||||
|
|
|
|||
Loading…
Reference in a new issue