Client: Add forms for resolving and unresolving a ticket/MR
This commit is contained in:
fr33domlover
parent
5a0c46ad5c
commit
9f34106a87
2 changed files with 113 additions and 65 deletions
|
|
@ -483,48 +483,56 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee =
|
|||
unresolve
|
||||
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent
|
||||
-> WorkItem
|
||||
-> FedURI
|
||||
-> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode))
|
||||
unresolve shrUser wi = runExceptT $ do
|
||||
unresolve shrUser uTicket = runExceptT $ do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
wiFollowers <- askWorkItemFollowers
|
||||
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" $ Left wi
|
||||
ltid <-
|
||||
ticket <- parseWorkItem "Ticket" uTicket
|
||||
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Ticket" ticket
|
||||
uResolve <-
|
||||
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)
|
||||
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 = AudLocal [] [wiFollowers wi]
|
||||
audTicketFollowers =
|
||||
case ident of
|
||||
Left (wi, _ltid) -> AudLocal [] [wiFollowers wi]
|
||||
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
|
||||
|
||||
(_, _, _, audLocal, audRemote) =
|
||||
collectAudience $
|
||||
|
|
|
|||
|
|
@ -211,14 +211,31 @@ followForm = renderDivs $ (,)
|
|||
where
|
||||
deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33"
|
||||
|
||||
resolveForm :: Form FedURI
|
||||
resolveForm = renderDivs $ areq fedUriField "Ticket" (Just deft)
|
||||
where
|
||||
deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/p/sandbox/t/20YNl"
|
||||
|
||||
unresolveForm :: Form FedURI
|
||||
unresolveForm = renderDivs $ areq fedUriField "Ticket" (Just deft)
|
||||
where
|
||||
deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/p/sandbox/t/20YNl"
|
||||
|
||||
activityWidget
|
||||
:: Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget
|
||||
activityWidget
|
||||
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4 =
|
||||
widget1 enctype1
|
||||
widget2 enctype2
|
||||
widget3 enctype3
|
||||
widget4 enctype4
|
||||
widget5 enctype5
|
||||
widget6 enctype6 =
|
||||
[whamlet|
|
||||
<h1>Publish a ticket comment
|
||||
<form method=POST action=@{PublishR} enctype=#{enctype1}>
|
||||
|
|
@ -239,6 +256,16 @@ activityWidget
|
|||
<form method=POST action=@{PublishR} enctype=#{enctype4}>
|
||||
^{widget4}
|
||||
<input type=submit>
|
||||
|
||||
<h1>Resolve a ticket / MR
|
||||
<form method=POST action=@{PublishR} enctype=#{enctype5}>
|
||||
^{widget5}
|
||||
<input type=submit>
|
||||
|
||||
<h1>Unresolve a ticket / MR
|
||||
<form method=POST action=@{PublishR} enctype=#{enctype6}>
|
||||
^{widget6}
|
||||
<input type=submit>
|
||||
|]
|
||||
|
||||
getUser :: Handler (ShrIdent, PersonId)
|
||||
|
|
@ -266,9 +293,18 @@ getPublishR = do
|
|||
runFormPost $ identifyForm "f3" offerTicketForm
|
||||
((_result4, widget4), enctype4) <-
|
||||
runFormPost $ identifyForm "f4" followForm
|
||||
((_result5, widget5), enctype5) <-
|
||||
runFormPost $ identifyForm "f5" resolveForm
|
||||
((_result6, widget6), enctype6) <-
|
||||
runFormPost $ identifyForm "f6" unresolveForm
|
||||
defaultLayout $
|
||||
activityWidget
|
||||
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4
|
||||
widget1 enctype1
|
||||
widget2 enctype2
|
||||
widget3 enctype3
|
||||
widget4 enctype4
|
||||
widget5 enctype5
|
||||
widget6 enctype6
|
||||
|
||||
postSharerOutboxR :: ShrIdent -> Handler Text
|
||||
postSharerOutboxR shr = do
|
||||
|
|
@ -320,6 +356,14 @@ postSharerOutboxR shr = do
|
|||
undoC eperson sharer summary audience undo
|
||||
_ -> throwE "Unsupported activity type"
|
||||
|
||||
data Result
|
||||
= ResultPublishComment ((Host, ShrIdent, PrjIdent, KeyHashid LocalTicket), Maybe FedURI, Text)
|
||||
| ResultCreateTicket (FedURI, FedURI, TextHtml, TextPandocMarkdown)
|
||||
| ResultOfferTicket ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
|
||||
| ResultFollow (FedURI, FedURI)
|
||||
| ResultResolve FedURI
|
||||
| ResultUnresolve FedURI
|
||||
|
||||
postPublishR :: Handler Html
|
||||
postPublishR = do
|
||||
federation <- getsYesod $ appFederation . appSettings
|
||||
|
|
@ -333,11 +377,17 @@ postPublishR = do
|
|||
runFormPost $ identifyForm "f3" offerTicketForm
|
||||
((result4, widget4), enctype4) <-
|
||||
runFormPost $ identifyForm "f4" followForm
|
||||
((result5, widget5), enctype5) <-
|
||||
runFormPost $ identifyForm "f5" resolveForm
|
||||
((result6, widget6), enctype6) <-
|
||||
runFormPost $ identifyForm "f6" unresolveForm
|
||||
let result
|
||||
= Left . Left <$> result1
|
||||
<|> Left . Right <$> result2
|
||||
<|> Right . Left <$> result3
|
||||
<|> Right . Right <$> result4
|
||||
= ResultPublishComment <$> result1
|
||||
<|> ResultCreateTicket <$> result2
|
||||
<|> ResultOfferTicket <$> result3
|
||||
<|> ResultFollow <$> result4
|
||||
<|> ResultResolve <$> result5
|
||||
<|> ResultUnresolve <$> result6
|
||||
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
s <- runDB $ getJust $ personIdent p
|
||||
|
|
@ -349,39 +399,28 @@ postPublishR = do
|
|||
FormMissing -> throwE "Field(s) missing"
|
||||
FormFailure _l -> throwE "Invalid input, see below"
|
||||
FormSuccess r -> return r
|
||||
bitraverse (bitraverse (publishComment ep s) (publishTicket ep s)) (bitraverse (openTicket ep s) (follow shrAuthor)) input
|
||||
case input of
|
||||
ResultPublishComment v -> publishComment ep s v
|
||||
ResultCreateTicket v -> publishTicket ep s v
|
||||
ResultOfferTicket v -> openTicket ep s v
|
||||
ResultFollow v -> follow shrAuthor v
|
||||
ResultResolve u -> do
|
||||
(summary, audience, specific) <- ExceptT $ resolve shrAuthor u
|
||||
resolveC ep s summary audience specific
|
||||
ResultUnresolve u -> do
|
||||
(summary, audience, specific) <- ExceptT $ unresolve shrAuthor u
|
||||
undoC ep s summary audience specific
|
||||
case eid of
|
||||
Left err -> setMessage $ toHtml err
|
||||
Right id_ ->
|
||||
case id_ of
|
||||
Left (Left obiid) -> do
|
||||
mlmid <- runDB $ getKeyBy $ UniqueLocalMessageCreate obiid
|
||||
case mlmid of
|
||||
Nothing -> error "noteC succeeded but no lmid found for obiid"
|
||||
Just lmid -> do
|
||||
lmkhid <- encodeKeyHashid lmid
|
||||
renderUrl <- getUrlRender
|
||||
let u = renderUrl $ MessageR shrAuthor lmkhid
|
||||
setMessage $ toHtml $ "Message created! ID: " <> u
|
||||
Left (Right obiid) -> do
|
||||
mtalid <- runDB $ getKeyBy $ UniqueTicketAuthorLocalOpen obiid
|
||||
case mtalid of
|
||||
Nothing -> error "createTicketC succeeded but no talid found for obiid"
|
||||
Just talid -> do
|
||||
talkhid <- encodeKeyHashid talid
|
||||
renderUrl <- getUrlRender
|
||||
let u = renderUrl $ SharerTicketR shrAuthor talkhid
|
||||
setMessage $ toHtml $ "Ticket created! ID: " <> u
|
||||
Right (Left _obiid) ->
|
||||
setMessage "Ticket offer published!"
|
||||
Right (Right _obiid) ->
|
||||
setMessage "Follow request published!"
|
||||
Right _obiid -> setMessage "Activity published"
|
||||
defaultLayout $
|
||||
activityWidget
|
||||
widget1 enctype1
|
||||
widget2 enctype2
|
||||
widget3 enctype3
|
||||
widget4 enctype4
|
||||
widget5 enctype5
|
||||
widget6 enctype6
|
||||
where
|
||||
publishComment eperson sharer ((hTicket, shrTicket, prj, num), muParent, msg) = do
|
||||
encodeRouteFed <- getEncodeRouteHome
|
||||
|
|
@ -870,11 +909,12 @@ postProjectTicketCloseR shr prj ltkhid = do
|
|||
postProjectTicketOpenR
|
||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||
postProjectTicketOpenR shr prj ltkhid = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
ltid <- decodeKeyHashid404 ltkhid
|
||||
s <- runDB $ getJust $ personIdent p
|
||||
let uTicket = encodeRouteHome $ ProjectTicketR shr prj ltkhid
|
||||
result <- runExceptT $ do
|
||||
(summary, audience, specific) <- ExceptT $ unresolve (sharerIdent s) (WorkItemProjectTicket shr prj ltid)
|
||||
(summary, audience, specific) <- ExceptT $ unresolve (sharerIdent s) uTicket
|
||||
undoC ep s summary audience specific
|
||||
case result of
|
||||
Left e -> setMessage $ toHtml $ "Error: " <> e
|
||||
|
|
|
|||
Loading…
Reference in a new issue