From 17e59af1c4253d410d324f15fe4960282dd485d8 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Mon, 25 May 2020 12:39:25 +0000
Subject: [PATCH] AP: In getSharerPatchR, provide the list of patch versions,
latest first
---
config/models | 1 +
src/Vervis/API.hs | 4 ++-
src/Vervis/Client.hs | 2 ++
src/Vervis/Federation/Ticket.hs | 4 ++-
src/Vervis/Handler/Client.hs | 1 +
src/Vervis/Handler/Patch.hs | 37 +++++++++++++++++++++-----
src/Vervis/Handler/Ticket.hs | 2 ++
src/Vervis/Migration.hs | 3 +++
src/Web/ActivityPub.hs | 47 ++++++++++++++++++++++++++++++++-
9 files changed, 92 insertions(+), 9 deletions(-)
diff --git a/config/models b/config/models
index b96c7f2..74f83d8 100644
--- a/config/models
+++ b/config/models
@@ -401,6 +401,7 @@ TicketProjectLocal
TicketRepoLocal
context TicketContextLocalId
repo RepoId
+ branch Text Maybe
UniqueTicketRepoLocal context
diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index 6cd4bf1..821b705 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -523,7 +523,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept
return talid
where
- checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved) mtarget = do
+ checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved mmr) mtarget = do
verifyNothingE mlocal "Ticket with 'id'"
encodeRouteLocal <- getEncodeRouteLocal
unless (encodeRouteLocal (SharerR shr) == luAttrib) $
@@ -534,6 +534,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
verifyNothingE massigned "Ticket with 'assignedTo'"
when resolved $ throwE "Ticket resolved"
target <- fromMaybeE mtarget "Create Ticket without 'target'"
+ verifyNothingE mmr "Ticket with 'attachment'"
return (context, summary, content, source, target)
parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI)
@@ -677,6 +678,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, AP.ticketSource = source
, AP.ticketAssignedTo = Nothing
, AP.ticketIsResolved = False
+ , AP.ticketAttachment = Nothing
}
, createTarget = Just uTarget
}
diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs
index f4b80d5..74883c4 100644
--- a/src/Vervis/Client.hs
+++ b/src/Vervis/Client.hs
@@ -241,6 +241,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
, AP.ticketSource = TextPandocMarkdown desc
, AP.ticketAssignedTo = Nothing
, AP.ticketIsResolved = False
+ , AP.ticketAttachment = Nothing
}
offer = Offer
{ offerObject = ticket
@@ -308,6 +309,7 @@ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context
, AP.ticketSource = TextPandocMarkdown desc
, AP.ticketAssignedTo = Nothing
, AP.ticketIsResolved = False
+ , AP.ticketAttachment = Nothing
}
create = Create
{ createObject = CreateTicket ticket
diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs
index 9793a05..79d0a7a 100644
--- a/src/Vervis/Federation/Ticket.hs
+++ b/src/Vervis/Federation/Ticket.hs
@@ -88,6 +88,7 @@ checkOffer ticket hProject shrProject prjProject = do
-- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
+ verifyNothingE (AP.ticketAttachment ticket) "Ticket with 'attachment'"
sharerOfferTicketF
:: UTCTime
@@ -445,7 +446,7 @@ checkCreateTicket author ticket muTarget = do
else return $ Right u
checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext _summary
- _content _source muAssigned resolved) = do
+ _content _source muAssigned resolved mmr) = do
(hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'"
hl <- hostIsLocal hTicket
when hl $ throwE "Remote author claims to create local ticket"
@@ -460,6 +461,7 @@ checkCreateTicket author ticket muTarget = do
verifyNothingE mupdated "Ticket has 'updated'"
verifyNothingE muAssigned "Ticket has 'assignedTo'"
when resolved $ throwE "Ticket is resolved"
+ verifyNothingE mmr "Ticket has 'attachment'"
return (context, tlocal, pub)
diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs
index 511351f..bf05aa6 100644
--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@@ -399,6 +399,7 @@ postPublishR = do
, ticketSource = TextPandocMarkdown desc
, ticketAssignedTo = Nothing
, ticketIsResolved = False
+ , ticketAttachment = Nothing
}
offer = Offer
{ offerObject = ticketAP
diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs
index d66f991..3e26b8b 100644
--- a/src/Vervis/Handler/Patch.hs
+++ b/src/Vervis/Handler/Patch.hs
@@ -34,6 +34,7 @@ import Database.Persist
import Yesod.Core
import Yesod.Persist.Core
+import qualified Data.List.NonEmpty as NE
import qualified Database.Esqueleto as E
import Network.FedURI
@@ -99,14 +100,14 @@ getSharerPatchesR =
getSharerPatchR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerPatchR shr talkhid = do
- (ticket, repo, massignee) <- runDB $ do
- (_, _, Entity _ t, tp) <- getSharerPatch404 shr talkhid
- (,,) t
+ (ticket, repo, massignee, ptids') <- runDB $ do
+ (_, _, Entity tid t, tp) <- getSharerPatch404 shr talkhid
+ (,,,) t
<$> bitraverse
(\ (_, Entity _ trl) -> do
r <- getJust $ ticketRepoLocalRepo trl
s <- getJust $ repoSharer r
- return (s, r)
+ return (s, r, ticketRepoLocalBranch trl)
)
(\ (Entity _ tpr, _) -> do
roid <-
@@ -124,10 +125,17 @@ getSharerPatchR shr talkhid = do
p <- getJust pidAssignee
getJust $ personIdent p
)
+ <*> selectKeysList [PatchTicket ==. tid] [Desc PatchId]
+ let ptids =
+ case NE.nonEmpty ptids' of
+ Nothing -> error "No patches found!"
+ Just ne -> ne
hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
- let patchAP = AP.Ticket
+ encodePatchId <- getEncodeKeyHashid
+ let versionUrl = SharerPatchVersionR shr talkhid . encodePatchId
+ patchAP = AP.Ticket
{ AP.ticketLocal = Just
( hLocal
, AP.TicketLocal
@@ -152,7 +160,7 @@ getSharerPatchR shr talkhid = do
, AP.ticketContext =
Just $
case repo of
- Left (s, r) ->
+ Left (s, r, _) ->
encodeRouteHome $
RepoR (sharerIdent s) (repoIdent r)
Right (i, ro) ->
@@ -163,6 +171,23 @@ getSharerPatchR shr talkhid = do
, AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent <$> massignee
, AP.ticketIsResolved = ticketStatus ticket == TSClosed
+ , AP.ticketAttachment = Just
+ ( hLocal
+ , MergeRequest
+ { mrOrigin = Nothing
+ , mrTarget =
+ case repo of
+ Left (s, r, Nothing) ->
+ encodeRouteHome $
+ RepoR (sharerIdent s) (repoIdent r)
+ Left (s, r, Just b) ->
+ encodeRouteHome $
+ RepoBranchR (sharerIdent s) (repoIdent r) b
+ Right (i, ro) ->
+ ObjURI (instanceHost i) (remoteObjectIdent ro)
+ , mrPatch = NE.map (encodeRouteLocal . versionUrl) ptids
+ }
+ )
}
provideHtmlAndAP patchAP $ redirectToPrettyJSON here
where
diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs
index 7c32779..efda708 100644
--- a/src/Vervis/Handler/Ticket.hs
+++ b/src/Vervis/Handler/Ticket.hs
@@ -418,6 +418,7 @@ getProjectTicketR shar proj ltkhid = do
, AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
, AP.ticketIsResolved = ticketStatus ticket == TSClosed
+ , AP.ticketAttachment = Nothing
}
provideHtmlAndAP' host ticketAP $
let followButton =
@@ -1230,6 +1231,7 @@ getSharerTicketR shr talkhid = do
, AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent <$> massignee
, AP.ticketIsResolved = ticketStatus ticket == TSClosed
+ , AP.ticketAttachment = Nothing
}
provideHtmlAndAP ticketAP $ redirectToPrettyJSON here
where
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index f82b2a0..f86e7c3 100644
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@@ -766,6 +766,7 @@ changes hLocal ctx =
TextPandocMarkdown $ ticket20190612Source ticket
, ticketAssignedTo = Nothing
, ticketIsResolved = False
+ , ticketAttachment = Nothing
}
summary =
[hamlet|
@@ -1582,6 +1583,8 @@ changes hLocal ctx =
, addEntities model_2020_05_17
-- 250
, addFieldPrimRequired "Patch" defaultTime "created"
+ -- 251
+ , addFieldPrimOptional "TicketRepoLocal" (Nothing :: Maybe Text) "branch"
]
migrateDB
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 5911faa..d00f629 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -49,6 +49,7 @@ module Web.ActivityPub
, PatchType (..)
, Patch (..)
, TicketLocal (..)
+ , MergeRequest (..)
, Ticket (..)
, Author (..)
, Hash (..)
@@ -924,6 +925,44 @@ encodeTicketLocal
<> "dependencies" .= ObjURI a deps
<> "dependants" .= ObjURI a rdeps
+data MergeRequest u = MergeRequest
+ { mrOrigin :: Maybe (ObjURI u)
+ , mrTarget :: ObjURI u
+ , mrPatch :: NonEmpty LocalURI
+ }
+
+instance ActivityPub MergeRequest where
+ jsonldContext _ = [as2Context, forgeContext]
+
+ parseObject o = do
+ typ <- o .: "type"
+ unless (typ == ("Offer" :: Text)) $
+ fail "type isn't Offer"
+ (hPatch, patches) <- do
+ c <- o .: "object"
+ ctyp <- c .: "type"
+ unless (ctyp == ("OrderedCollection" :: Text)) $
+ fail "type isn't OrderedCollection"
+ ObjURI h lu :| us <- c .: "items" <|> c .: "orderedItems"
+ let (hs, lus) = unzip $ map (\ (ObjURI h lu) -> (h, lu)) us
+ unless (all (== h) hs) $ fail "Version hosts differ"
+ return (h, lu :| lus)
+ fmap (hPatch,) $
+ MergeRequest
+ <$> o .:? "origin"
+ <*> o .: "target"
+ <*> pure patches
+
+ toSeries hPatch (MergeRequest morigin target patches)
+ = "type" .= ("Offer" :: Text)
+ <> "origin" .=? morigin
+ <> "target" .= target
+ <> "object" .= object
+ [ "type" .= ("OrderedCollection" :: Text)
+ , "totalItems" .= length patches
+ , "orderedItems" .= NE.map (ObjURI hPatch) patches
+ ]
+
data Ticket u = Ticket
{ ticketLocal :: Maybe (Authority u, TicketLocal)
, ticketAttributedTo :: LocalURI
@@ -936,6 +975,7 @@ data Ticket u = Ticket
, ticketSource :: TextPandocMarkdown
, ticketAssignedTo :: Maybe (ObjURI u)
, ticketIsResolved :: Bool
+ , ticketAttachment :: Maybe (Authority u, MergeRequest u)
}
instance ActivityPub Ticket where
@@ -969,10 +1009,11 @@ instance ActivityPub Ticket where
<*> source .: "content"
<*> o .:? "assignedTo"
<*> o .: "isResolved"
+ <*> (traverse parseObject =<< o .:? "attachment")
toSeries authority
(Ticket local attributedTo published updated context {-name-}
- summary content source assignedTo isResolved)
+ summary content source assignedTo isResolved mmr)
= maybe mempty (uncurry encodeTicketLocal) local
<> "type" .= ("Ticket" :: Text)
@@ -990,6 +1031,10 @@ instance ActivityPub Ticket where
]
<> "assignedTo" .=? assignedTo
<> "isResolved" .= isResolved
+ <> maybe
+ mempty
+ (\ (h, mr) -> "attachment" `pair` pairs (toSeries h mr))
+ mmr
data Author = Author
{ authorName :: Text