Client: Port/implement pseudo-client for unresolve-a-ticket
This commit is contained in:
Pere Lev
parent
3a95e6d302
commit
ebe676d94b
1 changed files with 135 additions and 91 deletions
|
|
@ -26,11 +26,11 @@ module Vervis.Client
|
|||
--, followRepo
|
||||
, offerIssue
|
||||
, resolve
|
||||
, unresolve
|
||||
--, undoFollowSharer
|
||||
--, undoFollowProject
|
||||
--, undoFollowTicket
|
||||
--, undoFollowRepo
|
||||
--, unresolve
|
||||
, offerPatches
|
||||
, offerMerge
|
||||
, applyPatches
|
||||
|
|
@ -92,10 +92,13 @@ import Vervis.Data.Ticket
|
|||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Recipient
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Recipient (Aud (..), LocalStageBy (..), collectAudience, renderLocalActor, localActorFollowers)
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Ticket
|
||||
|
||||
import qualified Vervis.Recipient as VR
|
||||
|
||||
makeServerInput
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> Maybe FedURI
|
||||
|
|
@ -370,28 +373,26 @@ resolve
|
|||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Resolve URIMode)
|
||||
resolve senderHash uObject = do
|
||||
|
||||
manager <- asksSite appHttpManager
|
||||
AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left uObject)
|
||||
uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context"
|
||||
audFollowers <- do
|
||||
(hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id"
|
||||
let luFollowers = AP.ticketParticipants tl
|
||||
routeOrRemote <- parseFedURIOld $ ObjURI hFollowers luFollowers
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
(uTracker, audFollowers) <- do
|
||||
routeOrRemote <- parseFedURIOld uObject
|
||||
case routeOrRemote of
|
||||
Left route ->
|
||||
case route of
|
||||
TicketFollowersR d t ->
|
||||
return $
|
||||
AudLocal
|
||||
[]
|
||||
[LocalStageTicketFollowers d t]
|
||||
ClothFollowersR l c ->
|
||||
return $
|
||||
AudLocal
|
||||
[]
|
||||
[LocalStageClothFollowers l c]
|
||||
_ -> throwE "Not a tickets followers route"
|
||||
Right u@(ObjURI h lu) -> return $ AudRemote h [] [lu]
|
||||
Left route -> do
|
||||
wih <- fromMaybeE (parseWorkItem route) "Not a work item route"
|
||||
wi <- runActE $ unhashWorkItemE wih "Work item invalid keyhashid"
|
||||
let uTracker =
|
||||
encodeRouteHome $ renderLocalActor $ workItemActor wih
|
||||
audFollowers = AudLocal [] [workItemFollowers wih]
|
||||
return (uTracker, audFollowers)
|
||||
Right u -> do
|
||||
manager <- asksSite appHttpManager
|
||||
AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left u)
|
||||
uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context"
|
||||
audFollowers <- do
|
||||
(hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id"
|
||||
let luFollowers = AP.ticketParticipants tl
|
||||
return $ AudRemote hFollowers [] [luFollowers]
|
||||
return (uTracker, audFollowers)
|
||||
|
||||
tracker <- do
|
||||
tracker <- runActE $ checkTracker uTracker
|
||||
|
|
@ -428,6 +429,116 @@ resolve senderHash uObject = do
|
|||
|
||||
return (Nothing, audience, AP.Resolve uObject)
|
||||
|
||||
unresolve
|
||||
:: KeyHashid Person
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Undo URIMode)
|
||||
unresolve senderHash uTicket = do
|
||||
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
(uTracker, audFollowers, uResolve) <- do
|
||||
routeOrRemote <- parseFedURIOld uTicket
|
||||
case routeOrRemote of
|
||||
Left route -> do
|
||||
wih <- fromMaybeE (parseWorkItem route) "Not a work item route"
|
||||
wi <- runActE $ unhashWorkItemE wih "Work item invalid keyhashid"
|
||||
let uTracker =
|
||||
encodeRouteHome $ renderLocalActor $ workItemActor wih
|
||||
audFollowers = AudLocal [] [workItemFollowers wih]
|
||||
resolved <- runDBExcept $ do
|
||||
mresolved <-
|
||||
case wi of
|
||||
WorkItemTicket d t -> do
|
||||
(_, _, _, _, mresolved) <- do
|
||||
mt <- lift $ getTicket d t
|
||||
fromMaybeE mt "No such ticket in DB"
|
||||
return mresolved
|
||||
WorkItemCloth l c -> do
|
||||
(_, _, _, _, mresolved, _) <- do
|
||||
mc <- lift $ getCloth l c
|
||||
fromMaybeE mc "No such MR in DB"
|
||||
return mresolved
|
||||
(_, etrx) <- fromMaybeE mresolved "Ticket not resolved"
|
||||
lift $ bitraverse
|
||||
(\ (Entity _ trl) -> do
|
||||
let obiid = ticketResolveLocalActivity trl
|
||||
obid <- outboxItemOutbox <$> getJust obiid
|
||||
actorID <- do
|
||||
maybeActorID <- getKeyBy $ UniqueActorOutbox obid
|
||||
case maybeActorID of
|
||||
Nothing -> error "Found outbox not used by any actor"
|
||||
Just a -> return a
|
||||
actor <- getLocalActor actorID
|
||||
return (actor, obiid)
|
||||
)
|
||||
(\ (Entity _ trr) -> do
|
||||
roid <-
|
||||
remoteActivityIdent <$>
|
||||
getJust (ticketResolveRemoteActivity trr)
|
||||
ro <- getJust roid
|
||||
i <- getJust $ remoteObjectInstance ro
|
||||
return (i, ro)
|
||||
)
|
||||
etrx
|
||||
hashItem <- getEncodeKeyHashid
|
||||
hashActor <- VR.getHashLocalActor
|
||||
let uResolve =
|
||||
case resolved of
|
||||
Left (actor, obiid) ->
|
||||
encodeRouteHome $
|
||||
activityRoute (hashActor actor) (hashItem obiid)
|
||||
Right (i, ro) ->
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
return (uTracker, audFollowers, uResolve)
|
||||
Right u -> do
|
||||
manager <- asksSite appHttpManager
|
||||
AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left u)
|
||||
uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context"
|
||||
audFollowers <- do
|
||||
(hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id"
|
||||
let luFollowers = AP.ticketParticipants tl
|
||||
return $ AudRemote hFollowers [] [luFollowers]
|
||||
uResolve <-
|
||||
case AP.ticketResolved t of
|
||||
Just (Just u, _) -> return u
|
||||
_ -> throwE "No ticket resolve URI specified"
|
||||
return (uTracker, audFollowers, uResolve)
|
||||
|
||||
tracker <- do
|
||||
tracker <- runActE $ checkTracker uTracker
|
||||
case tracker of
|
||||
TrackerDeck deckID -> Left . Left <$> encodeKeyHashid deckID
|
||||
TrackerLoom loomID -> Left . Right <$> encodeKeyHashid loomID
|
||||
TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do
|
||||
instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker)
|
||||
result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker
|
||||
case result of
|
||||
Left Nothing -> throwE "Tracker @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Tracker isn't an actor"
|
||||
Right (Just actor) -> return (entityVal actor, uTracker)
|
||||
|
||||
let audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
audTracker =
|
||||
case tracker of
|
||||
Left (Left deckHash) ->
|
||||
AudLocal
|
||||
[LocalActorDeck deckHash]
|
||||
[LocalStageDeckFollowers deckHash]
|
||||
Left (Right loomHash) ->
|
||||
AudLocal
|
||||
[LocalActorLoom loomHash]
|
||||
[LocalStageLoomFollowers loomHash]
|
||||
Right (remoteActor, ObjURI hTracker luTracker) ->
|
||||
AudRemote hTracker
|
||||
[luTracker]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
|
||||
audience = [audAuthor, audTracker, audFollowers]
|
||||
|
||||
return (Nothing, audience, AP.Undo uResolve)
|
||||
|
||||
{-
|
||||
undoFollow
|
||||
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
|
|
@ -568,73 +679,6 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee =
|
|||
repoFollowers <$>
|
||||
fromMaybeE mr "Unfollow target no such local repo"
|
||||
-}
|
||||
|
||||
unresolve
|
||||
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent
|
||||
-> FedURI
|
||||
-> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode))
|
||||
unresolve shrUser uTicket = runExceptT $ do
|
||||
error "Temporarily disabled"
|
||||
{-
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
wiFollowers <- askWorkItemFollowers
|
||||
ticket <- parseWorkItem "Ticket" uTicket
|
||||
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Ticket" ticket
|
||||
uResolve <-
|
||||
case ident of
|
||||
Left (_, ltid) -> 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)
|
||||
Right (u, _) -> do
|
||||
manager <- asksSite appHttpManager
|
||||
Doc _ t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
|
||||
case ticketResolved t of
|
||||
Nothing -> throwE "Ticket already isn't resolved"
|
||||
Just (muBy, _) -> fromMaybeE muBy "Ticket doesn't specify 'resolvedBy'"
|
||||
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 [] [] [] [] [], Undo uResolve)
|
||||
-}
|
||||
-}
|
||||
|
||||
offerPatches
|
||||
|
|
@ -1315,7 +1359,7 @@ acceptProjectInvite personID component project uInvite = do
|
|||
encodeRouteHome <- getEncodeRouteHome
|
||||
theater <- asksSite appTheater
|
||||
env <- asksSite appEnv
|
||||
component' <- Vervis.Recipient.hashLocalActor component
|
||||
component' <- VR.hashLocalActor component
|
||||
project' <- bitraverse encodeKeyHashid pure project
|
||||
|
||||
let activity = AP.Accept uInvite Nothing
|
||||
|
|
|
|||
Loading…
Reference in a new issue