C2S: Re-implement and enable resolveC, followC, undoC
This commit is contained in:
fr33domlover
parent
fa7f765e2e
commit
8f8354ea5e
18 changed files with 946 additions and 563 deletions
|
|
@ -25,12 +25,12 @@ module Vervis.API
|
|||
, createPatchTrackerC
|
||||
, createRepositoryC
|
||||
, createTicketTrackerC
|
||||
--, followC
|
||||
, followC
|
||||
, inviteC
|
||||
, offerTicketC
|
||||
--, offerDepC
|
||||
--, resolveC
|
||||
--, undoC
|
||||
, resolveC
|
||||
, undoC
|
||||
--, pushCommitsC
|
||||
)
|
||||
where
|
||||
|
|
@ -102,6 +102,7 @@ import Vervis.Darcs
|
|||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Data.Discussion
|
||||
import Vervis.Data.Follow
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Fetch
|
||||
|
|
@ -116,13 +117,13 @@ import Vervis.Path
|
|||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.Persist.Follow
|
||||
import Vervis.Persist.Ticket
|
||||
import Vervis.Recipient
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
import Vervis.Query
|
||||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.Web.Repo
|
||||
|
||||
|
|
@ -1666,16 +1667,6 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
|
|||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
|
||||
{-
|
||||
data Followee
|
||||
= FolloweePerson (KeyHashid Person)
|
||||
| FolloweeGroup (KeyHashid Group)
|
||||
| FolloweeRepo (KeyHashid Repo)
|
||||
| FolloweeDeck (KeyHashid Deck)
|
||||
| FolloweeLoom (KeyHashid Loom)
|
||||
| FolloweeTicket (KeyHashid Deck) (KeyHashid TicketDeck)
|
||||
| FolloweeCloth (KeyHashid Loom) (KeyHashid TicketLoom)
|
||||
|
||||
followC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
|
|
@ -1690,158 +1681,130 @@ followC
|
|||
-> AP.Action URIMode
|
||||
-> AP.Follow URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
followC (Entity pidSender personSender) _senderActor maybeCap localRecips remoteRecips fwdHosts action follow@(AP.Follow uObject muContext hide) = do
|
||||
followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action follow = do
|
||||
|
||||
-- Check input
|
||||
verifyNothingE maybeCap "Capability not needed"
|
||||
(followee, hide) <- parseFollow follow
|
||||
case followee of
|
||||
Left (FolloweeActor (LocalActorPerson personID))
|
||||
| personID == senderPersonID ->
|
||||
throwE "Trying to follow yourself"
|
||||
_ -> pure ()
|
||||
|
||||
-- Verify that followee's actor is addressed
|
||||
case followee of
|
||||
Left f -> do
|
||||
actorByHash <- hashLocalActor $ followeeActor f
|
||||
unless (actorIsAddressed localRecips actorByHash) $
|
||||
throwE "Followee's actor not addressed by the Follow"
|
||||
Right (h, luActor, luObject) ->
|
||||
verifyRemoteAddressed remoteRecips $ ObjURI h luActor
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
senderHash <- encodeKeyHashid pidSender
|
||||
mfollowee <- do
|
||||
let ObjURI h luObject = uObject
|
||||
local <- hostIsLocal h
|
||||
if local
|
||||
then Just <$> do
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal luObject)
|
||||
"Follow object isn't a valid route"
|
||||
followee <-
|
||||
fromMaybeE
|
||||
(parseFollowee route)
|
||||
"Follow object isn't a followee route"
|
||||
let actor = followeeActor followee
|
||||
unless (actorRecips actor == localRecips) $
|
||||
throwE "Follow object isn't the recipient"
|
||||
case followee of
|
||||
FolloweePerson p | p == senderHash ->
|
||||
throwE "User trying to follow themselves"
|
||||
_ -> return ()
|
||||
return (followee, actor)
|
||||
else do
|
||||
unless (localRecips == RecipientRoutes [] [] [] [] []) $
|
||||
throwE "Follow object is remote but local recips listed"
|
||||
return Nothing
|
||||
(obiidFollow, doc, remotesHttp) <- runDBExcept $ do
|
||||
let actorSenderID = personActor personSender
|
||||
actorSender <- lift $ getJust actorSenderID
|
||||
let ibidSender = actorInbox actorSender
|
||||
obidSender = actorOutbox actorSender
|
||||
obiidFollow <- lift $ insertEmptyOutboxItem obidSender now
|
||||
luFollow <- lift $ updateOutboxItem (LocalActorPerson pidSender) obiidFollow action
|
||||
case mfollowee of
|
||||
Nothing -> lift $ insert_ $ FollowRemoteRequest pidSender uObject muContext (not hide) obiidFollow
|
||||
Just (followee, actorRecip) -> do
|
||||
(actorRecipID, mfsid, unread) <- getFollowee followee
|
||||
actorRecipDB <- lift $ getJust actorRecipID
|
||||
let obidRecip = actorOutbox actorRecipDB
|
||||
obiidAccept <- lift $ insertAcceptToOutbox senderHash luFollow actorRecip obidRecip
|
||||
let ibidRecip = actorInbox actorRecipDB
|
||||
fsid = fromMaybe (actorFollowers actorRecipDB) mfsid
|
||||
deliverFollowLocal now actorSenderID fsid unread obiidFollow obiidAccept ibidRecip
|
||||
lift $ deliverAcceptLocal now obiidAccept ibidSender
|
||||
remotesHttp <- lift $ deliverRemoteDB fwdHosts obiidFollow remoteRecips []
|
||||
return (obiidFollow, doc, remotesHttp)
|
||||
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidFollow doc remotesHttp
|
||||
return obiidFollow
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
|
||||
(followID, deliverHttpFollow, maybeDeliverHttpAccept) <- runDBExcept $ do
|
||||
|
||||
-- If followee is local, find it in our DB
|
||||
followeeDB <- bitraverse getFollowee pure followee
|
||||
|
||||
-- Insert Follow activity to author's outbox
|
||||
followID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
luFollow <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) followID action
|
||||
|
||||
-- Deliver the Follow activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
deliverHttpFollow <- do
|
||||
sieve <- do
|
||||
(actors, stages) <-
|
||||
case followeeDB of
|
||||
Left (actorByKey, _, _) -> do
|
||||
actorByHash <- hashLocalActor actorByKey
|
||||
return
|
||||
( [actorByHash]
|
||||
, [localActorFollowers actorByHash]
|
||||
)
|
||||
Right _ -> pure ([], [])
|
||||
let stages' = LocalStagePersonFollowers senderHash : stages
|
||||
return $ makeRecipientSet actors stages'
|
||||
let localRecipsFinal = localRecipSieve sieve False localRecips
|
||||
deliverActivityDB
|
||||
(LocalActorPerson senderHash) (personActor senderPerson)
|
||||
localRecipsFinal remoteRecips fwdHosts followID action
|
||||
|
||||
maybeDeliverHttpAccept <-
|
||||
case followeeDB of
|
||||
Right (h, luActor, luObject) -> lift $ do
|
||||
|
||||
-- For remote followee, just remember the request in our DB
|
||||
let uObject = ObjURI h luObject
|
||||
muContext =
|
||||
if luActor == luObject
|
||||
then Nothing
|
||||
else Just $ ObjURI h luActor
|
||||
insert_ $ FollowRemoteRequest senderPersonID uObject muContext (not hide) followID
|
||||
return Nothing
|
||||
|
||||
Left (actorByKey, actorID, maybeFollowerSetID) -> Just <$> do
|
||||
|
||||
-- Verify followee's actor has received the Accept
|
||||
verifyActorHasItem actorID followID "Followee's actor didn't receive the Follow"
|
||||
|
||||
-- Insert an Accept activity to followee's outbox
|
||||
actor <- lift $ getJust actorID
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
|
||||
let acceptActors = [LocalActorPerson senderHash]
|
||||
acceptStages = []
|
||||
actionAccept <- prepareAccept luFollow acceptActors acceptStages
|
||||
_luAccept <- lift $ updateOutboxItem actorByKey acceptID actionAccept
|
||||
|
||||
-- Insert author to followee's followers collection
|
||||
let fsid =
|
||||
fromMaybe (actorFollowers actor) maybeFollowerSetID
|
||||
mfid <-
|
||||
lift $ insertUnique $
|
||||
Follow (personActor senderPerson) fsid (not hide) followID acceptID
|
||||
_ <- fromMaybeE mfid "Already following this object"
|
||||
|
||||
-- Deliver the Accept activity to local recipients, and
|
||||
-- schedule delivery for unavailable remote recipients
|
||||
let localRecipsAccept = makeRecipientSet acceptActors acceptStages
|
||||
actorByHash <- hashLocalActor actorByKey
|
||||
deliverActivityDB
|
||||
actorByHash actorID localRecipsAccept [] []
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return (followID, deliverHttpFollow, maybeDeliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of Follow and Accept
|
||||
lift $ do
|
||||
forkWorker "followC: async HTTP Follow delivery" deliverHttpFollow
|
||||
for_ maybeDeliverHttpAccept $
|
||||
forkWorker "followC: async HTTP Accept delivery"
|
||||
|
||||
return followID
|
||||
|
||||
where
|
||||
parseFollowee (PersonR p) = Just $ FolloweePerson p
|
||||
parseFollowee (GroupR g) = Just $ FolloweeGroup g
|
||||
parseFollowee (RepoR r) = Just $ FolloweeRepo r
|
||||
parseFollowee (DeckR d) = Just $ FolloweeDeck d
|
||||
parseFollowee (LoomR l) = Just $ FolloweeLoom l
|
||||
parseFollowee (TicketR d t) = Just $ FolloweeTicket d t
|
||||
parseFollowee (ClothR l c) = Just $ FolloweeCloth l c
|
||||
parseFollowee _ = Nothing
|
||||
|
||||
followeeActor (FolloweePerson p) = LocalActorPerson p
|
||||
followeeActor (FolloweeGroup g) = LocalActorGroup g
|
||||
followeeActor (FolloweeRepo r) = LocalActorRepo r
|
||||
followeeActor (FolloweeDeck d) = LocalActorDeck d
|
||||
followeeActor (FolloweeLoom l) = LocalActorLoom l
|
||||
followeeActor (FolloweeTicket d _) = LocalActorDeck d
|
||||
followeeActor (FolloweeCloth l _) = LocalActorLoom l
|
||||
|
||||
getFollowee (FolloweePerson personHash) = do
|
||||
personID <- decodeKeyHashidE personHash "Follow object: No such person hash"
|
||||
(,Nothing,True) . personActor <$> getE personID "Follow object: No such person in DB"
|
||||
getFollowee (FolloweeGroup groupHash) = do
|
||||
groupID <- decodeKeyHashidE groupHash "Follow object: No such group hash"
|
||||
(,Nothing,False) . groupActor <$> getE groupID "Follow object: No such group in DB"
|
||||
getFollowee (FolloweeRepo repoHash) = do
|
||||
repoID <- decodeKeyHashidE repoHash "Follow object: No such repo hash"
|
||||
(,Nothing,False) . repoActor <$> getE repoID "Follow object: No such repo in DB"
|
||||
getFollowee (FolloweeDeck deckHash) = do
|
||||
deckID <- decodeKeyHashidE deckHash "Follow object: No such deck hash"
|
||||
(,Nothing,False) . deckActor <$> getE deckID "Follow object: No such deck in DB"
|
||||
getFollowee (FolloweeLoom loomHash) = do
|
||||
loomID <- decodeKeyHashidE loomHash "Follow object: No such loom hash"
|
||||
(,Nothing,False) . loomActor <$> getE loomID "Follow object: No such loom in DB"
|
||||
getFollowee (FolloweeTicket deckHash ticketHash) = do
|
||||
deckID <- decodeKeyHashidE deckHash "Follow object: No such deck hash"
|
||||
actor <- deckActor <$> getE deckID "Follow object: No such deck in DB"
|
||||
ticketID <- decodeKeyHashidE ticketHash "Follow object: No such ticket hash"
|
||||
(_, _, Entity _ ticket, _, _) <- do
|
||||
mticket <- lift $ getTicket deckID ticketID
|
||||
fromMaybeE mticket "Follow object: No such ticket in DB"
|
||||
return (actor, Just $ ticketFollowers ticket, False)
|
||||
getFollowee (FolloweeCloth loomHash clothHash) = do
|
||||
loomID <- decodeKeyHashidE loomHash "Follow object: No such loom hash"
|
||||
actor <- loomActor <$> getE loomID "Follow object: No such loom in DB"
|
||||
clothID <- decodeKeyHashidE clothHash "Follow object: No such cloth hash"
|
||||
(_, _, Entity _ ticket, _, _, _) <- do
|
||||
mticket <- lift $ getCloth loomID clothID
|
||||
fromMaybeE mticket "Follow object: No such cloth in DB"
|
||||
return (actor, Just $ ticketFollowers ticket, False)
|
||||
|
||||
insertAcceptToOutbox senderHash luFollow actorRecip obidRecip = do
|
||||
now <- liftIO getCurrentTime
|
||||
summary <-
|
||||
renderHTML <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
<a href=@{PersonR senderHash}>
|
||||
#{username2text $ personUsername personSender}
|
||||
's follow request accepted by #
|
||||
<a href=#{renderObjURI uObject}>
|
||||
#{localUriPath $ objUriLocal uObject}
|
||||
|]
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
prepareAccept luFollow actors stages = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let recips = [encodeRouteHome $ PersonR senderHash]
|
||||
accept mluAct = Doc hLocal Activity
|
||||
{ activityId = mluAct
|
||||
, activityActor = objUriLocal uObject
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Just summary
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activityFulfills = []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luFollow
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
let recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalStage stages
|
||||
return AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hLocal luFollow
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
obiid <- insert OutboxItem
|
||||
{ outboxItemOutbox = obidRecip
|
||||
, outboxItemActivity =
|
||||
persistJSONObjectFromDoc $ accept Nothing
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ actorOutboxItem actorRecip obikhid
|
||||
doc = accept $ Just luAct
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return obiid
|
||||
|
||||
deliverFollowLocal now aidSender fsid unread obiidF obiidA ibidRecip = do
|
||||
mfid <- lift $ insertUnique $ Follow aidSender fsid (not hide) obiidF obiidA
|
||||
_ <- fromMaybeE mfid "Already following this object"
|
||||
ibiid <- lift $ insert $ InboxItem unread now
|
||||
lift $ insert_ $ InboxItemLocal ibidRecip obiidF ibiid
|
||||
|
||||
deliverAcceptLocal now obiidAccept ibidAuthor = do
|
||||
ibiid <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
|
||||
-}
|
||||
|
||||
inviteC
|
||||
:: Entity Person
|
||||
|
|
@ -2042,13 +2005,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
routes <- lookup p $ recipPeople localRecips
|
||||
guard $ routePerson routes
|
||||
|
||||
verifyRemoteAddressed remoteRecips u =
|
||||
fromMaybeE (verify u) "Given remote entity not addressed"
|
||||
where
|
||||
verify (ObjURI h lu) = do
|
||||
lus <- lookup h remoteRecips
|
||||
guard $ lu `elem` lus
|
||||
|
||||
insertCollab resource recipient inviteID = do
|
||||
collabID <- insert Collab
|
||||
case resource of
|
||||
|
|
@ -2740,279 +2696,377 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve
|
|||
|
||||
resolveC
|
||||
:: Entity Person
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Resolve URIMode
|
||||
-> Actor
|
||||
-> Maybe
|
||||
(Either
|
||||
(LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
|
||||
FedURI
|
||||
)
|
||||
-> RecipientRoutes
|
||||
-> [(Host, NonEmpty LocalURI)]
|
||||
-> [Host]
|
||||
-> AP.Action URIMode
|
||||
-> AP.Resolve URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
resolveC (Entity pidUser personUser) summary audience (Resolve uObject) = do
|
||||
error "resolveC temporarily disabled"
|
||||
resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Resolve uObject) = do
|
||||
|
||||
{-
|
||||
-- Check input
|
||||
maybeLocalWorkItem <-
|
||||
nameExceptT "Resolve object" $ either Just (const Nothing) <$> do
|
||||
routeOrRemote <- parseFedURI uObject
|
||||
bitraverse
|
||||
(\ r -> do
|
||||
wiByHash <-
|
||||
fromMaybeE (parseWorkItem r) "Not a work item route"
|
||||
unhashWorkItemE wiByHash "Work item invalid keyhashid"
|
||||
)
|
||||
pure
|
||||
routeOrRemote
|
||||
capID <- fromMaybeE maybeCap "No capability provided"
|
||||
|
||||
-- Verify that the work item's tracker is addressed
|
||||
for_ maybeLocalWorkItem $ \ wi -> do
|
||||
trackerByHash <- hashLocalActor $ workItemActor wi
|
||||
unless (actorIsAddressed localRecips trackerByHash) $
|
||||
throwE "Work item's tracker not addressed by the Resolve"
|
||||
|
||||
let shrUser = sharerIdent sharerUser
|
||||
object <- parseWorkItem "Resolve object" uObject
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Offer Ticket with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients specified"
|
||||
verifyHosterRecip localRecips "Parent" object
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
now <- liftIO getCurrentTime
|
||||
ticketDetail <- runWorkerExcept $ getWorkItemDetail "Object" object
|
||||
(obiid, doc, remotesHttp, maybeAccept) <- runDBExcept $ do
|
||||
(obiidResolve, docResolve, luResolve) <- lift $ insertResolveToOutbox shrUser now (personOutbox personUser) blinded
|
||||
remotesHttpResolve <- do
|
||||
wiFollowers <- askWorkItemFollowers
|
||||
let sieve =
|
||||
let (actors, colls) =
|
||||
workItemRecipSieve wiFollowers ticketDetail
|
||||
in makeRecipientSet
|
||||
actors
|
||||
(LocalPersonCollectionSharerFollowers shrUser :
|
||||
colls
|
||||
)
|
||||
moreRemoteRecips <-
|
||||
lift $
|
||||
deliverLocal'
|
||||
True
|
||||
(LocalActorSharer shrUser)
|
||||
(personInbox personUser)
|
||||
obiidResolve
|
||||
(localRecipSieve sieve False localRecips)
|
||||
unless (federation || null moreRemoteRecips) $
|
||||
throwE "Federation disabled, but recipient collection remote members found"
|
||||
lift $ deliverRemoteDB fwdHosts obiidResolve remoteRecips moreRemoteRecips
|
||||
maccept <-
|
||||
case widIdent ticketDetail of
|
||||
Right _ -> return Nothing
|
||||
Left (wi, ltid) -> Just <$> do
|
||||
mhoster <-
|
||||
lift $ runMaybeT $
|
||||
case wi of
|
||||
WorkItemSharerTicket shr _ _ -> do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
p <- MaybeT (getValBy $ UniquePersonIdent sid)
|
||||
return (personOutbox p, personInbox p)
|
||||
WorkItemProjectTicket shr prj _ -> do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
j <- MaybeT $ getValBy $ UniqueProject prj sid
|
||||
a <- lift $ getJust $ projectActor j
|
||||
return (actorOutbox a, actorInbox a)
|
||||
WorkItemRepoProposal shr rp _ -> do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
r <- MaybeT (getValBy $ UniqueRepo rp sid)
|
||||
return (repoOutbox r, repoInbox r)
|
||||
(obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB"
|
||||
obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now
|
||||
lift $ insertResolve ltid obiidResolve obiidAccept
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift $ insertAcceptOnTicketStatus shrUser wi ticketDetail obiidResolve obiidAccept
|
||||
knownRemoteRecipsAccept <-
|
||||
lift $
|
||||
deliverLocal'
|
||||
False
|
||||
(workItemActor wi)
|
||||
ibidHoster
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (obiidResolve, docResolve, remotesHttpResolve, maccept)
|
||||
lift $ do
|
||||
forkWorker "resolveC: async HTTP Resolve delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp
|
||||
for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) ->
|
||||
forkWorker "resolveC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept
|
||||
return obiid
|
||||
where
|
||||
insertResolveToOutbox shrUser now obid blinded = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just luAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = ResolveActivity $ Resolve uObject
|
||||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
|
||||
insertResolve ltid obiidResolve obiidAccept = do
|
||||
(resolveID, deliverHttpResolve, maybeDeliverHttpAccept) <- runDBExcept $ do
|
||||
|
||||
workItemDB <- for maybeLocalWorkItem $ \ wi -> do
|
||||
|
||||
-- Find the work item and its tracker in DB, and verify the work
|
||||
-- item isn't already resolved
|
||||
(resource, actor, ticketID) <-
|
||||
case wi of
|
||||
WorkItemTicket deckID taskID -> do
|
||||
maybeTicket <- lift $ getTicket deckID taskID
|
||||
(Entity _ deck, _task, Entity ticketID _, _author, resolve) <-
|
||||
fromMaybeE maybeTicket "No such ticket in DB"
|
||||
verifyNothingE resolve "Ticket already resolved"
|
||||
actor <- lift $ getJustEntity $ deckActor deck
|
||||
return (GrantResourceDeck deckID, actor, ticketID)
|
||||
WorkItemCloth loomID clothID -> do
|
||||
maybeCloth <- lift $ getCloth loomID clothID
|
||||
(Entity _ loom, _cloth, Entity ticketID _, _author, resolve, _merge) <-
|
||||
fromMaybeE maybeCloth "No such MR in DB"
|
||||
verifyNothingE resolve "MR already resolved"
|
||||
actor <- lift $ getJustEntity $ loomActor loom
|
||||
return (GrantResourceLoom loomID, actor, ticketID)
|
||||
|
||||
-- Verify the sender is authorized by the tracker to resolve work
|
||||
-- items
|
||||
capability <-
|
||||
case capID of
|
||||
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
|
||||
verifyCapability capability (Left senderPersonID) resource
|
||||
|
||||
return (wi, actor, ticketID)
|
||||
|
||||
-- Insert Resolve to sender's outbox
|
||||
resolveID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
luResolve <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) resolveID action
|
||||
|
||||
-- Deliver the Resolve activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
deliverHttpResolve <- do
|
||||
sieve <- do
|
||||
(actors, stages) <-
|
||||
case maybeLocalWorkItem of
|
||||
Nothing -> pure ([], [])
|
||||
Just (WorkItemTicket deckID taskID) -> do
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
return
|
||||
( [LocalActorDeck deckHash]
|
||||
, [ LocalStageDeckFollowers deckHash
|
||||
, LocalStageTicketFollowers deckHash taskHash
|
||||
]
|
||||
)
|
||||
Just (WorkItemCloth loomID clothID) -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
return
|
||||
( [LocalActorLoom loomHash]
|
||||
, [ LocalStageLoomFollowers loomHash
|
||||
, LocalStageClothFollowers loomHash clothHash
|
||||
]
|
||||
)
|
||||
let stages' = LocalStagePersonFollowers senderHash : stages
|
||||
return $ makeRecipientSet actors stages'
|
||||
let localRecipsFinal = localRecipSieve sieve False localRecips
|
||||
deliverActivityDB
|
||||
(LocalActorPerson senderHash) (personActor senderPerson)
|
||||
localRecipsFinal remoteRecips fwdHosts resolveID action
|
||||
|
||||
-- Verify that the tracker has received the Resolve, resolve the work
|
||||
-- item in DB, and publish Accept
|
||||
maybeDeliverHttpAccept <- for workItemDB $ \ (wi, Entity trackerActorID trackerActor, ticketID) -> do
|
||||
|
||||
-- Verify tracker received the Resolve
|
||||
verifyActorHasItem
|
||||
trackerActorID
|
||||
resolveID
|
||||
"Local tracker didn't receive the Resolve"
|
||||
|
||||
-- Mark work item in DB as resolved by the Resolve
|
||||
acceptID <-
|
||||
lift $ insertEmptyOutboxItem (actorOutbox trackerActor) now
|
||||
lift $ insertResolve ticketID resolveID acceptID
|
||||
|
||||
-- Insert an Accept activity to tracker's outbox
|
||||
trackerStages <-
|
||||
case wi of
|
||||
WorkItemTicket deckID taskID -> do
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
return
|
||||
[ LocalStageDeckFollowers deckHash
|
||||
, LocalStageTicketFollowers deckHash taskHash
|
||||
]
|
||||
WorkItemCloth loomID clothID -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
return
|
||||
[ LocalStageLoomFollowers loomHash
|
||||
, LocalStageClothFollowers loomHash clothHash
|
||||
]
|
||||
let acceptActors = [LocalActorPerson senderHash]
|
||||
acceptStages =
|
||||
LocalStagePersonFollowers senderHash : trackerStages
|
||||
actionAccept <- prepareAccept luResolve acceptActors acceptStages
|
||||
let trackerByKey = workItemActor wi
|
||||
_ <- lift $ updateOutboxItem trackerByKey acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
let localRecipsAccept = makeRecipientSet acceptActors acceptStages
|
||||
trackerByHash <- hashLocalActor trackerByKey
|
||||
deliverActivityDB
|
||||
trackerByHash trackerActorID localRecipsAccept [] []
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP delivery of Resolve and Accept to
|
||||
-- remote recipients
|
||||
return
|
||||
( resolveID
|
||||
, deliverHttpResolve
|
||||
, maybeDeliverHttpAccept
|
||||
)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of Resolve and Accept
|
||||
lift $ do
|
||||
forkWorker "resolveC: async HTTP Resolve delivery" deliverHttpResolve
|
||||
for_ maybeDeliverHttpAccept $
|
||||
forkWorker "resolveC: async HTTP Accept delivery"
|
||||
|
||||
return resolveID
|
||||
|
||||
where
|
||||
|
||||
insertResolve ticketID resolveID acceptID = do
|
||||
trid <- insert TicketResolve
|
||||
{ ticketResolveTicket = ltid
|
||||
, ticketResolveAccept = obiidAccept
|
||||
{ ticketResolveTicket = ticketID
|
||||
, ticketResolveAccept = acceptID
|
||||
}
|
||||
insert_ TicketResolveLocal
|
||||
{ ticketResolveLocalTicket = trid
|
||||
, ticketResolveLocalActivity = obiidResolve
|
||||
, ticketResolveLocalActivity = resolveID
|
||||
}
|
||||
|
||||
prepareAccept luResolve actors stages = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
let recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalStage stages
|
||||
return AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hLocal luResolve
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
tid <- localTicketTicket <$> getJust ltid
|
||||
update tid [TicketStatus =. TSClosed]
|
||||
-}
|
||||
|
||||
undoC
|
||||
:: Entity Person
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Undo URIMode
|
||||
-> Actor
|
||||
-> Maybe
|
||||
(Either
|
||||
(LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
|
||||
FedURI
|
||||
)
|
||||
-> RecipientRoutes
|
||||
-> [(Host, NonEmpty LocalURI)]
|
||||
-> [Host]
|
||||
-> AP.Action URIMode
|
||||
-> AP.Undo URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
undoC (Entity _pidUser personUser) summary audience undo@(Undo uObject) = do
|
||||
error "undoC temporarily disabled"
|
||||
undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Undo uObject) = do
|
||||
|
||||
{-
|
||||
-- Check input
|
||||
undone <-
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI uObject
|
||||
|
||||
|
||||
let shrUser = sharerIdent sharerUser
|
||||
object <- parseActivity uObject
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Undo with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients specified"
|
||||
now <- liftIO getCurrentTime
|
||||
(obiid, doc, _lu, mwi) <- runDBExcept $ do
|
||||
(obiidUndo, docUndo, luUndo) <- lift $ insertUndoToOutbox shrUser now (personOutbox personUser) blinded
|
||||
mltid <- fmap join $ runMaybeT $ do
|
||||
object' <- MaybeT $ getActivity object
|
||||
deleteFollow shrUser object' <|> deleteResolve object'
|
||||
mwi <- lift $ traverse getWorkItem mltid
|
||||
return (obiidUndo, docUndo, luUndo, mwi)
|
||||
mticketDetail <-
|
||||
for mwi $ \ wi ->
|
||||
(wi,) <$> runWorkerExcept (getWorkItemDetail "Object" $ Left wi)
|
||||
wiFollowers <- askWorkItemFollowers
|
||||
let sieve =
|
||||
case mticketDetail of
|
||||
Nothing -> makeRecipientSet [] [LocalPersonCollectionSharerFollowers shrUser]
|
||||
Just (_wi, ticketDetail) ->
|
||||
let (actors, colls) =
|
||||
workItemRecipSieve wiFollowers ticketDetail
|
||||
in makeRecipientSet
|
||||
actors
|
||||
(LocalPersonCollectionSharerFollowers shrUser :
|
||||
colls
|
||||
)
|
||||
(remotes, maybeAccept) <- runDBExcept $ do
|
||||
remotesHttpUndo <- do
|
||||
moreRemoteRecips <-
|
||||
lift $
|
||||
deliverLocal'
|
||||
True
|
||||
(LocalActorSharer shrUser)
|
||||
(personInbox personUser)
|
||||
obiid
|
||||
(localRecipSieve sieve True localRecips)
|
||||
unless (federation || null moreRemoteRecips) $
|
||||
throwE "Federation disabled, but recipient collection remote members found"
|
||||
lift $ deliverRemoteDB fwdHosts obiid remoteRecips moreRemoteRecips
|
||||
maccept <- for mticketDetail $ \ (wi, ticketDetail) -> do
|
||||
mhoster <-
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
|
||||
(undoID, deliverHttpUndo, maybeDeliverHttpAccept) <- runDBExcept $ do
|
||||
|
||||
-- Find the undone activity in our DB
|
||||
undoneDB <- do
|
||||
a <- getActivity undone
|
||||
fromMaybeE a "Can't find undone in DB"
|
||||
|
||||
-- See if the undone activity is a Follow/Resolve on a local target
|
||||
-- If it is, verify the relevant actor is addressed, verify
|
||||
-- permissions, and perform the actual undoing in the DB
|
||||
maybeUndoLocal <- do
|
||||
maybeUndo <-
|
||||
lift $ runMaybeT $
|
||||
case wi of
|
||||
WorkItemSharerTicket shr _ _ -> do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
p <- MaybeT (getValBy $ UniquePersonIdent sid)
|
||||
return (personOutbox p, personInbox p)
|
||||
WorkItemProjectTicket shr prj _ -> do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
j <- MaybeT $ getValBy $ UniqueProject prj sid
|
||||
a <- lift $ getJust $ projectActor j
|
||||
return (actorOutbox a, actorInbox a)
|
||||
WorkItemRepoProposal shr rp _ -> do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
r <- MaybeT (getValBy $ UniqueRepo rp sid)
|
||||
return (repoOutbox r, repoInbox r)
|
||||
(obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB"
|
||||
obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift $ insertAcceptOnTicketStatus shrUser wi ticketDetail obiid obiidAccept
|
||||
knownRemoteRecipsAccept <-
|
||||
lift $
|
||||
deliverLocal'
|
||||
False
|
||||
(workItemActor wi)
|
||||
ibidHoster
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (remotesHttpUndo, maccept)
|
||||
Left <$> MaybeT (tryUnfollow undoneDB) <|>
|
||||
Right <$> MaybeT (tryUnresolve undoneDB)
|
||||
case maybeUndo of
|
||||
Nothing -> pure Nothing
|
||||
Just (Left (updateDB, actorID, Left followerSetID)) -> do
|
||||
actorByKey <- lift $ getLocalActor actorID
|
||||
unless (actorByKey == LocalActorPerson senderPersonID) $
|
||||
throwE "Tryin to undo a Follow of someone else"
|
||||
(fByKey, fActorID, _) <- do
|
||||
followee <- lift $ getFollowee' followerSetID
|
||||
getFollowee followee
|
||||
fByHash <- hashLocalActor fByKey
|
||||
unless (actorIsAddressed localRecips fByHash) $
|
||||
throwE "Followee's actor not addressed by the Undo"
|
||||
lift updateDB
|
||||
fActor <- lift $ getJust fActorID
|
||||
return $ Just
|
||||
( fByKey
|
||||
, Entity fActorID fActor
|
||||
, makeRecipientSet
|
||||
[fByHash]
|
||||
[LocalStagePersonFollowers senderHash]
|
||||
, [LocalActorPerson senderHash]
|
||||
, []
|
||||
)
|
||||
Just (Left (updateDB, actorID, Right uTarget)) -> do
|
||||
actorByKey <- lift $ getLocalActor actorID
|
||||
unless (actorByKey == LocalActorPerson senderPersonID) $
|
||||
throwE "Trying to undo a Follow of someone else"
|
||||
verifyRemoteAddressed remoteRecips uTarget
|
||||
lift updateDB
|
||||
return Nothing
|
||||
Just (Right (updateDB, ticketID)) -> do
|
||||
wiByKey <- lift $ getWorkItem ticketID
|
||||
wiByHash <- hashWorkItem wiByKey
|
||||
let resource = workItemResource wiByKey
|
||||
actorByKey = workItemActor wiByKey
|
||||
actorByHash = workItemActor wiByHash
|
||||
unless (actorIsAddressed localRecips actorByHash) $
|
||||
throwE "Work item's actor not addressed by the Undo"
|
||||
capID <- fromMaybeE maybeCap "No capability provided"
|
||||
capability <-
|
||||
case capID of
|
||||
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
|
||||
verifyCapability capability (Left senderPersonID) resource
|
||||
lift updateDB
|
||||
actorID <- do
|
||||
maybeActor <- lift $ getLocalActorEntity actorByKey
|
||||
case localActorID <$> maybeActor of
|
||||
Nothing -> error "Actor entity not in DB"
|
||||
Just aid -> pure aid
|
||||
actor <- lift $ getJust actorID
|
||||
return $ Just
|
||||
( actorByKey
|
||||
, Entity actorID actor
|
||||
, makeRecipientSet
|
||||
[actorByHash]
|
||||
[ localActorFollowers actorByHash
|
||||
, workItemFollowers wiByHash
|
||||
, LocalStagePersonFollowers senderHash
|
||||
]
|
||||
, [LocalActorPerson senderHash]
|
||||
, [ localActorFollowers actorByHash
|
||||
, workItemFollowers wiByHash
|
||||
, LocalStagePersonFollowers senderHash
|
||||
]
|
||||
)
|
||||
|
||||
-- Insert the Undo activity to author's outbox
|
||||
undoID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
luUndo <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) undoID action
|
||||
|
||||
-- Deliver the Undo activity to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
deliverHttpUndo <- do
|
||||
let sieve =
|
||||
case maybeUndoLocal of
|
||||
Nothing ->
|
||||
makeRecipientSet
|
||||
[] [LocalStagePersonFollowers senderHash]
|
||||
Just (_, _, s, _, _) -> s
|
||||
localRecipsFinal = localRecipSieve sieve False localRecips
|
||||
deliverActivityDB
|
||||
(LocalActorPerson senderHash) (personActor senderPerson)
|
||||
localRecipsFinal remoteRecips fwdHosts undoID action
|
||||
|
||||
maybeDeliverHttpAccept <- for maybeUndoLocal $ \ (actorByKey, Entity actorID actor, _, acceptActors, acceptStages) -> do
|
||||
|
||||
-- Verify the relevant actor has received the Undp
|
||||
verifyActorHasItem actorID undoID "Actor didn't receive the Undo"
|
||||
|
||||
-- Insert an Accept activity to actor's outbox
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
|
||||
actionAccept <- prepareAccept luUndo acceptActors acceptStages
|
||||
_luAccept <- lift $ updateOutboxItem actorByKey acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
let localRecipsAccept = makeRecipientSet acceptActors acceptStages
|
||||
actorByHash <- hashLocalActor actorByKey
|
||||
deliverActivityDB
|
||||
actorByHash actorID localRecipsAccept [] []
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return (undoID, deliverHttpUndo, maybeDeliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of Undo and Accept
|
||||
lift $ do
|
||||
forkWorker "undoC: async HTTP Undo delivery" $
|
||||
deliverRemoteHttp' fwdHosts obiid doc remotes
|
||||
for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) ->
|
||||
forkWorker "undoC: async HTTP Accept delivery" $
|
||||
deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept
|
||||
return obiid
|
||||
forkWorker "undoC: async HTTP Undo delivery" deliverHttpUndo
|
||||
for_ maybeDeliverHttpAccept $
|
||||
forkWorker "undoC: async HTTP Accept delivery"
|
||||
|
||||
return undoID
|
||||
|
||||
where
|
||||
insertUndoToOutbox shrUser now obid blinded = do
|
||||
|
||||
prepareAccept luUndo actors stages = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just luAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = UndoActivity $ Undo uObject
|
||||
let recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalStage stages
|
||||
return AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hLocal luUndo
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
|
||||
deleteFollow shr (Left (actor, obiid)) = do
|
||||
deleteFollowLocal <|> deleteFollowRemote <|> deleteFollowRequest
|
||||
return Nothing
|
||||
where
|
||||
deleteFollowLocal = do
|
||||
fid <- MaybeT $ lift $ getKeyBy $ UniqueFollowFollow obiid
|
||||
unless (actor == LocalActorSharer shr) $
|
||||
lift $ throwE "Undoing someone else's follow"
|
||||
lift $ lift $ delete fid
|
||||
deleteFollowRemote = do
|
||||
frid <- MaybeT $ lift $ getKeyBy $ UniqueFollowRemoteFollow obiid
|
||||
unless (actor == LocalActorSharer shr) $
|
||||
lift $ throwE "Undoing someone else's follow"
|
||||
lift $ lift $ delete frid
|
||||
deleteFollowRequest = do
|
||||
frrid <- MaybeT $ lift $ getKeyBy $ UniqueFollowRemoteRequestActivity obiid
|
||||
unless (actor == LocalActorSharer shr) $
|
||||
lift $ throwE "Undoing someone else's follow"
|
||||
lift $ lift $ delete frrid
|
||||
deleteFollow _ (Right _) = mzero
|
||||
|
||||
deleteResolve (Left (_, obiid)) = do
|
||||
Entity trlid trl <- MaybeT $ lift $ getBy $ UniqueTicketResolveLocalActivity obiid
|
||||
lift $ lift $ do
|
||||
let trid = ticketResolveLocalTicket trl
|
||||
tr <- getJust trid
|
||||
delete trlid
|
||||
delete trid
|
||||
let ltid = ticketResolveTicket tr
|
||||
tid <- localTicketTicket <$> getJust ltid
|
||||
update tid [TicketStatus =. TSTodo]
|
||||
return $ Just ltid
|
||||
deleteResolve (Right ractid) = do
|
||||
Entity trrid trr <- MaybeT $ lift $ getBy $ UniqueTicketResolveRemoteActivity ractid
|
||||
lift $ lift $ do
|
||||
let trid = ticketResolveRemoteTicket trr
|
||||
tr <- getJust trid
|
||||
delete trrid
|
||||
delete trid
|
||||
let ltid = ticketResolveTicket tr
|
||||
tid <- localTicketTicket <$> getJust ltid
|
||||
update tid [TicketStatus =. TSTodo]
|
||||
return $ Just ltid
|
||||
-}
|
||||
}
|
||||
|
||||
pushCommitsC
|
||||
:: Entity Person
|
||||
|
|
|
|||
|
|
@ -86,7 +86,6 @@ import Vervis.Model
|
|||
import Vervis.Recipient
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
|
||||
makeServerInput
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
|
|
@ -782,7 +781,7 @@ applyPatches
|
|||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode)
|
||||
applyPatches senderHash uObject = do
|
||||
|
||||
bundle <- parseProposalBundle "Apply object" uObject
|
||||
bundle <- parseBundleRoute "Apply object" uObject
|
||||
mrInfo <-
|
||||
bifor bundle
|
||||
(\ (loomID, clothID, _) -> do
|
||||
|
|
|
|||
|
|
@ -20,6 +20,9 @@ module Vervis.Data.Actor
|
|||
, stampRoute
|
||||
, parseStampRoute
|
||||
, localActorID
|
||||
, parseLocalURI
|
||||
, parseFedURI
|
||||
, parseLocalActorE
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -104,3 +107,18 @@ localActorID (LocalActorGroup (Entity _ g)) = groupActor g
|
|||
localActorID (LocalActorRepo (Entity _ r)) = repoActor r
|
||||
localActorID (LocalActorDeck (Entity _ d)) = deckActor d
|
||||
localActorID (LocalActorLoom (Entity _ l)) = loomActor l
|
||||
|
||||
parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App)
|
||||
parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
|
||||
|
||||
parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI)
|
||||
parseFedURI u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> parseLocalURI lu
|
||||
else pure $ Right u
|
||||
|
||||
parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
|
||||
parseLocalActorE route = do
|
||||
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
|
||||
unhashLocalActorE actorByHash "Invalid actor keyhashid"
|
||||
|
|
|
|||
|
|
@ -39,26 +39,12 @@ import qualified Web.ActivityPub as AP
|
|||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Recipient
|
||||
|
||||
parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App)
|
||||
parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
|
||||
|
||||
parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI)
|
||||
parseFedURI u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> parseLocalURI lu
|
||||
else pure $ Right u
|
||||
|
||||
parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
|
||||
parseLocalActorE route = do
|
||||
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
|
||||
unhashLocalActorE actorByHash "Invalid actor keyhashid"
|
||||
|
||||
parseCommentId
|
||||
:: Route App -> ExceptT Text Handler (LocalActorBy Key, LocalMessageId)
|
||||
parseCommentId (PersonMessageR p m) =
|
||||
|
|
|
|||
84
src/Vervis/Data/Follow.hs
Normal file
84
src/Vervis/Data/Follow.hs
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module Vervis.Data.Follow
|
||||
( FolloweeBy (..)
|
||||
, followeeActor
|
||||
, parseFollow
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bitraversable
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Database.Persist.Types
|
||||
|
||||
import Network.FedURI
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Recipient
|
||||
|
||||
data FolloweeBy f
|
||||
= FolloweeActor (LocalActorBy f)
|
||||
| FolloweeWorkItem (WorkItemBy f)
|
||||
|
||||
followeeActor :: FolloweeBy f -> LocalActorBy f
|
||||
followeeActor (FolloweeActor a) = a
|
||||
followeeActor (FolloweeWorkItem wi) = workItemActor wi
|
||||
|
||||
unhashFolloweeE (FolloweeActor a) e = FolloweeActor <$> unhashLocalActorE a e
|
||||
unhashFolloweeE (FolloweeWorkItem wi) e = FolloweeWorkItem <$> unhashWorkItemE wi e
|
||||
|
||||
parseFollow
|
||||
:: AP.Follow URIMode
|
||||
-> ExceptT Text Handler
|
||||
(Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
|
||||
parseFollow (AP.Follow uObject mluContext hide) = do
|
||||
routeOrRemote <- parseFedURI uObject
|
||||
(,hide) <$>
|
||||
bitraverse
|
||||
(parseLocal mluContext)
|
||||
(pure . makeRemote mluContext)
|
||||
routeOrRemote
|
||||
where
|
||||
parseFollowee r =
|
||||
FolloweeActor <$> parseLocalActor r <|>
|
||||
FolloweeWorkItem <$> parseWorkItem r
|
||||
parseLocal mlu r = do
|
||||
byHash <- fromMaybeE (parseFollowee r) "Not a followee route"
|
||||
byKey <- unhashFolloweeE byHash "Followee invalid keyhashid"
|
||||
for_ mlu $ \ lu -> nameExceptT "Follow context" $ do
|
||||
actorR <-parseLocalURI lu
|
||||
actorByKey <- parseLocalActorE actorR
|
||||
unless (actorByKey == followeeActor byKey) $
|
||||
throwE "Isn't object's actor"
|
||||
return byKey
|
||||
makeRemote mlu (ObjURI h lu) = (h, fromMaybe lu mlu, lu)
|
||||
|
|
@ -22,6 +22,27 @@ module Vervis.Data.Ticket
|
|||
, checkOfferTicket
|
||||
, checkApplyLocalLoom
|
||||
|
||||
, parseBundleRoute
|
||||
|
||||
, WorkItemBy (..)
|
||||
|
||||
, hashWorkItemPure
|
||||
, getHashWorkItem
|
||||
, hashWorkItem
|
||||
|
||||
, unhashWorkItemPure
|
||||
, unhashWorkItem
|
||||
, unhashWorkItemF
|
||||
, unhashWorkItemM
|
||||
, unhashWorkItemE
|
||||
, unhashWorkItem404
|
||||
|
||||
, workItemResource
|
||||
, workItemActor
|
||||
, workItemFollowers
|
||||
, workItemRoute
|
||||
, parseWorkItem
|
||||
|
||||
-- These are exported only for Vervis.Client
|
||||
, Tracker (..)
|
||||
, checkTracker
|
||||
|
|
@ -30,11 +51,16 @@ where
|
|||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Bifunctor
|
||||
import Data.Foldable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
import Web.Hashids
|
||||
import Yesod.Core
|
||||
|
||||
import qualified Control.Monad.Fail as F
|
||||
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
|
|
@ -42,15 +68,17 @@ import Web.Text
|
|||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.Foundation
|
||||
import Vervis.FedURI
|
||||
import Vervis.Model
|
||||
import Vervis.Ticket
|
||||
import Vervis.Recipient
|
||||
|
||||
data Tip
|
||||
= TipLocalRepo RepoId
|
||||
|
|
@ -201,12 +229,28 @@ checkOfferTicket host ticket uTarget = do
|
|||
tam <- checkTrackerAndMerge target maybeBundle
|
||||
return $ WorkItemOffer author title desc source tam
|
||||
|
||||
parseBundleRoute name u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <-
|
||||
fromMaybeE (decodeRouteLocal lu) $
|
||||
name <> ": Not a valid route"
|
||||
case route of
|
||||
BundleR loom ticket bundle ->
|
||||
(,,)
|
||||
<$> decodeKeyHashidE loom (name <> ": Invalid lkhid")
|
||||
<*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
|
||||
<*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid")
|
||||
_ -> throwE $ name <> ": not a bundle route"
|
||||
else return $ Right u
|
||||
|
||||
checkApply
|
||||
:: AP.Apply URIMode
|
||||
-> ExceptT Text Handler
|
||||
(Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
|
||||
checkApply (AP.Apply uObject target) =
|
||||
(,) <$> parseProposalBundle "Apply object" uObject
|
||||
(,) <$> parseBundleRoute "Apply object" uObject
|
||||
<*> nameExceptT "Apply target" (checkTip target)
|
||||
|
||||
checkApplyLocalLoom
|
||||
|
|
@ -227,3 +271,91 @@ checkApplyLocalLoom apply = do
|
|||
Left b -> pure b
|
||||
Right _ -> throwE "Applying a remote bundle on local loom"
|
||||
return (repoID, maybeBranch, loomID, clothID, bundleID)
|
||||
|
||||
data WorkItemBy f
|
||||
= WorkItemTicket (f Deck) (f TicketDeck)
|
||||
| WorkItemCloth (f Loom) (f TicketLoom)
|
||||
|
||||
hashWorkItemPure :: HashidsContext -> WorkItemBy Key -> WorkItemBy KeyHashid
|
||||
hashWorkItemPure ctx = f
|
||||
where
|
||||
f (WorkItemTicket d t) =
|
||||
WorkItemTicket (encodeKeyHashidPure ctx d) (encodeKeyHashidPure ctx t)
|
||||
f (WorkItemCloth l c) =
|
||||
WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c)
|
||||
|
||||
getHashWorkItem
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> m (WorkItemBy Key -> WorkItemBy KeyHashid)
|
||||
getHashWorkItem = do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
return $ hashWorkItemPure ctx
|
||||
|
||||
hashWorkItem
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> WorkItemBy Key -> m (WorkItemBy KeyHashid)
|
||||
hashWorkItem actor = do
|
||||
hash <- getHashWorkItem
|
||||
return $ hash actor
|
||||
|
||||
unhashWorkItemPure
|
||||
:: HashidsContext -> WorkItemBy KeyHashid -> Maybe (WorkItemBy Key)
|
||||
unhashWorkItemPure ctx = f
|
||||
where
|
||||
f (WorkItemTicket d t) =
|
||||
WorkItemTicket
|
||||
<$> decodeKeyHashidPure ctx d
|
||||
<*> decodeKeyHashidPure ctx t
|
||||
f (WorkItemCloth l c) =
|
||||
WorkItemCloth
|
||||
<$> decodeKeyHashidPure ctx l
|
||||
<*> decodeKeyHashidPure ctx c
|
||||
|
||||
unhashWorkItem
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key))
|
||||
unhashWorkItem actor = do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
return $ unhashWorkItemPure ctx actor
|
||||
|
||||
unhashWorkItemF
|
||||
:: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> WorkItemBy KeyHashid -> String -> m (WorkItemBy Key)
|
||||
unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor
|
||||
|
||||
unhashWorkItemM
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key)
|
||||
unhashWorkItemM = MaybeT . unhashWorkItem
|
||||
|
||||
unhashWorkItemE
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key)
|
||||
unhashWorkItemE actor e =
|
||||
ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor
|
||||
|
||||
unhashWorkItem404
|
||||
:: ( MonadSite m
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ SiteEnv m
|
||||
, YesodHashids (HandlerSite m)
|
||||
)
|
||||
=> WorkItemBy KeyHashid
|
||||
-> m (WorkItemBy Key)
|
||||
unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor
|
||||
|
||||
workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck
|
||||
workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom
|
||||
|
||||
workItemActor (WorkItemTicket deck _) = LocalActorDeck deck
|
||||
workItemActor (WorkItemCloth loom _) = LocalActorLoom loom
|
||||
|
||||
workItemFollowers (WorkItemTicket d t) = LocalStageTicketFollowers d t
|
||||
workItemFollowers (WorkItemCloth l c) = LocalStageClothFollowers l c
|
||||
|
||||
workItemRoute (WorkItemTicket d t) = TicketR d t
|
||||
workItemRoute (WorkItemCloth l c) = ClothR l c
|
||||
|
||||
parseWorkItem (TicketR deck task) = Just $ WorkItemTicket deck task
|
||||
parseWorkItem (ClothR loom cloth) = Just $ WorkItemCloth loom cloth
|
||||
parseWorkItem _ = Nothing
|
||||
|
|
|
|||
|
|
@ -113,7 +113,6 @@ import Vervis.Query
|
|||
import Vervis.Recipient
|
||||
import Vervis.Ticket
|
||||
import Vervis.Web.Repo
|
||||
import Vervis.WorkItem
|
||||
|
||||
{-
|
||||
checkBranch
|
||||
|
|
|
|||
|
|
@ -102,7 +102,6 @@ import Vervis.RemoteActorStore
|
|||
import Vervis.Settings
|
||||
import Vervis.Query
|
||||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
|
||||
data Result
|
||||
= ResultSomeException SomeException
|
||||
|
|
|
|||
|
|
@ -128,6 +128,7 @@ import Vervis.Model.Ident
|
|||
import Vervis.Model.Ticket
|
||||
import Vervis.Paginate
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Ticket
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
import Vervis.Style
|
||||
|
|
|
|||
|
|
@ -335,10 +335,7 @@ postPersonOutboxR personHash = do
|
|||
addBundleC eperson sharer summary audience patches target
|
||||
_ -> throwE "Unsupported Add 'object' type"
|
||||
-}
|
||||
{-
|
||||
FollowActivity follow ->
|
||||
followC shr summary audience follow
|
||||
-}
|
||||
AP.FollowActivity follow -> run followC follow
|
||||
AP.OfferActivity (AP.Offer obj target) ->
|
||||
case obj of
|
||||
AP.OfferTicket ticket -> run offerTicketC ticket target
|
||||
|
|
@ -347,12 +344,8 @@ postPersonOutboxR personHash = do
|
|||
offerDepC eperson sharer summary audience dep target
|
||||
-}
|
||||
_ -> throwE "Unsupported Offer 'object' type"
|
||||
{-
|
||||
ResolveActivity resolve ->
|
||||
resolveC eperson sharer summary audience resolve
|
||||
UndoActivity undo ->
|
||||
undoC eperson sharer summary audience undo
|
||||
-}
|
||||
AP.ResolveActivity resolve -> run resolveC resolve
|
||||
AP.UndoActivity undo -> run undoC undo
|
||||
_ -> throwE "Unsupported activity type"
|
||||
|
||||
getPersonOutboxItemR
|
||||
|
|
|
|||
|
|
@ -151,6 +151,7 @@ import Vervis.Model.Workflow
|
|||
import Vervis.Paginate
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.Persist.Ticket
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
import Vervis.Style
|
||||
|
|
|
|||
138
src/Vervis/Persist/Follow.hs
Normal file
138
src/Vervis/Persist/Follow.hs
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module Vervis.Persist.Follow
|
||||
( getFollowee
|
||||
, getFollowee'
|
||||
, tryUnfollow
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
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.Bitraversable
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Crypto.ActorKey
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
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.Cloth
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Follow
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Ticket
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
|
||||
getFollowee
|
||||
:: MonadIO m
|
||||
=> FolloweeBy Key
|
||||
-> ExceptT Text (ReaderT SqlBackend m)
|
||||
(LocalActorBy Key, ActorId, Maybe FollowerSetId)
|
||||
getFollowee (FolloweeActor actorByKey) = do
|
||||
actorByEntity <- do
|
||||
maybeActor <- lift $ getLocalActorEntity actorByKey
|
||||
fromMaybeE maybeActor "Actor not found in DB"
|
||||
return (actorByKey, localActorID actorByEntity, Nothing)
|
||||
getFollowee (FolloweeWorkItem wi) =
|
||||
case wi of
|
||||
WorkItemTicket deckID taskID -> do
|
||||
actorID <- deckActor <$> getE deckID "No such deck in DB"
|
||||
(_, _, Entity _ ticket, _, _) <- do
|
||||
mticket <- lift $ getTicket deckID taskID
|
||||
fromMaybeE mticket "No such ticket in DB"
|
||||
return
|
||||
( LocalActorDeck deckID
|
||||
, actorID
|
||||
, Just $ ticketFollowers ticket
|
||||
)
|
||||
WorkItemCloth loomID clothID -> do
|
||||
actorID <- loomActor <$> getE loomID "No such loom in DB"
|
||||
(_, _, Entity _ ticket, _, _, _) <- do
|
||||
mcloth <- lift $ getCloth loomID clothID
|
||||
fromMaybeE mcloth "No such MR in DB"
|
||||
return
|
||||
( LocalActorLoom loomID
|
||||
, actorID
|
||||
, Just $ ticketFollowers ticket
|
||||
)
|
||||
|
||||
getFollowee' followerSetID = do
|
||||
actorOrTicket <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniqueActorFollowers followerSetID)
|
||||
(getKeyBy $ UniqueTicketFollowers followerSetID)
|
||||
"Can't find who's using this FollowerSet"
|
||||
"Multi use of FollowerSet"
|
||||
either FolloweeActor FolloweeWorkItem <$>
|
||||
bitraverse getLocalActor getWorkItem actorOrTicket
|
||||
|
||||
tryUnfollow (Left (_actorByKey, _actorEntity, itemID)) =
|
||||
runMaybeT $
|
||||
MaybeT forRemoteRequest <|> MaybeT forRemote <|> MaybeT forLocal
|
||||
where
|
||||
forRemoteRequest = do
|
||||
maybeFollow <- getBy $ UniqueFollowRemoteRequestActivity itemID
|
||||
for maybeFollow $ \ (Entity requestID request) -> do
|
||||
actorID <-
|
||||
personActor <$> getJust (followRemoteRequestPerson request)
|
||||
let uTarget =
|
||||
fromMaybe (followRemoteRequestTarget request) $
|
||||
followRemoteRequestRecip request
|
||||
return (delete requestID, actorID, Right uTarget)
|
||||
forRemote = do
|
||||
maybeFollow <- getBy $ UniqueFollowRemoteFollow itemID
|
||||
for maybeFollow $ \ (Entity remoteID remote) -> do
|
||||
let actorID = followRemoteActor remote
|
||||
uTarget <- getRemoteActorURI =<< getJust (followRemoteRecip remote)
|
||||
return (delete remoteID, actorID, Right uTarget)
|
||||
forLocal = do
|
||||
maybeFollow <- getBy $ UniqueFollowFollow itemID
|
||||
return $ maybeFollow <&> \ (Entity followID follow) ->
|
||||
let actorID = followActor follow
|
||||
followerSetID = followTarget follow
|
||||
in (delete followID, actorID, Left followerSetID)
|
||||
tryUnfollow (Right _) = pure Nothing
|
||||
|
|
@ -14,19 +14,27 @@
|
|||
-}
|
||||
|
||||
module Vervis.Persist.Ticket
|
||||
( checkApplyDB
|
||||
( getTicketResolve
|
||||
, getWorkItem
|
||||
, checkApplyDB
|
||||
, tryUnresolve
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Bitraversable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.These
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
|
||||
|
|
@ -34,15 +42,57 @@ import Development.PatchMediaType
|
|||
import Yesod.Hashids
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Either.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Recipient
|
||||
|
||||
getTicketResolve (Entity _ tr, resolve) = do
|
||||
time <- outboxItemPublished <$> getJust (ticketResolveAccept tr)
|
||||
closer <- bitraverse getCloserLocal getCloserRemote resolve
|
||||
return (time, closer)
|
||||
where
|
||||
getCloserLocal (Entity _ trl) = do
|
||||
outboxID <-
|
||||
outboxItemOutbox <$>
|
||||
getJust (ticketResolveLocalActivity trl)
|
||||
Entity actorID actor <- do
|
||||
maybeActor <- getBy $ UniqueActorOutbox outboxID
|
||||
case maybeActor of
|
||||
Nothing -> error "No actor for outbox"
|
||||
Just a -> pure a
|
||||
actorByEntity <- getLocalActorEnt actorID
|
||||
person <-
|
||||
case actorByEntity of
|
||||
LocalActorPerson p -> pure p
|
||||
_ -> error "Surprise! Ticket closer isn't a Person"
|
||||
return (person, actor)
|
||||
getCloserRemote (Entity _ trr) = do
|
||||
ra <- getJust $ ticketResolveRemoteActor trr
|
||||
ro <- getJust $ remoteActorIdent ra
|
||||
i <- getJust $ remoteObjectInstance ro
|
||||
return (i, ro, ra)
|
||||
|
||||
getWorkItem :: MonadIO m => TicketId -> ReaderT SqlBackend m (WorkItemBy Key)
|
||||
getWorkItem tid = do
|
||||
tracker <-
|
||||
requireEitherAlt
|
||||
(getBy $ UniqueTicketDeck tid)
|
||||
(getBy $ UniqueTicketLoom tid)
|
||||
"Neither TD nor TD found"
|
||||
"Both TD and TL found"
|
||||
return $
|
||||
case tracker of
|
||||
Left (Entity tdid td) -> WorkItemTicket (ticketDeckDeck td) tdid
|
||||
Right (Entity tlid tl) -> WorkItemCloth (ticketLoomLoom tl) tlid
|
||||
|
||||
-- | Given:
|
||||
--
|
||||
-- * A local tip (i.e. a repository or a branch), parsed from a URI
|
||||
|
|
@ -142,3 +192,24 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
|
|||
else throwE "Patch type mismatch with repo VCS type"
|
||||
|
||||
return (loom, ticketID, diffs)
|
||||
|
||||
tryUnresolve (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
maybeResolve <- getBy $ UniqueTicketResolveLocalActivity itemID
|
||||
for maybeResolve $ \ (Entity resolveLocalID resolveLocal) -> do
|
||||
let resolveID = ticketResolveLocalTicket resolveLocal
|
||||
resolve <- getJust resolveID
|
||||
let ticketID = ticketResolveTicket resolve
|
||||
return
|
||||
( delete resolveLocalID >> delete resolveID
|
||||
, ticketID
|
||||
)
|
||||
tryUnresolve (Right remoteActivityID) = do
|
||||
maybeResolve <- getBy $ UniqueTicketResolveRemoteActivity remoteActivityID
|
||||
for maybeResolve $ \ (Entity resolveRemoteID resolveRemote) -> do
|
||||
let resolveID = ticketResolveRemoteTicket resolveRemote
|
||||
resolve <- getJust resolveID
|
||||
let ticketID = ticketResolveTicket resolve
|
||||
return
|
||||
( delete resolveRemoteID >> delete resolveID
|
||||
, ticketID
|
||||
)
|
||||
|
|
|
|||
|
|
@ -39,16 +39,9 @@ module Vervis.Ticket
|
|||
--, getDependencyCollection
|
||||
--, getReverseDependencyCollection
|
||||
|
||||
, WorkItem (..)
|
||||
, getWorkItemRoute
|
||||
, askWorkItemRoute
|
||||
, getWorkItem
|
||||
, parseWorkItem
|
||||
, parseProposalBundle
|
||||
--, getWorkItem
|
||||
|
||||
, checkDepAndTarget
|
||||
|
||||
, getTicketResolve
|
||||
--, checkDepAndTarget
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -85,6 +78,7 @@ import Data.Paginate.Local
|
|||
import Database.Persist.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
|
@ -690,74 +684,7 @@ getReverseDependencyCollection here getLocalTicketId404 = do
|
|||
return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
|
||||
-}
|
||||
|
||||
data WorkItem
|
||||
= WorkItemTicket DeckId TicketDeckId
|
||||
| WorkItemCloth LoomId TicketLoomId
|
||||
deriving Eq
|
||||
|
||||
getWorkItemRoute
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m)) => WorkItem -> m (Route App)
|
||||
getWorkItemRoute wi = ($ wi) <$> askWorkItemRoute
|
||||
|
||||
askWorkItemRoute
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m)) => m (WorkItem -> Route App)
|
||||
askWorkItemRoute = do
|
||||
hashDID <- getEncodeKeyHashid
|
||||
hashLID <- getEncodeKeyHashid
|
||||
hashTDID <- getEncodeKeyHashid
|
||||
hashTLID <- getEncodeKeyHashid
|
||||
let route (WorkItemTicket did tdid) = TicketR (hashDID did) (hashTDID tdid)
|
||||
route (WorkItemCloth lid tlid) = ClothR (hashLID lid) (hashTLID tlid)
|
||||
return route
|
||||
|
||||
getWorkItem :: MonadIO m => TicketId -> ReaderT SqlBackend m WorkItem
|
||||
getWorkItem tid = do
|
||||
tracker <-
|
||||
requireEitherAlt
|
||||
(getBy $ UniqueTicketDeck tid)
|
||||
(getBy $ UniqueTicketLoom tid)
|
||||
"Neither TD nor TD found"
|
||||
"Both TD and TL found"
|
||||
return $
|
||||
case tracker of
|
||||
Left (Entity tdid td) -> WorkItemTicket (ticketDeckDeck td) tdid
|
||||
Right (Entity tlid tl) -> WorkItemCloth (ticketLoomLoom tl) tlid
|
||||
|
||||
parseWorkItem name u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <-
|
||||
fromMaybeE (decodeRouteLocal lu) $
|
||||
name <> ": Not a valid route"
|
||||
case route of
|
||||
TicketR deck ticket ->
|
||||
WorkItemTicket
|
||||
<$> decodeKeyHashidE deck (name <> ": Invalid dkhid")
|
||||
<*> decodeKeyHashidE ticket (name <> ": Invalid tdkhid")
|
||||
ClothR loom ticket ->
|
||||
WorkItemCloth
|
||||
<$> decodeKeyHashidE loom (name <> ": Invalid lkhid")
|
||||
<*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
|
||||
_ -> throwE $ name <> ": not a work item route"
|
||||
else return $ Right u
|
||||
|
||||
parseProposalBundle name u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <-
|
||||
fromMaybeE (decodeRouteLocal lu) $
|
||||
name <> ": Not a valid route"
|
||||
case route of
|
||||
BundleR loom ticket bundle ->
|
||||
(,,)
|
||||
<$> decodeKeyHashidE loom (name <> ": Invalid lkhid")
|
||||
<*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
|
||||
<*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid")
|
||||
_ -> throwE $ name <> ": not a bundle route"
|
||||
else return $ Right u
|
||||
|
||||
{-
|
||||
checkDepAndTarget
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> TicketDependency URIMode
|
||||
|
|
@ -798,29 +725,4 @@ checkDepAndTarget
|
|||
checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target"
|
||||
checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
|
||||
checkParentAndTarget (Right _) (Right _) = return ()
|
||||
|
||||
getTicketResolve (Entity _ tr, resolve) = do
|
||||
time <- outboxItemPublished <$> getJust (ticketResolveAccept tr)
|
||||
closer <- bitraverse getCloserLocal getCloserRemote resolve
|
||||
return (time, closer)
|
||||
where
|
||||
getCloserLocal (Entity _ trl) = do
|
||||
outboxID <-
|
||||
outboxItemOutbox <$>
|
||||
getJust (ticketResolveLocalActivity trl)
|
||||
Entity actorID actor <- do
|
||||
maybeActor <- getBy $ UniqueActorOutbox outboxID
|
||||
case maybeActor of
|
||||
Nothing -> error "No actor for outbox"
|
||||
Just a -> pure a
|
||||
actorByEntity <- getLocalActorEnt actorID
|
||||
person <-
|
||||
case actorByEntity of
|
||||
LocalActorPerson p -> pure p
|
||||
_ -> error "Surprise! Ticket closer isn't a Person"
|
||||
return (person, actor)
|
||||
getCloserRemote (Entity _ trr) = do
|
||||
ra <- getJust $ ticketResolveRemoteActor trr
|
||||
ro <- getJust $ remoteActorIdent ra
|
||||
i <- getJust $ remoteObjectInstance ro
|
||||
return (i, ro, ra)
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -97,6 +97,7 @@ import qualified Web.ActivityPub as AP
|
|||
import Vervis.ActivityPub
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Foundation
|
||||
|
|
@ -433,10 +434,10 @@ getFollowingCollection here actor hash = do
|
|||
<*> getRemotes followerActorID
|
||||
|
||||
hashActor <- getHashLocalActor
|
||||
workItemRoute <- askWorkItemRoute
|
||||
hashItem <- getHashWorkItem
|
||||
let locals =
|
||||
map (renderLocalActor . hashActor) localActors ++
|
||||
map workItemRoute workItems
|
||||
map (workItemRoute . hashItem) workItems
|
||||
unless (length locals == localTotal) $
|
||||
error "Bug! List length mismatch"
|
||||
|
||||
|
|
|
|||
|
|
@ -62,6 +62,7 @@ import Yesod.Persist.Local
|
|||
|
||||
import Vervis.API
|
||||
import Vervis.Data.Discussion
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Form.Discussion
|
||||
import Vervis.Foundation
|
||||
|
|
@ -69,6 +70,7 @@ import Vervis.Model
|
|||
import Vervis.Model.Ident
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.Persist.Ticket
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
|
|
@ -220,7 +222,6 @@ serveMessage authorHash localMessageHash = do
|
|||
localMessageID <- decodeKeyHashid404 localMessageHash
|
||||
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
workItemRoute <- askWorkItemRoute
|
||||
noteAP <- runDB $ do
|
||||
author <- get404 authorID
|
||||
localMessage <- get404 localMessageID
|
||||
|
|
@ -236,8 +237,10 @@ serveMessage authorHash localMessageHash = do
|
|||
"Neither T nor RD found"
|
||||
"Both T and RD found"
|
||||
case topic of
|
||||
Left ticketID ->
|
||||
encodeRouteHome . workItemRoute <$> getWorkItem ticketID
|
||||
Left ticketID -> do
|
||||
wiByKey <- getWorkItem ticketID
|
||||
wiByHash <- hashWorkItem wiByKey
|
||||
return $ encodeRouteHome $ workItemRoute wiByHash
|
||||
Right rd -> do
|
||||
ro <- getJust $ remoteDiscussionIdent rd
|
||||
i <- getJust $ remoteObjectInstance ro
|
||||
|
|
|
|||
|
|
@ -1513,21 +1513,21 @@ encodeCreate (Create obj target)
|
|||
|
||||
data Follow u = Follow
|
||||
{ followObject :: ObjURI u
|
||||
, followContext :: Maybe (ObjURI u)
|
||||
, followContext :: Maybe LocalURI
|
||||
, followHide :: Bool
|
||||
}
|
||||
|
||||
parseFollow :: UriMode u => Object -> Parser (Follow u)
|
||||
parseFollow o =
|
||||
Follow
|
||||
<$> o .: "object"
|
||||
<*> o .:? "context"
|
||||
parseFollow o = do
|
||||
u@(ObjURI h _) <- o .: "object"
|
||||
Follow u
|
||||
<$> withAuthorityMaybeO h (o .:? "context")
|
||||
<*> o .:? "hide" .!= False
|
||||
|
||||
encodeFollow :: UriMode u => Follow u -> Series
|
||||
encodeFollow (Follow obj mcontext hide)
|
||||
= "object" .= obj
|
||||
<> "context" .=? mcontext
|
||||
<> "context" .=? (ObjURI (objUriAuthority obj) <$> mcontext)
|
||||
<> "hide" .= hide
|
||||
|
||||
data Grant u = Grant
|
||||
|
|
|
|||
|
|
@ -143,6 +143,7 @@ library
|
|||
Vervis.Data.Actor
|
||||
Vervis.Data.Collab
|
||||
Vervis.Data.Discussion
|
||||
Vervis.Data.Follow
|
||||
Vervis.Data.Ticket
|
||||
|
||||
--Vervis.Federation
|
||||
|
|
@ -211,6 +212,7 @@ library
|
|||
Vervis.Persist.Actor
|
||||
Vervis.Persist.Collab
|
||||
Vervis.Persist.Discussion
|
||||
Vervis.Persist.Follow
|
||||
Vervis.Persist.Ticket
|
||||
|
||||
Vervis.Query
|
||||
|
|
@ -246,7 +248,7 @@ library
|
|||
Vervis.Widget.Tracker
|
||||
-- Vervis.Widget.Workflow
|
||||
-- Vervis.Wiki
|
||||
Vervis.WorkItem
|
||||
--Vervis.WorkItem
|
||||
|
||||
default-extensions: TemplateHaskell
|
||||
QuasiQuotes
|
||||
|
|
|
|||
Loading…
Reference in a new issue