Client: Add forms for resolving and unresolving a ticket/MR
This commit is contained in:
parent
5a0c46ad5c
commit
9f34106a87
2 changed files with 113 additions and 65 deletions
|
@ -483,17 +483,16 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee =
|
||||||
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
|
||||||
-> WorkItem
|
-> FedURI
|
||||||
-> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode))
|
-> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode))
|
||||||
unresolve shrUser wi = runExceptT $ do
|
unresolve shrUser uTicket = runExceptT $ do
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
wiFollowers <- askWorkItemFollowers
|
wiFollowers <- askWorkItemFollowers
|
||||||
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" $ Left wi
|
ticket <- parseWorkItem "Ticket" uTicket
|
||||||
ltid <-
|
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Ticket" ticket
|
||||||
|
uResolve <-
|
||||||
case ident of
|
case ident of
|
||||||
Left (_, ltid) -> return ltid
|
Left (_, ltid) -> runSiteDBExcept $ do
|
||||||
Right _ -> error "Local WorkItem expected!"
|
|
||||||
uResolve <- runSiteDBExcept $ do
|
|
||||||
mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid
|
mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid
|
||||||
trid <- fromMaybeE mtrid "Ticket already isn't resolved"
|
trid <- fromMaybeE mtrid "Ticket already isn't resolved"
|
||||||
trx <-
|
trx <-
|
||||||
|
@ -518,13 +517,22 @@ unresolve shrUser wi = runExceptT $ do
|
||||||
ro <- getJust roid
|
ro <- getJust roid
|
||||||
i <- getJust $ remoteObjectInstance ro
|
i <- getJust $ remoteObjectInstance ro
|
||||||
return $ ObjURI (instanceHost i) (remoteObjectIdent 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 =
|
let audAuthor =
|
||||||
AudLocal
|
AudLocal
|
||||||
[LocalActorSharer shrUser]
|
[LocalActorSharer shrUser]
|
||||||
[LocalPersonCollectionSharerFollowers shrUser]
|
[LocalPersonCollectionSharerFollowers shrUser]
|
||||||
audTicketContext = contextAudience context
|
audTicketContext = contextAudience context
|
||||||
audTicketAuthor = authorAudience author
|
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) =
|
(_, _, _, audLocal, audRemote) =
|
||||||
collectAudience $
|
collectAudience $
|
||||||
|
|
|
@ -211,14 +211,31 @@ followForm = renderDivs $ (,)
|
||||||
where
|
where
|
||||||
deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33"
|
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
|
activityWidget
|
||||||
:: Widget -> Enctype
|
:: Widget -> Enctype
|
||||||
-> Widget -> Enctype
|
-> Widget -> Enctype
|
||||||
-> Widget -> Enctype
|
-> Widget -> Enctype
|
||||||
-> Widget -> Enctype
|
-> Widget -> Enctype
|
||||||
|
-> Widget -> Enctype
|
||||||
|
-> Widget -> Enctype
|
||||||
-> Widget
|
-> Widget
|
||||||
activityWidget
|
activityWidget
|
||||||
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4 =
|
widget1 enctype1
|
||||||
|
widget2 enctype2
|
||||||
|
widget3 enctype3
|
||||||
|
widget4 enctype4
|
||||||
|
widget5 enctype5
|
||||||
|
widget6 enctype6 =
|
||||||
[whamlet|
|
[whamlet|
|
||||||
<h1>Publish a ticket comment
|
<h1>Publish a ticket comment
|
||||||
<form method=POST action=@{PublishR} enctype=#{enctype1}>
|
<form method=POST action=@{PublishR} enctype=#{enctype1}>
|
||||||
|
@ -239,6 +256,16 @@ activityWidget
|
||||||
<form method=POST action=@{PublishR} enctype=#{enctype4}>
|
<form method=POST action=@{PublishR} enctype=#{enctype4}>
|
||||||
^{widget4}
|
^{widget4}
|
||||||
<input type=submit>
|
<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)
|
getUser :: Handler (ShrIdent, PersonId)
|
||||||
|
@ -266,9 +293,18 @@ getPublishR = do
|
||||||
runFormPost $ identifyForm "f3" offerTicketForm
|
runFormPost $ identifyForm "f3" offerTicketForm
|
||||||
((_result4, widget4), enctype4) <-
|
((_result4, widget4), enctype4) <-
|
||||||
runFormPost $ identifyForm "f4" followForm
|
runFormPost $ identifyForm "f4" followForm
|
||||||
|
((_result5, widget5), enctype5) <-
|
||||||
|
runFormPost $ identifyForm "f5" resolveForm
|
||||||
|
((_result6, widget6), enctype6) <-
|
||||||
|
runFormPost $ identifyForm "f6" unresolveForm
|
||||||
defaultLayout $
|
defaultLayout $
|
||||||
activityWidget
|
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 :: ShrIdent -> Handler Text
|
||||||
postSharerOutboxR shr = do
|
postSharerOutboxR shr = do
|
||||||
|
@ -320,6 +356,14 @@ postSharerOutboxR shr = do
|
||||||
undoC eperson sharer summary audience undo
|
undoC eperson sharer summary audience undo
|
||||||
_ -> throwE "Unsupported activity type"
|
_ -> 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 :: Handler Html
|
||||||
postPublishR = do
|
postPublishR = do
|
||||||
federation <- getsYesod $ appFederation . appSettings
|
federation <- getsYesod $ appFederation . appSettings
|
||||||
|
@ -333,11 +377,17 @@ postPublishR = do
|
||||||
runFormPost $ identifyForm "f3" offerTicketForm
|
runFormPost $ identifyForm "f3" offerTicketForm
|
||||||
((result4, widget4), enctype4) <-
|
((result4, widget4), enctype4) <-
|
||||||
runFormPost $ identifyForm "f4" followForm
|
runFormPost $ identifyForm "f4" followForm
|
||||||
|
((result5, widget5), enctype5) <-
|
||||||
|
runFormPost $ identifyForm "f5" resolveForm
|
||||||
|
((result6, widget6), enctype6) <-
|
||||||
|
runFormPost $ identifyForm "f6" unresolveForm
|
||||||
let result
|
let result
|
||||||
= Left . Left <$> result1
|
= ResultPublishComment <$> result1
|
||||||
<|> Left . Right <$> result2
|
<|> ResultCreateTicket <$> result2
|
||||||
<|> Right . Left <$> result3
|
<|> ResultOfferTicket <$> result3
|
||||||
<|> Right . Right <$> result4
|
<|> ResultFollow <$> result4
|
||||||
|
<|> ResultResolve <$> result5
|
||||||
|
<|> ResultUnresolve <$> result6
|
||||||
|
|
||||||
ep@(Entity _ p) <- requireVerifiedAuth
|
ep@(Entity _ p) <- requireVerifiedAuth
|
||||||
s <- runDB $ getJust $ personIdent p
|
s <- runDB $ getJust $ personIdent p
|
||||||
|
@ -349,39 +399,28 @@ postPublishR = do
|
||||||
FormMissing -> throwE "Field(s) missing"
|
FormMissing -> throwE "Field(s) missing"
|
||||||
FormFailure _l -> throwE "Invalid input, see below"
|
FormFailure _l -> throwE "Invalid input, see below"
|
||||||
FormSuccess r -> return r
|
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
|
case eid of
|
||||||
Left err -> setMessage $ toHtml err
|
Left err -> setMessage $ toHtml err
|
||||||
Right id_ ->
|
Right _obiid -> setMessage "Activity published"
|
||||||
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!"
|
|
||||||
defaultLayout $
|
defaultLayout $
|
||||||
activityWidget
|
activityWidget
|
||||||
widget1 enctype1
|
widget1 enctype1
|
||||||
widget2 enctype2
|
widget2 enctype2
|
||||||
widget3 enctype3
|
widget3 enctype3
|
||||||
widget4 enctype4
|
widget4 enctype4
|
||||||
|
widget5 enctype5
|
||||||
|
widget6 enctype6
|
||||||
where
|
where
|
||||||
publishComment eperson sharer ((hTicket, shrTicket, prj, num), muParent, msg) = do
|
publishComment eperson sharer ((hTicket, shrTicket, prj, num), muParent, msg) = do
|
||||||
encodeRouteFed <- getEncodeRouteHome
|
encodeRouteFed <- getEncodeRouteHome
|
||||||
|
@ -870,11 +909,12 @@ postProjectTicketCloseR shr prj ltkhid = do
|
||||||
postProjectTicketOpenR
|
postProjectTicketOpenR
|
||||||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
|
||||||
postProjectTicketOpenR shr prj ltkhid = do
|
postProjectTicketOpenR shr prj ltkhid = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
ep@(Entity _ p) <- requireVerifiedAuth
|
ep@(Entity _ p) <- requireVerifiedAuth
|
||||||
ltid <- decodeKeyHashid404 ltkhid
|
|
||||||
s <- runDB $ getJust $ personIdent p
|
s <- runDB $ getJust $ personIdent p
|
||||||
|
let uTicket = encodeRouteHome $ ProjectTicketR shr prj ltkhid
|
||||||
result <- runExceptT $ do
|
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
|
undoC ep s summary audience specific
|
||||||
case result of
|
case result of
|
||||||
Left e -> setMessage $ toHtml $ "Error: " <> e
|
Left e -> setMessage $ toHtml $ "Error: " <> e
|
||||||
|
|
Loading…
Reference in a new issue