forge/Vervis
1
0
Fork 0
Code Pull requests Activity

GET ticket handlers: Provide 'resolvedBy', set to the Resolve activity's ID URI

Browse source
This commit is contained in:
fr33domlover 2020-08-05 12:43:04 +00:00
parent de5d24edca
commit 5a0c46ad5c
4 changed files with 119 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
src/Vervis/ActivityPub.hs
View file

@ -54,6 +54,10 @@ module Vervis.ActivityPub
, verifyContentTypeAP_E , verifyContentTypeAP_E
, parseActivity , parseActivity
, getActivity , getActivity
, ActorEntity (..)
, getOutboxActorEntity
, actorEntityPath
, outboxItemRoute
) )
where where
@ -105,7 +109,7 @@ import Yesod.HttpSignature
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest import Network.HTTP.Digest
import Web.ActivityPub hiding (Author (..), Ticket) import Web.ActivityPub hiding (Author (..), Ticket, Project, Repo)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.MonadSite import Yesod.MonadSite
import Yesod.FedURI import Yesod.FedURI
@ -1265,3 +1269,31 @@ getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do
iid <- MaybeT $ getKeyBy $ UniqueInstance h iid <- MaybeT $ getKeyBy $ UniqueInstance h
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu
MaybeT $ getKeyBy $ UniqueRemoteActivity roid MaybeT $ getKeyBy $ UniqueRemoteActivity roid
data ActorEntity
= ActorPerson (Entity Person)
| ActorProject (Entity Project)
| ActorRepo (Entity Repo)
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

26
src/Vervis/Client.hs
View file

@ -480,11 +480,6 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee =
repoFollowers <$> repoFollowers <$>
fromMaybeE mr "Unfollow target no such local repo" fromMaybeE mr "Unfollow target no such local repo"
data ActorEntity
= ActorPerson (Entity Person)
| ActorProject (Entity Project)
| ActorRepo (Entity Repo)
unresolve unresolve
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> ShrIdent => ShrIdent
@ -540,24 +535,3 @@ unresolve shrUser wi = runExceptT $ do
recips = map encodeRouteHome audLocal ++ audRemote recips = map encodeRouteHome audLocal ++ audRemote
return (Nothing, Audience recips [] [] [] [] [], Undo uResolve) 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

35
src/Vervis/Handler/Patch.hs
View file

