diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index bcebe91..1c179d2 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -659,7 +659,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , TextPandocMarkdown ) checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary - content source muAssigned resolved mmr) = do + content source muAssigned mresolved mmr) = do verifyNothingE mlocal "Ticket with 'id'" encodeRouteLocal <- getEncodeRouteLocal unless (encodeRouteLocal (SharerR shr) == attrib) $ @@ -669,7 +669,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT uContext <- fromMaybeE muContext "Ticket without 'context'" context <- checkTracker "Ticket context" uContext verifyNothingE muAssigned "Ticket with 'assignedTo'" - when resolved $ throwE "Ticket resolved" + when (isJust mresolved) $ throwE "Ticket resolved" mmr' <- traverse (uncurry checkMR) mmr context' <- matchContextAndMR context mmr' return (context', summary, content, source) @@ -1005,7 +1005,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , AP.ticketContent = desc , AP.ticketSource = source , AP.ticketAssignedTo = Nothing - , AP.ticketIsResolved = False + , AP.ticketResolved = Nothing , AP.ticketAttachment = mmr } , createTarget = Just uTarget @@ -1399,7 +1399,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar checkTicket shrUser (AP.Ticket mlocal attrib mpublished mupdated muContext summary - content source muAssigned resolved mmr) = do + content source muAssigned mresolved mmr) = do verifyNothingE mlocal "Ticket with 'id'" shrAttrib <- do route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route" @@ -1412,7 +1412,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar verifyNothingE mpublished "Ticket with 'published'" verifyNothingE mupdated "Ticket with 'updated'" verifyNothingE muAssigned "Ticket has 'assignedTo'" - when resolved $ throwE "Ticket is resolved" + when (isJust mresolved) $ throwE "Ticket is resolved" mmr' <- traverse (uncurry checkMR) mmr diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 2963178..ce8b932 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -246,7 +246,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx , AP.ticketContent = TextHtml descHtml , AP.ticketSource = TextPandocMarkdown desc , AP.ticketAssignedTo = Nothing - , AP.ticketIsResolved = False + , AP.ticketResolved = Nothing , AP.ticketAttachment = Nothing } target = encodeRouteHome $ ProjectR shr prj @@ -311,7 +311,7 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context , AP.ticketContent = TextHtml descHtml , AP.ticketSource = TextPandocMarkdown desc , AP.ticketAssignedTo = Nothing - , AP.ticketIsResolved = False + , AP.ticketResolved = Nothing , AP.ticketAttachment = Nothing } create = Create diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 3d10789..6025be6 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -133,7 +133,7 @@ checkOfferTicket author ticket uTarget = do else return $ Right u checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary - content source muAssigned resolved mmr) = do + content source muAssigned mresolved mmr) = do verifyNothingE mlocal "Ticket with 'id'" unless (attrib == objUriLocal (remoteAuthorURI author)) $ throwE "Author created ticket attibuted to someone else" @@ -141,7 +141,7 @@ checkOfferTicket author ticket uTarget = do verifyNothingE mpublished "Ticket has 'published'" verifyNothingE mupdated "Ticket has 'updated'" verifyNothingE muAssigned "Ticket has 'assignedTo'" - when resolved $ throwE "Ticket is resolved" + when (isJust mresolved) $ throwE "Ticket is resolved" mmr' <- traverse (uncurry checkMR) mmr @@ -567,7 +567,7 @@ checkCreateTicket author ticket muTarget = do , TextPandocMarkdown ) checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary - content source muAssigned resolved mmr) = do + content source muAssigned mresolved mmr) = do (hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'" hl <- hostIsLocal hTicket when hl $ throwE "Remote author claims to create local ticket" @@ -581,7 +581,7 @@ checkCreateTicket author ticket muTarget = do pub <- fromMaybeE mpublished "Ticket without 'published'" verifyNothingE mupdated "Ticket has 'updated'" verifyNothingE muAssigned "Ticket has 'assignedTo'" - when resolved $ throwE "Ticket is resolved" + when (isJust mresolved) $ throwE "Ticket is resolved" mmr' <- traverse (uncurry checkMR) mmr context' <- matchTicketAndMR (AP.ticketId tlocal) pub context mmr' diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 18eac4e..cb2be74 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -460,7 +460,7 @@ postPublishR = do , ticketContent = TextHtml descHtml , ticketSource = TextPandocMarkdown desc , ticketAssignedTo = Nothing - , ticketIsResolved = False + , ticketResolved = Nothing , ticketAttachment = Nothing } target = encodeRouteFed h $ ProjectR shr prj diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 226a014..d249a5a 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -176,7 +176,10 @@ getSharerPatchR shr talkhid = do , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent <$> massignee - , AP.ticketIsResolved = ticketStatus ticket == TSClosed + , AP.ticketResolved = + if ticketStatus ticket == TSClosed + then Just (Nothing, Nothing) + else Nothing , AP.ticketAttachment = Just ( case repo of Left _ -> hLocal @@ -461,7 +464,10 @@ getRepoPatchR shr rp ltkhid = do , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent <$> massignee - , AP.ticketIsResolved = ticketStatus ticket == TSClosed + , AP.ticketResolved = + if ticketStatus ticket == TSClosed + then Just (Nothing, Nothing) + else Nothing , AP.ticketAttachment = Just ( hLocal , MergeRequest diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 50787a3..4159cba 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -393,7 +393,10 @@ getProjectTicketR shar proj ltkhid = do , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent . fst <$> massignee - , AP.ticketIsResolved = ticketStatus ticket == TSClosed + , AP.ticketResolved = + if ticketStatus ticket == TSClosed + then Just (Nothing, Nothing) + else Nothing , AP.ticketAttachment = Nothing } provideHtmlAndAP' host ticketAP $ @@ -1112,7 +1115,10 @@ getSharerTicketR shr talkhid = do , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent <$> massignee - , AP.ticketIsResolved = ticketStatus ticket == TSClosed + , AP.ticketResolved = + if ticketStatus ticket == TSClosed + then Just (Nothing, Nothing) + else Nothing , AP.ticketAttachment = Nothing } provideHtmlAndAP ticketAP $ redirectToPrettyJSON here diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 5f15223..15b088d 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -765,7 +765,7 @@ changes hLocal ctx = , ticketSource = TextPandocMarkdown $ ticket20190612Source ticket , ticketAssignedTo = Nothing - , ticketIsResolved = False + , ticketResolved = Nothing , ticketAttachment = Nothing } summary = diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index f8f3125..54b754b 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1002,7 +1002,7 @@ data Ticket u = Ticket , ticketContent :: TextHtml , ticketSource :: TextPandocMarkdown , ticketAssignedTo :: Maybe (ObjURI u) - , ticketIsResolved :: Bool + , ticketResolved :: Maybe (Maybe (ObjURI u), Maybe UTCTime) , ticketAttachment :: Maybe (Authority u, MergeRequest u) } @@ -1024,6 +1024,18 @@ instance ActivityPub Ticket where ObjURI a attributedTo <- o .: "attributedTo" + mresolved <- do + is <- o .:? "isResolved" .!= False + if is + then do + at <- o .:? "resolved" + by <- o .:? "resolvedBy" + return $ Just (by, at) + else do + verifyNothing "resolved" + verifyNothing "resolvedBy" + return Nothing + fmap (a,) $ Ticket <$> parseTicketLocal o @@ -1036,12 +1048,17 @@ instance ActivityPub Ticket where <*> (TextHtml . sanitizeBalance <$> o .: "content") <*> source .: "content" <*> o .:? "assignedTo" - <*> o .: "isResolved" + <*> pure mresolved <*> (traverse parseObject =<< o .:? "attachment") + where + verifyNothing t = + if t `M.member` o + then fail $ T.unpack t ++ " field found, expected none" + else return () toSeries authority (Ticket local attributedTo published updated context {-name-} - summary content source assignedTo isResolved mmr) + summary content source assignedTo mresolved mmr) = maybe mempty (uncurry encodeTicketLocal) local <> "type" .= ("Ticket" :: Text) @@ -1058,7 +1075,14 @@ instance ActivityPub Ticket where , "mediaType" .= ("text/markdown; variant=Pandoc" :: Text) ] <> "assignedTo" .=? assignedTo - <> "isResolved" .= isResolved + <> maybe + ("isResolved" .= False) + (\ (mby, mat) + -> "isResolved" .= True + <> "resolvedBy" .=? mby + <> "resolved" .=? mat + ) + mresolved <> maybe mempty (\ (h, mr) -> "attachment" `pair` pairs (toSeries h mr))