sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:34:52 +09:00
Code Issues Activity

AP: In getSharerPatchR, provide the list of patch versions, latest first

Browse source
This commit is contained in:
fr33domlover 2020-05-25 12:39:25 +00:00
parent c63479470e
commit 17e59af1c4
9 changed files with 92 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/models
View file

@ -401,6 +401,7 @@ TicketProjectLocal
TicketRepoLocal
context TicketContextLocalId
repo RepoId
branch Text Maybe
UniqueTicketRepoLocal context

4
src/Vervis/API.hs
View file

@ -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
}

2
src/Vervis/Client.hs
View file

@ -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

4
src/Vervis/Federation/Ticket.hs
View file

@ -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)

1
src/Vervis/Handler/Client.hs
View file

@ -399,6 +399,7 @@ postPublishR = do
, ticketSource = TextPandocMarkdown desc
, ticketAssignedTo = Nothing
, ticketIsResolved = False
, ticketAttachment = Nothing
}
offer = Offer
{ offerObject = ticketAP

37
src/Vervis/Handler/Patch.hs
View file

@ -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

2
src/Vervis/Handler/Ticket.hs
View file

@ -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

3
src/Vervis/Migration.hs
View file

@ -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

47
src/Web/ActivityPub.hs
View file

@ -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