@ -404,9 +404,9 @@ getRepoPatchesR shr rp = do
getRepoPatchR getRepoPatchR
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
getRepoPatchR shr rp ltkhid = do getRepoPatchR shr rp ltkhid = do
(ticket, ptid, trl, author, massignee) <- runDB $ do (ticket, ptid, trl, author, massignee, mresolved) <- runDB $ do
(_, _, Entity tid t, _, _, Entity _ trl, ta, _, ptid :| _) <- getRepoPatch404 shr rp ltkhid (_, _, Entity tid t, _, _, Entity _ trl, ta, tr, ptid :| _) <- getRepoPatch404 shr rp ltkhid
(,,,,) t ptid trl (,,,,,) t ptid trl
<$> bitraverse <$> bitraverse
(\ (Entity _ tal, _) -> do (\ (Entity _ tal, _) -> do
p <- getJust $ ticketAuthorLocalAuthor tal p <- getJust $ ticketAuthorLocalAuthor tal
@ -423,10 +423,30 @@ getRepoPatchR shr rp ltkhid = do
p <- getJust pidAssignee p <- getJust pidAssignee
getJust $ personIdent p getJust $ personIdent p
) )
<*> (for tr $ \ (_, etrx) ->
bitraverse
(\ (Entity _ trl) -> do
let obiid = ticketResolveLocalActivity trl
obid <- outboxItemOutbox <$> getJust obiid
ent <- getOutboxActorEntity obid
actor <- actorEntityPath ent
return (actor, obiid)
)
(\ (Entity _ trr) -> do
roid <-
remoteActivityIdent <$>
getJust (ticketResolveRemoteActivity trr)
ro <- getJust roid
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
etrx
)
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodePatchId <- getEncodeKeyHashid encodePatchId <- getEncodeKeyHashid
encodeObiid <- getEncodeKeyHashid
let host = let host =
case author of case author of
Left _ -> hLocal Left _ -> hLocal
@ -465,9 +485,12 @@ getRepoPatchR shr rp ltkhid = do
, AP.ticketAssignedTo = , AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent <$> massignee encodeRouteHome . SharerR . sharerIdent <$> massignee
, AP.ticketResolved = , AP.ticketResolved =
if ticketStatus ticket == TSClosed let u (Left (actor, obiid)) =
then Just (Nothing, Nothing) encodeRouteHome $
else Nothing outboxItemRoute actor $ encodeObiid obiid
u (Right (i, ro)) =
ObjURI (instanceHost i) (remoteObjectIdent ro)
in (,Nothing) . Just . u <$> mresolved
, AP.ticketAttachment = Just , AP.ticketAttachment = Just
( hLocal ( hLocal
, MergeRequest , MergeRequest

69
src/Vervis/Handler/Ticket.hs
View file

@ -297,9 +297,9 @@ getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Ty
getProjectTicketR shar proj ltkhid = do getProjectTicketR shar proj ltkhid = do
mpid <- maybeAuthId mpid <- maybeAuthId
( wshr, wfl, ( wshr, wfl,
author, massignee, ticket, lticket, tparams, eparams, cparams) <- author, massignee, mresolved, ticket, lticket, tparams, eparams, cparams) <-
runDB $ do runDB $ do
(Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author, _) <- getProjectTicket404 shar proj ltkhid (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author, resolved) <- getProjectTicket404 shar proj ltkhid
(wshr, wid, wfl) <- do (wshr, wid, wfl) <- do
w <- get404 $ projectWorkflow project w <- get404 $ projectWorkflow project
wsharer <- wsharer <-
@ -325,12 +325,30 @@ getProjectTicketR shar proj ltkhid = do
person <- get404 apid person <- get404 apid
sharer <- get404 $ personIdent person sharer <- get404 $ personIdent person
return (sharer, fromMaybe False $ (== apid) <$> mpid) return (sharer, fromMaybe False $ (== apid) <$> mpid)
mresolved <- for resolved $ \ (_, etrx) ->
bitraverse
(\ (Entity _ trl) -> do
let obiid = ticketResolveLocalActivity trl
obid <- outboxItemOutbox <$> getJust obiid
ent <- getOutboxActorEntity obid
actor <- actorEntityPath ent
return (actor, obiid)
)
(\ (Entity _ trr) -> do
roid <-
remoteActivityIdent <$>
getJust (ticketResolveRemoteActivity trr)
ro <- getJust roid
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
etrx
tparams <- getTicketTextParams tid wid tparams <- getTicketTextParams tid wid
eparams <- getTicketEnumParams tid wid eparams <- getTicketEnumParams tid wid
cparams <- getTicketClasses tid wid cparams <- getTicketClasses tid wid
return return
( wshr, wfl ( wshr, wfl
, author', massignee, ticket, lticket , author', massignee, mresolved, ticket, lticket
, tparams, eparams, cparams , tparams, eparams, cparams
) )
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
@ -352,6 +370,7 @@ getProjectTicketR shar proj ltkhid = do
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeKeyHashid <- getEncodeKeyHashid
let host = let host =
case author of case author of
Left _ -> hLocal Left _ -> hLocal
@ -394,9 +413,12 @@ getProjectTicketR shar proj ltkhid = do
, AP.ticketAssignedTo = , AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent . fst <$> massignee encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
, AP.ticketResolved = , AP.ticketResolved =
if ticketStatus ticket == TSClosed let u (Left (actor, obiid)) =
then Just (Nothing, Nothing) encodeRouteHome $
else Nothing outboxItemRoute actor $ encodeKeyHashid obiid
u (Right (i, ro)) =
ObjURI (instanceHost i) (remoteObjectIdent ro)
in (,Nothing) . Just . u <$> mresolved
, AP.ticketAttachment = Nothing , AP.ticketAttachment = Nothing
} }
provideHtmlAndAP' host ticketAP $ provideHtmlAndAP' host ticketAP $
@ -1051,9 +1073,9 @@ getSharerTicketsR =
getSharerTicketR getSharerTicketR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketR shr talkhid = do getSharerTicketR shr talkhid = do
(ticket, project, massignee) <- runDB $ do (ticket, project, massignee, mresolved) <- runDB $ do
(_, _, Entity _ t, tp, _) <- getSharerTicket404 shr talkhid (_, _, Entity _ t, tp, tr) <- getSharerTicket404 shr talkhid
(,,) t (,,,) t
<$> bitraverse <$> bitraverse
(\ (_, Entity _ tpl) -> do (\ (_, Entity _ tpl) -> do
j <- getJust $ ticketProjectLocalProject tpl j <- getJust $ ticketProjectLocalProject tpl
@ -1076,9 +1098,29 @@ getSharerTicketR shr talkhid = do
p <- getJust pidAssignee p <- getJust pidAssignee
getJust $ personIdent p getJust $ personIdent p
) )
<*> (for tr $ \ (_, etrx) ->
bitraverse
(\ (Entity _ trl) -> do
let obiid = ticketResolveLocalActivity trl
obid <- outboxItemOutbox <$> getJust obiid
ent <- getOutboxActorEntity obid
actor <- actorEntityPath ent
return (actor, obiid)
)
(\ (Entity _ trr) -> do
roid <-
remoteActivityIdent <$>
getJust (ticketResolveRemoteActivity trr)
ro <- getJust roid
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
etrx
)
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeKeyHashid <- getEncodeKeyHashid
let ticketAP = AP.Ticket let ticketAP = AP.Ticket
{ AP.ticketLocal = Just { AP.ticketLocal = Just
( hLocal ( hLocal
@ -1116,9 +1158,12 @@ getSharerTicketR shr talkhid = do
, AP.ticketAssignedTo = , AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent <$> massignee encodeRouteHome . SharerR . sharerIdent <$> massignee
, AP.ticketResolved = , AP.ticketResolved =
if ticketStatus ticket == TSClosed let u (Left (actor, obiid)) =
then Just (Nothing, Nothing) encodeRouteHome $
else Nothing outboxItemRoute actor $ encodeKeyHashid obiid
u (Right (i, ro)) =
ObjURI (instanceHost i) (remoteObjectIdent ro)
in (,Nothing) . Just . u <$> mresolved
, AP.ticketAttachment = Nothing , AP.ticketAttachment = Nothing
} }
provideHtmlAndAP ticketAP $ redirectToPrettyJSON here provideHtmlAndAP ticketAP $ redirectToPrettyJSON here