S2S unresolve, C2S resolve & unresolve, use C2S in the UI buttons
This commit is contained in:
fr33domlover
parent
7f106023b0
commit
9317e514b2
14 changed files with 897 additions and 350 deletions
|
|
@ -368,8 +368,6 @@ Ticket
|
|||
description Text -- HTML
|
||||
assignee PersonId Maybe
|
||||
status TicketStatus
|
||||
closed UTCTime
|
||||
closer PersonId Maybe
|
||||
|
||||
-- UniqueTicket project number
|
||||
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ module Vervis.API
|
|||
, followC
|
||||
, offerTicketC
|
||||
, offerDepC
|
||||
, resolveC
|
||||
, undoC
|
||||
, pushCommitsC
|
||||
, getFollowersCollection
|
||||
|
|
@ -855,8 +856,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
, ticketDescription = unTextHtml desc
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
}
|
||||
ltid <- insert LocalTicket
|
||||
{ localTicketTicket = tid
|
||||
|
|
@ -1514,8 +1513,6 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
, ticketDescription = unTextHtml desc
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
}
|
||||
ltid <- insert LocalTicket
|
||||
{ localTicketTicket = tid
|
||||
|
|
@ -1585,6 +1582,59 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, makeRecipientSet actors collections)
|
||||
|
||||
verifyHosterRecip _ _ (Right _) = return ()
|
||||
verifyHosterRecip localRecips name (Left wi) =
|
||||
fromMaybeE (verify wi) $
|
||||
name <> " ticket hoster actor isn't listed as a recipient"
|
||||
where
|
||||
verify (WorkItemSharerTicket shr _ _) = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
guard $ localRecipSharer $ localRecipSharerDirect sharerSet
|
||||
verify (WorkItemProjectTicket shr prj _) = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
|
||||
guard $ localRecipProject $ localRecipProjectDirect projectSet
|
||||
verify (WorkItemRepoPatch shr rp _) = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
repoSet <- lookup rp $ localRecipRepoRelated sharerSet
|
||||
guard $ localRecipRepo $ localRecipRepoDirect repoSet
|
||||
|
||||
workItemRecipSieve wiFollowers (WorkItemDetail ident context author) =
|
||||
let authorC =
|
||||
case author of
|
||||
Left shr -> [LocalPersonCollectionSharerFollowers shr]
|
||||
Right _ -> []
|
||||
ticketC =
|
||||
case ident of
|
||||
Left (wi, _) -> [wiFollowers wi]
|
||||
Right _ -> []
|
||||
(contextA, contextC) =
|
||||
case context of
|
||||
Left local ->
|
||||
case local of
|
||||
Left (shr, prj) ->
|
||||
( [LocalActorProject shr prj]
|
||||
, [ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
)
|
||||
Right (shr, rp) ->
|
||||
( [LocalActorRepo shr rp]
|
||||
, [ LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
)
|
||||
Right _ -> ([], [])
|
||||
in (contextA, authorC ++ ticketC ++ contextC)
|
||||
|
||||
workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr
|
||||
workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj
|
||||
workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp
|
||||
|
||||
actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr
|
||||
actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
|
||||
actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp
|
||||
|
||||
offerDepC
|
||||
:: Entity Person
|
||||
-> Sharer
|
||||
|
|
@ -1698,25 +1748,6 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget =
|
|||
forkWorker "offerDepC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept
|
||||
return obiidOffer
|
||||
where
|
||||
runWorkerExcept action = do
|
||||
site <- askSite
|
||||
ExceptT $ liftIO $ runWorker (runExceptT action) site
|
||||
verifyHosterRecip _ _ (Right _) = return ()
|
||||
verifyHosterRecip localRecips name (Left wi) =
|
||||
fromMaybeE (verify wi) $
|
||||
name <> " ticket hoster actor isn't listed as a recipient"
|
||||
where
|
||||
verify (WorkItemSharerTicket shr _ _) = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
guard $ localRecipSharer $ localRecipSharerDirect sharerSet
|
||||
verify (WorkItemProjectTicket shr prj _) = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
|
||||
guard $ localRecipProject $ localRecipProjectDirect projectSet
|
||||
verify (WorkItemRepoPatch shr rp _) = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
repoSet <- lookup rp $ localRecipRepoRelated sharerSet
|
||||
guard $ localRecipRepo $ localRecipRepoDirect repoSet
|
||||
insertOfferToOutbox shrUser now obid blinded = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
|
|
@ -1733,33 +1764,6 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget =
|
|||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
workItemRecipSieve wiFollowers (WorkItemDetail ident context author) =
|
||||
let authorC =
|
||||
case author of
|
||||
Left shr -> [LocalPersonCollectionSharerFollowers shr]
|
||||
Right _ -> []
|
||||
ticketC =
|
||||
case ident of
|
||||
Left (wi, _) -> [wiFollowers wi]
|
||||
Right _ -> []
|
||||
(contextA, contextC) =
|
||||
case context of
|
||||
Left local ->
|
||||
case local of
|
||||
Left (shr, prj) ->
|
||||
( [LocalActorProject shr prj]
|
||||
, [ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
)
|
||||
Right (shr, rp) ->
|
||||
( [LocalActorRepo shr rp]
|
||||
, [ LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
)
|
||||
Right _ -> ([], [])
|
||||
in (contextA, authorC ++ ticketC ++ contextC)
|
||||
insertDep now pidAuthor obiidOffer ltidParent child obiidAccept = do
|
||||
tdid <- insert LocalTicketDependency
|
||||
{ localTicketDependencyParent = ltidParent
|
||||
|
|
@ -1839,91 +1843,306 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget =
|
|||
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
where
|
||||
authorAudience (Left shr) = AudLocal [LocalActorSharer shr] []
|
||||
authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] []
|
||||
actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr
|
||||
actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
|
||||
actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp
|
||||
|
||||
insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve obiidAccept = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
wiFollowers <- askWorkItemFollowers
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
obikhidResolve <- encodeKeyHashid obiidResolve
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
|
||||
let audAuthor =
|
||||
AudLocal
|
||||
[LocalActorSharer shrUser]
|
||||
[LocalPersonCollectionSharerFollowers shrUser]
|
||||
audTicketContext = contextAudience ctx
|
||||
audTicketAuthor = authorAudience author
|
||||
audTicketFollowers = AudLocal [] [wiFollowers wi]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience $
|
||||
audAuthor :
|
||||
audTicketAuthor :
|
||||
audTicketFollowers :
|
||||
audTicketContext
|
||||
|
||||
actor = workItemActor wi
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
actorOutboxItem actor obikhidAccept
|
||||
, activityActor = encodeRouteLocal $ renderLocalActor actor
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject =
|
||||
encodeRouteHome $ SharerOutboxItemR shrUser obikhidResolve
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
resolveC
|
||||
:: Entity Person
|
||||
-> Sharer
|
||||
-> Maybe TextHtml
|
||||
-> Audience URIMode
|
||||
-> Resolve URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObject) = do
|
||||
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
|
||||
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)
|
||||
return (projectOutbox j, projectInbox j)
|
||||
WorkItemRepoPatch 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
|
||||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = ResolveActivity $ Resolve uObject
|
||||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
|
||||
insertResolve ltid obiidResolve obiidAccept = do
|
||||
trid <- insert TicketResolve
|
||||
{ ticketResolveTicket = ltid
|
||||
, ticketResolveAccept = obiidAccept
|
||||
}
|
||||
insert_ TicketResolveLocal
|
||||
{ ticketResolveLocalTicket = trid
|
||||
, ticketResolveLocalActivity = obiidResolve
|
||||
}
|
||||
tid <- localTicketTicket <$> getJust ltid
|
||||
update tid [TicketStatus =. TSClosed]
|
||||
|
||||
undoC
|
||||
:: ShrIdent
|
||||
:: Entity Person
|
||||
-> Sharer
|
||||
-> Maybe TextHtml
|
||||
-> Audience URIMode
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
undoC shrUser summary audience undo@(Undo luObject) = do
|
||||
undoC (Entity _pidUser personUser) sharerUser summary audience undo@(Undo uObject) = do
|
||||
let shrUser = sharerIdent sharerUser
|
||||
object <- parseActivity uObject
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Follow with no recipients"
|
||||
fromMaybeE mrecips "Undo with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients specified"
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal luObject)
|
||||
"Undo object isn't a valid route"
|
||||
obiidOriginal <- case route of
|
||||
SharerOutboxItemR shr obikhid
|
||||
| shr == shrUser ->
|
||||
decodeKeyHashidE obikhid "Undo object invalid obikhid"
|
||||
_ -> throwE "Undo object isn't actor's outbox item route"
|
||||
(obiidUndo, doc, remotesHttp) <- runDBExcept $ do
|
||||
Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser
|
||||
obi <- do
|
||||
mobi <- lift $ get obiidOriginal
|
||||
fromMaybeE mobi "Undo object obiid doesn't exist in DB"
|
||||
unless (outboxItemOutbox obi == personOutbox personAuthor) $
|
||||
throwE "Undo object obiid belongs to different actor"
|
||||
lift $ do
|
||||
deleteFollow obiidOriginal
|
||||
deleteFollowRemote obiidOriginal
|
||||
deleteFollowRemoteRequest obiidOriginal
|
||||
let obidAuthor = personOutbox personAuthor
|
||||
(obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor blinded
|
||||
let ibidAuthor = personInbox personAuthor
|
||||
fsidAuthor = personFollowers personAuthor
|
||||
knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips
|
||||
remotesHttp <- deliverRemoteDB'' fwdHosts obiidUndo remoteRecips knownRemotes
|
||||
return (obiidUndo, doc, remotesHttp)
|
||||
lift $ forkWorker "undoC: Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidUndo doc remotesHttp
|
||||
return obiidUndo
|
||||
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 <-
|
||||
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)
|
||||
return (projectOutbox j, projectInbox j)
|
||||
WorkItemRepoPatch 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)
|
||||
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
|
||||
where
|
||||
getAuthor shr = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
getBy404 $ UniquePersonIdent sid
|
||||
deleteFollow obiid = do
|
||||
mfid <- getKeyBy $ UniqueFollowFollow obiid
|
||||
traverse_ delete mfid
|
||||
deleteFollowRemote obiid = do
|
||||
mfrid <- getKeyBy $ UniqueFollowRemoteFollow obiid
|
||||
traverse_ delete mfrid
|
||||
deleteFollowRemoteRequest obiid = do
|
||||
mfrrid <- getKeyBy $ UniqueFollowRemoteRequestActivity obiid
|
||||
traverse_ delete mfrrid
|
||||
insertUndoToOutbox obid blinded = do
|
||||
insertUndoToOutbox shrUser now obid blinded = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let activity mluAct = Doc hLocal Activity
|
||||
{ activityId = mluAct
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just luAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = UndoActivity undo
|
||||
, activitySpecific = UndoActivity $ Undo uObject
|
||||
}
|
||||
now <- liftIO getCurrentTime
|
||||
obiid <- insert OutboxItem
|
||||
{ outboxItemOutbox = obid
|
||||
, outboxItemActivity =
|
||||
persistJSONObjectFromDoc $ activity Nothing
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = activity $ Just luAct
|
||||
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
|
||||
return $ Just $ ticketResolveTicket tr
|
||||
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
|
||||
return $ Just $ ticketResolveTicket tr
|
||||
|
||||
pushCommitsC
|
||||
:: (Entity Person, Sharer)
|
||||
-> Html
|
||||
|
|
|
|||
|
|
@ -52,6 +52,8 @@ module Vervis.ActivityPub
|
|||
, insertEmptyOutboxItem
|
||||
, verifyContentTypeAP
|
||||
, verifyContentTypeAP_E
|
||||
, parseActivity
|
||||
, getActivity
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1208,3 +1210,58 @@ verifyContentTypeAP_E = do
|
|||
typeAS2 =
|
||||
"application/ld+json; \
|
||||
\profile=\"https://www.w3.org/ns/activitystreams\""
|
||||
|
||||
parseActivity u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Object isn't a valid route"
|
||||
case route of
|
||||
SharerOutboxItemR shr obikhid ->
|
||||
(LocalActorSharer shr,) <$>
|
||||
decodeKeyHashidE obikhid "No such obikhid"
|
||||
ProjectOutboxItemR shr prj obikhid -> do
|
||||
(LocalActorProject shr prj,) <$>
|
||||
decodeKeyHashidE obikhid "No such obikhid"
|
||||
RepoOutboxItemR shr rp obikhid -> do
|
||||
(LocalActorRepo shr rp,) <$>
|
||||
decodeKeyHashidE obikhid "No such obikhid"
|
||||
else return $ Right u
|
||||
|
||||
getActivity (Left (actor, obiid)) = Just . Left <$> do
|
||||
obid <- getActorOutbox actor
|
||||
obi <- do
|
||||
mobi <- lift $ get obiid
|
||||
fromMaybeE mobi "No such obiid"
|
||||
unless (outboxItemOutbox obi == obid) $
|
||||
throwE "Actor/obiid mismatch"
|
||||
return (actor, obiid)
|
||||
where
|
||||
getActorOutbox (LocalActorSharer shr) = do
|
||||
sid <- do
|
||||
msid <- lift $ getKeyBy $ UniqueSharer shr
|
||||
fromMaybeE msid "No such sharer"
|
||||
p <- do
|
||||
mp <- lift $ getValBy $ UniquePersonIdent sid
|
||||
fromMaybeE mp "No such person"
|
||||
return $ personOutbox p
|
||||
getActorOutbox (LocalActorProject shr prj) = do
|
||||
sid <- do
|
||||
msid <- lift $ getKeyBy $ UniqueSharer shr
|
||||
fromMaybeE msid "No such sharer"
|
||||
j <- do
|
||||
mj <- lift $ getValBy $ UniqueProject prj sid
|
||||
fromMaybeE mj "No such project"
|
||||
return $ projectOutbox j
|
||||
getActorOutbox (LocalActorRepo shr rp) = do
|
||||
sid <- do
|
||||
msid <- lift $ getKeyBy $ UniqueSharer shr
|
||||
fromMaybeE msid "No such sharer"
|
||||
r <- do
|
||||
mr <- lift $ getValBy $ UniqueRepo rp sid
|
||||
fromMaybeE mr "No such repo"
|
||||
return $ repoOutbox r
|
||||
getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do
|
||||
iid <- MaybeT $ getKeyBy $ UniqueInstance h
|
||||
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu
|
||||
MaybeT $ getKeyBy $ UniqueRemoteActivity roid
|
||||
|
|
|
|||
|
|
@ -23,10 +23,12 @@ module Vervis.Client
|
|||
, followRepo
|
||||
, offerTicket
|
||||
, createTicket
|
||||
, resolve
|
||||
, undoFollowSharer
|
||||
, undoFollowProject
|
||||
, undoFollowTicket
|
||||
, undoFollowRepo
|
||||
, unresolve
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -47,7 +49,7 @@ import qualified Data.Text as T
|
|||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Follow, Ticket)
|
||||
import Web.ActivityPub hiding (Follow, Ticket, Project, Repo)
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
|
@ -57,13 +59,17 @@ import Yesod.RenderSource
|
|||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Either.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActivityPub.Recipient
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
|
||||
createThread
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
|
|
@ -315,6 +321,37 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context
|
|||
|
||||
return (summary, audience, create)
|
||||
|
||||
resolve
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent
|
||||
-> FedURI
|
||||
-> m (Either Text (Maybe TextHtml, Audience URIMode, Resolve URIMode))
|
||||
resolve shrUser uObject = runExceptT $ do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
wiFollowers <- askWorkItemFollowers
|
||||
object <- parseWorkItem "Resolve object" uObject
|
||||
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" object
|
||||
let audAuthor =
|
||||
AudLocal
|
||||
[LocalActorSharer shrUser]
|
||||
[LocalPersonCollectionSharerFollowers shrUser]
|
||||
audTicketContext = contextAudience context
|
||||
audTicketAuthor = authorAudience author
|
||||
audTicketFollowers =
|
||||
case ident of
|
||||
Left (wi, _ltid) -> AudLocal [] [wiFollowers wi]
|
||||
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
|
||||
|
||||
(_, _, _, audLocal, audRemote) =
|
||||
collectAudience $
|
||||
audAuthor :
|
||||
audTicketAuthor :
|
||||
audTicketFollowers :
|
||||
audTicketContext
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
return (Nothing, Audience recips [] [] [] [] [], Resolve uObject)
|
||||
|
||||
undoFollow
|
||||
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent
|
||||
|
|
@ -347,7 +384,7 @@ undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do
|
|||
|]
|
||||
let undo = Undo
|
||||
{ undoObject =
|
||||
encodeRouteLocal $ SharerOutboxItemR shrAuthor obikhidFollow
|
||||
encodeRouteHome $ SharerOutboxItemR shrAuthor obikhidFollow
|
||||
}
|
||||
audience = Audience [encodeRouteHome recipRoute] [] [] [] [] []
|
||||
return (summary, audience, undo)
|
||||
|
|
@ -442,3 +479,85 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee =
|
|||
mr <- lift $ getValBy $ UniqueRepo rpFollowee sidFollowee
|
||||
repoFollowers <$>
|
||||
fromMaybeE mr "Unfollow target no such local repo"
|
||||
|
||||
data ActorEntity
|
||||
= ActorPerson (Entity Person)
|
||||
| ActorProject (Entity Project)
|
||||
| ActorRepo (Entity Repo)
|
||||
|
||||
unresolve
|
||||
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent
|
||||
-> WorkItem
|
||||
-> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode))
|
||||
unresolve shrUser wi = runExceptT $ do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
wiFollowers <- askWorkItemFollowers
|
||||
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" $ Left wi
|
||||
ltid <-
|
||||
case ident of
|
||||
Left (_, ltid) -> return ltid
|
||||
Right _ -> error "Local WorkItem expected!"
|
||||
uResolve <- runSiteDBExcept $ do
|
||||
mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid
|
||||
trid <- fromMaybeE mtrid "Ticket already isn't resolved"
|
||||
trx <-
|
||||
lift $
|
||||
requireEitherAlt
|
||||
(getValBy $ UniqueTicketResolveLocal trid)
|
||||
(getValBy $ UniqueTicketResolveRemote trid)
|
||||
"No TRX"
|
||||
"Both TRL and TRR"
|
||||
case trx of
|
||||
Left trl -> lift $ do
|
||||
let obiid = ticketResolveLocalActivity trl
|
||||
obid <- outboxItemOutbox <$> getJust obiid
|
||||
ent <- getOutboxActorEntity obid
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
encodeRouteHome . flip outboxItemRoute obikhid <$>
|
||||
actorEntityPath ent
|
||||
Right trr -> lift $ do
|
||||
roid <-
|
||||
remoteActivityIdent <$>
|
||||
getJust (ticketResolveRemoteActivity trr)
|
||||
ro <- getJust roid
|
||||
i <- getJust $ remoteObjectInstance ro
|
||||
return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
let audAuthor =
|
||||
AudLocal
|
||||
[LocalActorSharer shrUser]
|
||||
[LocalPersonCollectionSharerFollowers shrUser]
|
||||
audTicketContext = contextAudience context
|
||||
audTicketAuthor = authorAudience author
|
||||
audTicketFollowers = AudLocal [] [wiFollowers wi]
|
||||
|
||||
(_, _, _, audLocal, audRemote) =
|
||||
collectAudience $
|
||||
audAuthor :
|
||||
audTicketAuthor :
|
||||
audTicketFollowers :
|
||||
audTicketContext
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
return (Nothing, Audience recips [] [] [] [] [], Undo uResolve)
|
||||
where
|
||||
getOutboxActorEntity obid = do
|
||||
mp <- getBy $ UniquePersonOutbox obid
|
||||
mj <- getBy $ UniqueProjectOutbox obid
|
||||
mr <- getBy $ UniqueRepoOutbox obid
|
||||
case (mp, mj, mr) of
|
||||
(Nothing, Nothing, Nothing) -> error "obid not in use"
|
||||
(Just p, Nothing, Nothing) -> return $ ActorPerson p
|
||||
(Nothing, Just j, Nothing) -> return $ ActorProject j
|
||||
(Nothing, Nothing, Just r) -> return $ ActorRepo r
|
||||
actorEntityPath (ActorPerson (Entity _ p)) =
|
||||
LocalActorSharer . sharerIdent <$> getJust (personIdent p)
|
||||
actorEntityPath (ActorProject (Entity _ j)) =
|
||||
flip LocalActorProject (projectIdent j) . sharerIdent <$>
|
||||
getJust (projectSharer j)
|
||||
actorEntityPath (ActorRepo (Entity _ r)) =
|
||||
flip LocalActorRepo (repoIdent r) . sharerIdent <$>
|
||||
getJust (repoSharer r)
|
||||
outboxItemRoute (LocalActorSharer shr) = SharerOutboxItemR shr
|
||||
outboxItemRoute (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
|
||||
outboxItemRoute (LocalActorRepo shr rp) = RepoOutboxItemR shr rp
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ import Data.Aeson
|
|||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.List (nub, union)
|
||||
|
|
@ -533,73 +534,77 @@ repoFollowF shr rp =
|
|||
followers (r, Nothing) = repoFollowers r
|
||||
followers (_, Just lt) = localTicketFollowers lt
|
||||
|
||||
undoF
|
||||
:: Route App
|
||||
-> AppDB (Entity a)
|
||||
-> (a -> InboxId)
|
||||
-> (a -> FollowerSetId)
|
||||
-> (Key a -> FollowerSetId -> AppDB (Maybe Text))
|
||||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
undoF
|
||||
recipRoute getRecip recipInbox recipFollowers trySubObjects
|
||||
now author body mfwd luUndo (Undo luObj) = do
|
||||
lift $ runDB $ do
|
||||
Entity idRecip recip <- getRecip
|
||||
ractid <- insertActivity luUndo
|
||||
mreason <- deleteRemoteFollow idRecip (recipFollowers recip)
|
||||
case mreason of
|
||||
Just reason -> return $ "Not using this Undo: " <> reason
|
||||
Nothing -> do
|
||||
inserted <- insertToInbox (recipInbox recip) ractid
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let me = localUriPath $ encodeRouteLocal recipRoute
|
||||
return $
|
||||
if inserted
|
||||
then "Undo applied and inserted to inbox of " <> me
|
||||
else "Undo applied and already exists in inbox of " <> me
|
||||
getFollow (Left _) = return Nothing
|
||||
getFollow (Right ractid) = getBy $ UniqueRemoteFollowFollow ractid
|
||||
|
||||
getResolve (Left (_, obiid)) = fmap Left <$> getBy (UniqueTicketResolveLocalActivity obiid)
|
||||
getResolve (Right ractid) = fmap Right <$> getBy (UniqueTicketResolveRemoteActivity ractid)
|
||||
|
||||
deleteResolve myWorkItem prepareAccept tr = do
|
||||
let (trid, trxid) =
|
||||
case tr of
|
||||
Left (Entity trlid trl) -> (ticketResolveLocalTicket trl, Left trlid)
|
||||
Right (Entity trrid trr) -> (ticketResolveRemoteTicket trr, Right trrid)
|
||||
ltid <- ticketResolveTicket <$> getJust trid
|
||||
wi <- getWorkItem ltid
|
||||
case myWorkItem wi of
|
||||
Nothing -> return ("Undo is of a TicketResolve but not my ticket", Nothing, Nothing)
|
||||
Just wiData -> do
|
||||
bitraverse delete delete trxid
|
||||
delete trid
|
||||
(colls, accept) <- prepareAccept wiData
|
||||
return ("Ticket unresolved", Just colls, Just accept)
|
||||
|
||||
deleteRemoteFollow myWorkItem author fsidRecip (Entity rfid rf)
|
||||
| remoteFollowActor rf /= remoteAuthorId author =
|
||||
return "Undo sent by different actor than the one who sent the Follow"
|
||||
| remoteFollowTarget rf == fsidRecip = do
|
||||
delete rfid
|
||||
return "Undo applied to sharer RemoteFollow"
|
||||
| otherwise = do
|
||||
r <- tryTicket $ remoteFollowTarget rf
|
||||
when (isRight r) $ delete rfid
|
||||
return $ either id id r
|
||||
where
|
||||
insertActivity luUndo = do
|
||||
let iidAuthor = remoteAuthorInstance author
|
||||
roid <-
|
||||
either entityKey id <$> insertBy' (RemoteObject iidAuthor luUndo)
|
||||
let jsonObj = persistJSONFromBL $ actbBL body
|
||||
ract = RemoteActivity roid jsonObj now
|
||||
either entityKey id <$> insertBy' ract
|
||||
deleteRemoteFollow idRecip fsidRecip = do
|
||||
let iidAuthor = remoteAuthorInstance author
|
||||
mractidObj <- runMaybeT $ do
|
||||
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iidAuthor luObj
|
||||
MaybeT $ getKeyBy $ UniqueRemoteActivity roid
|
||||
case mractidObj of
|
||||
Nothing -> return $ Just "Undo object isn't a known activity"
|
||||
Just ractidObj -> do
|
||||
merf <- getBy $ UniqueRemoteFollowFollow ractidObj
|
||||
case merf of
|
||||
Nothing -> return $ Just "Undo object doesn't match an active RemoteFollow"
|
||||
Just (Entity rfid rf)
|
||||
| remoteFollowActor rf /= remoteAuthorId author ->
|
||||
return $ Just "Undo sent by different actor than the one who sent the Follow"
|
||||
| remoteFollowTarget rf == fsidRecip -> do
|
||||
delete rfid
|
||||
return Nothing
|
||||
| otherwise -> do
|
||||
mr <- trySubObjects idRecip (remoteFollowTarget rf)
|
||||
when (isNothing mr) $ delete rfid
|
||||
return mr
|
||||
insertToInbox ibidRecip ractid = do
|
||||
ibiid <- insert $ InboxItem False
|
||||
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
|
||||
case mibrid of
|
||||
Nothing -> do
|
||||
delete ibiid
|
||||
return False
|
||||
Just _ -> return True
|
||||
tryTicket fsid = do
|
||||
mltid <- getKeyBy $ UniqueLocalTicketFollowers fsid
|
||||
case mltid of
|
||||
Nothing -> return $ Left "Undo object is a RemoteFollow, but not for me and not for a ticket"
|
||||
Just ltid -> do
|
||||
wi <- getWorkItem ltid
|
||||
return $
|
||||
if myWorkItem wi
|
||||
then Right "Undo applied to RemoteFollow of my ticket"
|
||||
else Left "Undo is of RemoteFollow of a ticket that isn't mine"
|
||||
|
||||
insertAcceptOnUndo actor author luUndo obiid auds = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience auds
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $ actorOutboxItem actor obikhid
|
||||
, activityActor = encodeRouteLocal $ renderLocalActor actor
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hAuthor luUndo
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
where
|
||||
actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr
|
||||
actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
|
||||
actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp
|
||||
|
||||
sharerUndoF
|
||||
:: ShrIdent
|
||||
|
|
@ -610,32 +615,88 @@ sharerUndoF
|
|||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
sharerUndoF shr =
|
||||
undoF
|
||||
(SharerR shr)
|
||||
getRecip
|
||||
personInbox
|
||||
personFollowers
|
||||
tryTicket
|
||||
sharerUndoF shrRecip now author body mfwd luUndo (Undo uObj) = do
|
||||
object <- parseActivity uObj
|
||||
mmmhttp <- runDBExcept $ do
|
||||
p <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
getValBy404 $ UniquePersonIdent sid
|
||||
mractid <- lift $ insertToInbox now author body (personInbox p) luUndo True
|
||||
for mractid $ \ ractid -> do
|
||||
mobject' <- getActivity object
|
||||
lift $ for mobject' $ \ object' -> do
|
||||
mobject'' <- runMaybeT $
|
||||
Left <$> MaybeT (getFollow object') <|>
|
||||
Right <$> MaybeT (getResolve object')
|
||||
for mobject'' $ \ object'' -> do
|
||||
(result, mfwdColl, macceptAuds) <-
|
||||
case object'' of
|
||||
Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (personFollowers p) erf
|
||||
Right tr -> deleteResolve myWorkItem prepareAccept tr
|
||||
mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
|
||||
let sieve = makeRecipientSet [] colls
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False ractid $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent p) sig remoteRecips
|
||||
mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
|
||||
obiidAccept <- insertEmptyOutboxItem (personOutbox p) now
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptOnUndo (LocalActorSharer shrRecip) author luUndo obiidAccept acceptAuds
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorSharer shrRecip)
|
||||
(personInbox p)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mmmhttp of
|
||||
Nothing -> return "Activity already in my inbox"
|
||||
Just mmhttp ->
|
||||
case mmhttp of
|
||||
Nothing -> return "Undo object isn't a known activity"
|
||||
Just mhttp ->
|
||||
case mhttp of
|
||||
Nothing -> return "Undo object isn't in use"
|
||||
Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "sharerUndoF inbox-forwarding" $
|
||||
deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes
|
||||
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
|
||||
forkWorker "sharerUndoF Accept HTTP delivery" $
|
||||
deliverRemoteHttp' fwdHosts obiid doc remotes
|
||||
let fwdMsg =
|
||||
case mremotesHttpFwd of
|
||||
Nothing -> "No inbox-forwarding"
|
||||
Just _ -> "Did inbox-forwarding"
|
||||
acceptMsg =
|
||||
case mremotesHttpAccept of
|
||||
Nothing -> "Didn't send Accept"
|
||||
Just _ -> "Sent Accept"
|
||||
return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
|
||||
where
|
||||
getRecip = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
getBy404 $ UniquePersonIdent sid
|
||||
tryTicket pid fsid = do
|
||||
mltid <- getKeyBy $ UniqueLocalTicketFollowers fsid
|
||||
case mltid of
|
||||
Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this sharer"
|
||||
Just ltid -> do
|
||||
mtal <- getBy $ UniqueTicketAuthorLocal ltid
|
||||
case mtal of
|
||||
Just (Entity talid tal)
|
||||
| ticketAuthorLocalAuthor tal == pid -> do
|
||||
mtup <- getBy $ UniqueTicketUnderProjectAuthor talid
|
||||
return $
|
||||
case mtup of
|
||||
Nothing -> Nothing
|
||||
Just _ -> Just "Undo object is a RemoteFollow of a ticket authored by this sharer, but is hosted by the project"
|
||||
_ -> return $ Just "Undo object is a RemoteFollow of a ticket of another author"
|
||||
myWorkItem (WorkItemSharerTicket shr talid patch)
|
||||
| shr == shrRecip = Just (talid, patch)
|
||||
myWorkItem _ = Nothing
|
||||
|
||||
prepareAccept (talid, patch) = do
|
||||
talkhid <- encodeKeyHashid talid
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
ticketFollowers =
|
||||
if patch
|
||||
then LocalPersonCollectionSharerPatchFollowers shrRecip talkhid
|
||||
else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
audTicket =
|
||||
AudLocal [] [ticketFollowers]
|
||||
return ([ticketFollowers], [audAuthor, audTicket])
|
||||
|
||||
projectUndoF
|
||||
:: ShrIdent
|
||||
|
|
@ -647,35 +708,86 @@ projectUndoF
|
|||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
projectUndoF shr prj =
|
||||
undoF
|
||||
(ProjectR shr prj)
|
||||
getRecip
|
||||
projectInbox
|
||||
projectFollowers
|
||||
tryTicket
|
||||
projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do
|
||||
object <- parseActivity uObj
|
||||
mmmhttp <- runDBExcept $ do
|
||||
Entity jid j <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
getBy404 $ UniqueProject prjRecip sid
|
||||
mractid <- lift $ insertToInbox now author body (projectInbox j) luUndo False
|
||||
for mractid $ \ ractid -> do
|
||||
mobject' <- getActivity object
|
||||
lift $ for mobject' $ \ object' -> do
|
||||
mobject'' <- runMaybeT $
|
||||
Left <$> MaybeT (getFollow object') <|>
|
||||
Right <$> MaybeT (getResolve object')
|
||||
for mobject'' $ \ object'' -> do
|
||||
(result, mfwdColl, macceptAuds) <-
|
||||
case object'' of
|
||||
Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (projectFollowers j) erf
|
||||
Right tr -> deleteResolve myWorkItem prepareAccept tr
|
||||
mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
|
||||
let sieve = makeRecipientSet [] colls
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False ractid $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
|
||||
mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
|
||||
obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptOnUndo (LocalActorProject shrRecip prjRecip) author luUndo obiidAccept acceptAuds
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorProject shrRecip prjRecip)
|
||||
(projectInbox j)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mmmhttp of
|
||||
Nothing -> return "Activity already in my inbox"
|
||||
Just mmhttp ->
|
||||
case mmhttp of
|
||||
Nothing -> return "Undo object isn't a known activity"
|
||||
Just mhttp ->
|
||||
case mhttp of
|
||||
Nothing -> return "Undo object isn't in use"
|
||||
Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "projectUndoF inbox-forwarding" $
|
||||
deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
|
||||
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
|
||||
forkWorker "projectUndoF Accept HTTP delivery" $
|
||||
deliverRemoteHttp' fwdHosts obiid doc remotes
|
||||
let fwdMsg =
|
||||
case mremotesHttpFwd of
|
||||
Nothing -> "No inbox-forwarding"
|
||||
Just _ -> "Did inbox-forwarding"
|
||||
acceptMsg =
|
||||
case mremotesHttpAccept of
|
||||
Nothing -> "Didn't send Accept"
|
||||
Just _ -> "Sent Accept"
|
||||
return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
|
||||
where
|
||||
getRecip = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
getBy404 $ UniqueProject prj sid
|
||||
tryTicket jid fsid = do
|
||||
mlt <- getValBy $ UniqueLocalTicketFollowers fsid
|
||||
case mlt of
|
||||
Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this project"
|
||||
Just lt -> do
|
||||
mtpl <- runMaybeT $ do
|
||||
tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt
|
||||
tpl <- MaybeT $ getValBy $ UniqueTicketProjectLocal tclid
|
||||
return (tclid, tpl)
|
||||
case mtpl of
|
||||
Just (tclid, tpl)
|
||||
| ticketProjectLocalProject tpl == jid -> do
|
||||
mtup <- getBy $ UniqueTicketUnderProjectProject tclid
|
||||
return $
|
||||
case mtup of
|
||||
Nothing -> Just "Undo object is a RemoteFollow of a ticket under this project, but is hosted by the author"
|
||||
Just _ -> Nothing
|
||||
_ -> return $ Just "Undo object is a RemoteFollow of a ticket of another project"
|
||||
myWorkItem (WorkItemProjectTicket shr prj ltid)
|
||||
| shr == shrRecip && prj == prjRecip = Just ltid
|
||||
myWorkItem _ = Nothing
|
||||
|
||||
prepareAccept ltid = do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
ticketFollowers =
|
||||
LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
audTicket =
|
||||
AudLocal [] [ticketFollowers]
|
||||
return ([ticketFollowers], [audAuthor, audTicket])
|
||||
|
||||
repoUndoF
|
||||
:: ShrIdent
|
||||
|
|
@ -687,32 +799,83 @@ repoUndoF
|
|||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
repoUndoF shr rp =
|
||||
undoF
|
||||
(RepoR shr rp)
|
||||
getRecip
|
||||
repoInbox
|
||||
repoFollowers
|
||||
tryPatch
|
||||
repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do
|
||||
object <- parseActivity uObj
|
||||
mmmhttp <- runDBExcept $ do
|
||||
Entity rid r <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
getBy404 $ UniqueRepo rpRecip sid
|
||||
mractid <- lift $ insertToInbox now author body (repoInbox r) luUndo False
|
||||
for mractid $ \ ractid -> do
|
||||
mobject' <- getActivity object
|
||||
lift $ for mobject' $ \ object' -> do
|
||||
mobject'' <- runMaybeT $
|
||||
Left <$> MaybeT (getFollow object') <|>
|
||||
Right <$> MaybeT (getResolve object')
|
||||
for mobject'' $ \ object'' -> do
|
||||
(result, mfwdColl, macceptAuds) <-
|
||||
case object'' of
|
||||
Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (repoFollowers r) erf
|
||||
Right tr -> deleteResolve myWorkItem prepareAccept tr
|
||||
mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
|
||||
let sieve = makeRecipientSet [] colls
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False ractid $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
|
||||
mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
|
||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptOnUndo (LocalActorRepo shrRecip rpRecip) author luUndo obiidAccept acceptAuds
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorRepo shrRecip rpRecip)
|
||||
(repoInbox r)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mmmhttp of
|
||||
Nothing -> return "Activity already in my inbox"
|
||||
Just mmhttp ->
|
||||
case mmhttp of
|
||||
Nothing -> return "Undo object isn't a known activity"
|
||||
Just mhttp ->
|
||||
case mhttp of
|
||||
Nothing -> return "Undo object isn't in use"
|
||||
Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "repoUndoF inbox-forwarding" $
|
||||
deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
|
||||
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
|
||||
forkWorker "repoUndoF Accept HTTP delivery" $
|
||||
deliverRemoteHttp' fwdHosts obiid doc remotes
|
||||
let fwdMsg =
|
||||
case mremotesHttpFwd of
|
||||
Nothing -> "No inbox-forwarding"
|
||||
Just _ -> "Did inbox-forwarding"
|
||||
acceptMsg =
|
||||
case mremotesHttpAccept of
|
||||
Nothing -> "Didn't send Accept"
|
||||
Just _ -> "Sent Accept"
|
||||
return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
|
||||
where
|
||||
getRecip = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
getBy404 $ UniqueRepo rp sid
|
||||
tryPatch rid fsid = do
|
||||
mlt <- getValBy $ UniqueLocalTicketFollowers fsid
|
||||
case mlt of
|
||||
Nothing -> return $ Just "Undo object is a RemoteFollow, but isn't under this repo"
|
||||
Just lt -> do
|
||||
mtrl <- runMaybeT $ do
|
||||
tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt
|
||||
trl <- MaybeT $ getValBy $ UniqueTicketRepoLocal tclid
|
||||
return (tclid, trl)
|
||||
case mtrl of
|
||||
Just (tclid, trl)
|
||||
| ticketRepoLocalRepo trl == rid -> do
|
||||
mtup <- getBy $ UniqueTicketUnderProjectProject tclid
|
||||
return $
|
||||
case mtup of
|
||||
Nothing -> Just "Undo object is a RemoteFollow of a patch under this repo, but is hosted by the author"
|
||||
Just _ -> Nothing
|
||||
_ -> return $ Just "Undo object is a RemoteFollow of a ticket of another project"
|
||||
myWorkItem (WorkItemRepoPatch shr rp ltid)
|
||||
| shr == shrRecip && rp == rpRecip = Just ltid
|
||||
myWorkItem _ = Nothing
|
||||
|
||||
prepareAccept ltid = do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
ticketFollowers =
|
||||
LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
audTicket =
|
||||
AudLocal [] [ticketFollowers]
|
||||
return ([ticketFollowers], [audAuthor, audTicket])
|
||||
|
|
|
|||
|
|
@ -256,8 +256,6 @@ insertLocalTicket now author txl summary content source ractidOffer obiidAccept
|
|||
, ticketDescription = unTextHtml content
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
}
|
||||
ltid <- insert LocalTicket
|
||||
{ localTicketTicket = tid
|
||||
|
|
@ -804,8 +802,6 @@ insertRemoteTicket mktxl author luTicket published summary content source ractid
|
|||
, ticketDescription = unTextHtml content
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
}
|
||||
tclid <- insert TicketContextLocal
|
||||
{ ticketContextLocalTicket = tid
|
||||
|
|
|
|||
|
|
@ -156,8 +156,6 @@ editTicketContentAForm ticket = Ticket
|
|||
<*> pure (ticketDescription ticket)
|
||||
<*> pure (ticketAssignee ticket)
|
||||
<*> pure (ticketStatus ticket)
|
||||
<*> pure (ticketClosed ticket)
|
||||
<*> pure (ticketCloser ticket)
|
||||
|
||||
tEditField
|
||||
:: TicketTextParam
|
||||
|
|
|
|||
|
|
@ -34,6 +34,8 @@ module Vervis.Handler.Client
|
|||
, postNotificationsR
|
||||
|
||||
, postProjectTicketsR
|
||||
, postProjectTicketCloseR
|
||||
, postProjectTicketOpenR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -90,6 +92,7 @@ import Vervis.Model.Ident
|
|||
import Vervis.Model.Repo
|
||||
import Vervis.Path
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
|
||||
import qualified Vervis.Client as C
|
||||
import qualified Vervis.Darcs as D
|
||||
|
|
@ -244,6 +247,12 @@ getUser = do
|
|||
s <- runDB $ getJust $ personIdent p
|
||||
return (sharerIdent s, pid)
|
||||
|
||||
getUser' :: Handler (Entity Person, Sharer)
|
||||
getUser' = do
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
s <- runDB $ getJust $ personIdent p
|
||||
return (ep, s)
|
||||
|
||||
getUserShrIdent :: Handler ShrIdent
|
||||
getUserShrIdent = fst <$> getUser
|
||||
|
||||
|
|
@ -305,8 +314,10 @@ postSharerOutboxR shr = do
|
|||
OfferDep dep ->
|
||||
offerDepC eperson sharer summary audience dep target
|
||||
_ -> throwE "Unsupported Offer 'object' type"
|
||||
ResolveActivity resolve ->
|
||||
resolveC eperson sharer summary audience resolve
|
||||
UndoActivity undo ->
|
||||
undoC shr summary audience undo
|
||||
undoC eperson sharer summary audience undo
|
||||
_ -> throwE "Unsupported activity type"
|
||||
|
||||
postPublishR :: Handler Html
|
||||
|
|
@ -572,41 +583,45 @@ setUnfollowMessage shr (Right obiid) = do
|
|||
|
||||
postSharerUnfollowR :: ShrIdent -> Handler ()
|
||||
postSharerUnfollowR shrFollowee = do
|
||||
(shrAuthor, pidAuthor) <- getUser
|
||||
(ep@(Entity pid _), s) <- getUser'
|
||||
let shrAuthor = sharerIdent s
|
||||
eid <- runExceptT $ do
|
||||
(summary, audience, undo) <-
|
||||
ExceptT $ undoFollowSharer shrAuthor pidAuthor shrFollowee
|
||||
undoC shrAuthor (Just summary) audience undo
|
||||
ExceptT $ undoFollowSharer shrAuthor pid shrFollowee
|
||||
undoC ep s (Just summary) audience undo
|
||||
setUnfollowMessage shrAuthor eid
|
||||
redirect $ SharerR shrFollowee
|
||||
|
||||
postProjectUnfollowR :: ShrIdent -> PrjIdent -> Handler ()
|
||||
postProjectUnfollowR shrFollowee prjFollowee = do
|
||||
(shrAuthor, pidAuthor) <- getUser
|
||||
(ep@(Entity pid _), s) <- getUser'
|
||||
let shrAuthor = sharerIdent s
|
||||
eid <- runExceptT $ do
|
||||
(summary, audience, undo) <-
|
||||
ExceptT $ undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee
|
||||
undoC shrAuthor (Just summary) audience undo
|
||||
ExceptT $ undoFollowProject shrAuthor pid shrFollowee prjFollowee
|
||||
undoC ep s (Just summary) audience undo
|
||||
setUnfollowMessage shrAuthor eid
|
||||
redirect $ ProjectR shrFollowee prjFollowee
|
||||
|
||||
postProjectTicketUnfollowR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler ()
|
||||
postProjectTicketUnfollowR shrFollowee prjFollowee tkhidFollowee = do
|
||||
(shrAuthor, pidAuthor) <- getUser
|
||||
(ep@(Entity pid _), s) <- getUser'
|
||||
let shrAuthor = sharerIdent s
|
||||
eid <- runExceptT $ do
|
||||
(summary, audience, undo) <-
|
||||
ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee tkhidFollowee
|
||||
undoC shrAuthor (Just summary) audience undo
|
||||
ExceptT $ undoFollowTicket shrAuthor pid shrFollowee prjFollowee tkhidFollowee
|
||||
undoC ep s (Just summary) audience undo
|
||||
setUnfollowMessage shrAuthor eid
|
||||
redirect $ ProjectTicketR shrFollowee prjFollowee tkhidFollowee
|
||||
|
||||
postRepoUnfollowR :: ShrIdent -> RpIdent -> Handler ()
|
||||
postRepoUnfollowR shrFollowee rpFollowee = do
|
||||
(shrAuthor, pidAuthor) <- getUser
|
||||
(ep@(Entity pid _), s) <- getUser'
|
||||
let shrAuthor = sharerIdent s
|
||||
eid <- runExceptT $ do
|
||||
(summary, audience, undo) <-
|
||||
ExceptT $ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee
|
||||
undoC shrAuthor (Just summary) audience undo
|
||||
ExceptT $ undoFollowRepo shrAuthor pid shrFollowee rpFollowee
|
||||
undoC ep s (Just summary) audience undo
|
||||
setUnfollowMessage shrAuthor eid
|
||||
redirect $ RepoR shrFollowee rpFollowee
|
||||
|
||||
|
|
@ -836,3 +851,32 @@ postProjectTicketsR shr prj = do
|
|||
Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e
|
||||
Right _ -> setMessage "Ticket created."
|
||||
redirect $ ProjectTicketR shr prj ltkhid
|
||||
|
||||
postProjectTicketCloseR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
postProjectTicketCloseR shr prj ltkhid = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
s <- runDB $ getJust $ personIdent p
|
||||
let uTicket = encodeRouteHome $ ProjectTicketR shr prj ltkhid
|
||||
result <- runExceptT $ do
|
||||
(summary, audience, specific) <- ExceptT $ resolve (sharerIdent s) uTicket
|
||||
resolveC ep s summary audience specific
|
||||
case result of
|
||||
Left e -> setMessage $ toHtml $ "Error: " <> e
|
||||
Right _obiid -> setMessage "Ticket closed"
|
||||
redirect $ ProjectTicketR shr prj ltkhid
|
||||
|
||||
postProjectTicketOpenR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
postProjectTicketOpenR shr prj ltkhid = do
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
ltid <- decodeKeyHashid404 ltkhid
|
||||
s <- runDB $ getJust $ personIdent p
|
||||
result <- runExceptT $ do
|
||||
(summary, audience, specific) <- ExceptT $ unresolve (sharerIdent s) (WorkItemProjectTicket shr prj ltid)
|
||||
undoC ep s summary audience specific
|
||||
case result of
|
||||
Left e -> setMessage $ toHtml $ "Error: " <> e
|
||||
Right _obiid -> setMessage "Ticket reopened"
|
||||
redirect $ ProjectTicketR shr prj ltkhid
|
||||
|
|
|
|||
|
|
@ -23,8 +23,6 @@ module Vervis.Handler.Ticket
|
|||
, postProjectTicketR
|
||||
, getProjectTicketEditR
|
||||
, postProjectTicketAcceptR
|
||||
, postProjectTicketCloseR
|
||||
, postProjectTicketOpenR
|
||||
, postProjectTicketClaimR
|
||||
, postProjectTicketUnclaimR
|
||||
, getProjectTicketAssignR
|
||||
|
|
@ -299,7 +297,7 @@ getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Ty
|
|||
getProjectTicketR shar proj ltkhid = do
|
||||
mpid <- maybeAuthId
|
||||
( wshr, wfl,
|
||||
author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams) <-
|
||||
author, massignee, ticket, lticket, tparams, eparams, cparams) <-
|
||||
runDB $ do
|
||||
(Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author) <- getProjectTicket404 shar proj ltkhid
|
||||
(wshr, wid, wfl) <- do
|
||||
|
|
@ -327,24 +325,12 @@ getProjectTicketR shar proj ltkhid = do
|
|||
person <- get404 apid
|
||||
sharer <- get404 $ personIdent person
|
||||
return (sharer, fromMaybe False $ (== apid) <$> mpid)
|
||||
mcloser <-
|
||||
case ticketStatus ticket of
|
||||
TSClosed ->
|
||||
case ticketCloser ticket of
|
||||
Just pidCloser -> Just <$> do
|
||||
person <- getJust pidCloser
|
||||
getJust $ personIdent person
|
||||
Nothing -> error "Closer not set for closed ticket"
|
||||
_ ->
|
||||
case ticketCloser ticket of
|
||||
Just _ -> error "Closer set for open ticket"
|
||||
Nothing -> return Nothing
|
||||
tparams <- getTicketTextParams tid wid
|
||||
eparams <- getTicketEnumParams tid wid
|
||||
cparams <- getTicketClasses tid wid
|
||||
return
|
||||
( wshr, wfl
|
||||
, author', massignee, mcloser, ticket, lticket
|
||||
, author', massignee, ticket, lticket
|
||||
, tparams, eparams, cparams
|
||||
)
|
||||
encodeHid <- getEncodeKeyHashid
|
||||
|
|
@ -517,50 +503,6 @@ postProjectTicketAcceptR shr prj ltkhid = do
|
|||
else "Ticket is already accepted."
|
||||
redirect $ ProjectTicketR shr prj ltkhid
|
||||
|
||||
postProjectTicketCloseR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
postProjectTicketCloseR shr prj ltkhid = do
|
||||
pid <- requireAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
succ <- runDB $ do
|
||||
(_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
|
||||
case ticketStatus ticket of
|
||||
TSClosed -> return False
|
||||
_ -> do
|
||||
update tid
|
||||
[ TicketAssignee =. Nothing
|
||||
, TicketStatus =. TSClosed
|
||||
, TicketClosed =. now
|
||||
, TicketCloser =. Just pid
|
||||
]
|
||||
return True
|
||||
setMessage $
|
||||
if succ
|
||||
then "Ticket closed."
|
||||
else "Ticket is already closed."
|
||||
redirect $ ProjectTicketR shr prj ltkhid
|
||||
|
||||
postProjectTicketOpenR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
postProjectTicketOpenR shr prj ltkhid = do
|
||||
pid <- requireAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
succ <- runDB $ do
|
||||
(_es, _ej, Entity tid ticket, _elt, _etcl, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
|
||||
case ticketStatus ticket of
|
||||
TSClosed -> do
|
||||
update tid
|
||||
[ TicketStatus =. TSTodo
|
||||
, TicketCloser =. Nothing
|
||||
]
|
||||
return True
|
||||
_ -> return False
|
||||
setMessage $
|
||||
if succ
|
||||
then "Ticket reopened"
|
||||
else "Ticket is already open."
|
||||
redirect $ ProjectTicketR shr prj ltkhid
|
||||
|
||||
postProjectTicketClaimR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
postProjectTicketClaimR shr prj ltkhid = do
|
||||
|
|
|
|||
|
|
@ -1748,6 +1748,10 @@ changes hLocal ctx =
|
|||
obiidAccept <- insert $ OutboxItem276 obidHoster doc closed
|
||||
trid <- insert $ TicketResolve276 ltid obiidAccept
|
||||
insert_ $ TicketResolveLocal276 trid obiidResolve
|
||||
-- 277
|
||||
, removeField "Ticket" "closed"
|
||||
-- 278
|
||||
, removeField "Ticket" "closer"
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ module Vervis.WorkItem
|
|||
, getWorkItemAuthorDetail
|
||||
, askWorkItemFollowers
|
||||
, contextAudience
|
||||
, authorAudience
|
||||
, getWorkItemDetail
|
||||
, WorkItemTarget (..)
|
||||
)
|
||||
|
|
@ -133,6 +134,9 @@ contextAudience ctx =
|
|||
, AudRemote hProject [] (catMaybes [luFollowers, luTeam])
|
||||
]
|
||||
|
||||
authorAudience (Left shr) = AudLocal [LocalActorSharer shr] []
|
||||
authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] []
|
||||
|
||||
getWorkItemDetail
|
||||
:: Text -> Either WorkItem FedURI -> ExceptT Text Worker WorkItemDetail
|
||||
getWorkItemDetail name v = do
|
||||
|
|
|
|||
|
|
@ -1344,14 +1344,14 @@ encodeResolve :: UriMode u => Resolve u -> Series
|
|||
encodeResolve (Resolve obj) = "object" .= obj
|
||||
|
||||
data Undo u = Undo
|
||||
{ undoObject :: LocalURI
|
||||
{ undoObject :: ObjURI u
|
||||
}
|
||||
|
||||
parseUndo :: UriMode u => Authority u -> Object -> Parser (Undo u)
|
||||
parseUndo a o = Undo <$> withAuthorityO a (o .: "object")
|
||||
parseUndo a o = Undo <$> o .: "object"
|
||||
|
||||
encodeUndo :: UriMode u => Authority u -> Undo u -> Series
|
||||
encodeUndo a (Undo obj) = "object" .= ObjURI a obj
|
||||
encodeUndo a (Undo obj) = "object" .= obj
|
||||
|
||||
data SpecificActivity u
|
||||
= AcceptActivity (Accept u)
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ module Yesod.MonadSite
|
|||
, runWorkerT
|
||||
, WorkerFor
|
||||
, runWorker
|
||||
, runWorkerExcept
|
||||
, forkWorker
|
||||
, asyncWorker
|
||||
)
|
||||
|
|
@ -198,6 +199,10 @@ type WorkerFor site = WorkerT site IO
|
|||
runWorker :: (Yesod site, Site site) => WorkerFor site a -> site -> IO a
|
||||
runWorker = runWorkerT
|
||||
|
||||
runWorkerExcept action = do
|
||||
site <- askSite
|
||||
ExceptT $ liftIO $ runWorker (runExceptT action) site
|
||||
|
||||
forkWorker
|
||||
:: (MonadSite m, Yesod site, Site site, SiteEnv m ~ site)
|
||||
=> Text
|
||||
|
|
|
|||
|
|
@ -77,9 +77,7 @@ $if ticketStatus ticket /= TSClosed
|
|||
|
||||
^{buttonW POST "Close this ticket" (ProjectTicketCloseR shar proj ltkhid)}
|
||||
$of TSClosed
|
||||
Closed on #{showDate $ ticketClosed ticket}
|
||||
$maybe closer <- mcloser
|
||||
by ^{sharerLinkW closer}.
|
||||
Closed on ___ by ___.
|
||||
|
||||
^{buttonW POST "Reopen this ticket" (ProjectTicketOpenR shar proj ltkhid)}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue