diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 727cfd9..1e80c76 100644 --- a/src/Vervis/Client.hs +++ b/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 - 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 $ diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index cb2be74..8282364 100644 --- a/src/Vervis/Handler/Client.hs +++ b/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|

Publish a ticket comment
@@ -239,6 +256,16 @@ activityWidget ^{widget4} + +

Resolve a ticket / MR + + ^{widget5} + + +

Unresolve a ticket / MR + + ^{widget6} + |] 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