Client: Add forms for resolving and unresolving a ticket/MR

src/Vervis/Client.hs

@@ -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
+    ticket <- parseWorkItem "Ticket" uTicket
-    ltid <-
+    WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Ticket" ticket
+    uResolve <-
         case ident of
-            Left (_, ltid) -> return ltid
+            Left (_, ltid) -> runSiteDBExcept $ do
-            Right _ -> error "Local WorkItem expected!"
+                mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid
-    uResolve <- runSiteDBExcept $ do
+                trid <- fromMaybeE mtrid "Ticket already isn't resolved"
-        mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid
+                trx <-
-        trid <- fromMaybeE mtrid "Ticket already isn't resolved"
+                    lift $
-        trx <-
+                    requireEitherAlt
-            lift $
+                        (getValBy $ UniqueTicketResolveLocal trid)
-            requireEitherAlt
+                        (getValBy $ UniqueTicketResolveRemote trid)
-                (getValBy $ UniqueTicketResolveLocal trid)
+                        "No TRX"
-                (getValBy $ UniqueTicketResolveRemote trid)
+                        "Both TRL and TRR"
-                "No TRX"
+                case trx of
-                "Both TRL and TRR"
+                    Left trl -> lift $ do
-        case trx of
+                        let obiid = ticketResolveLocalActivity trl
-            Left trl -> lift $ do
+                        obid <- outboxItemOutbox <$> getJust obiid
-                let obiid = ticketResolveLocalActivity trl
+                        ent <- getOutboxActorEntity obid
-                obid <- outboxItemOutbox <$> getJust obiid
+                        obikhid <- encodeKeyHashid obiid
-                ent <- getOutboxActorEntity obid
+                        encodeRouteHome . flip outboxItemRoute obikhid <$>
-                obikhid <- encodeKeyHashid obiid
+                            actorEntityPath ent
-                encodeRouteHome . flip outboxItemRoute obikhid <$>
+                    Right trr -> lift $ do
-                    actorEntityPath ent
+                        roid <-
-            Right trr -> lift $ do
+                            remoteActivityIdent <$>
-                roid <-
+                                getJust (ticketResolveRemoteActivity trr)
-                    remoteActivityIdent <$>
+                        ro <- getJust roid
-                        getJust (ticketResolveRemoteActivity trr)
+                        i <- getJust $ remoteObjectInstance ro
-                ro <- getJust roid
+                        return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
-                i <- getJust $ remoteObjectInstance ro
+            Right (u, _) -> do
-                return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
+                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 $

src/Vervis/Handler/Client.hs

@@ -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
+            =   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
     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_ ->
+        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 $
         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