mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 18:04:53 +09:00
Add repo-hosted patch routes and GET handlers
This commit is contained in:
fr33domlover
parent
e29233a59f
commit
d9c00cba1f
2 changed files with 306 additions and 1 deletions
|
|
@ -110,6 +110,17 @@
|
|||
/s/#ShrIdent/r/#RpIdent/d/!new RepoDevNewR GET
|
||||
/s/#ShrIdent/r/#RpIdent/d/#ShrIdent RepoDevR GET DELETE POST
|
||||
|
||||
/s/#ShrIdent/r/#RpIdent/pt RepoPatchesR GET
|
||||
|
||||
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid RepoPatchR GET
|
||||
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/d RepoPatchDiscussionR GET
|
||||
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/deps RepoPatchDepsR GET
|
||||
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/rdeps RepoPatchReverseDepsR GET
|
||||
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/followers RepoPatchFollowersR GET
|
||||
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/events RepoPatchEventsR GET
|
||||
|
||||
/s/#ShrIdent/r/#RpIdent/pt/#LocalTicketKeyHashid/v/#PatchKeyHashid RepoPatchVersionR GET
|
||||
|
||||
/s/#ShrIdent/r/#RpIdent/_darcs/+Texts DarcsDownloadR GET
|
||||
|
||||
/s/#ShrIdent/r/#RpIdent/info/refs GitRefDiscoverR GET
|
||||
|
|
|
|||
|
|
@ -21,13 +21,23 @@ module Vervis.Handler.Patch
|
|||
, getSharerPatchReverseDepsR
|
||||
, getSharerPatchFollowersR
|
||||
, getSharerPatchEventsR
|
||||
|
||||
, getSharerPatchVersionR
|
||||
|
||||
, getRepoPatchesR
|
||||
, getRepoPatchR
|
||||
, getRepoPatchDiscussionR
|
||||
, getRepoPatchDepsR
|
||||
, getRepoPatchReverseDepsR
|
||||
, getRepoPatchFollowersR
|
||||
, getRepoPatchEventsR
|
||||
, getRepoPatchVersionR
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.Function
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
|
|
@ -35,6 +45,7 @@ import Yesod.Core
|
|||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.List.Ordered as LO
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Network.FedURI
|
||||
|
|
@ -266,3 +277,286 @@ getSharerPatchVersionR shr talkhid ptkhid = do
|
|||
provideHtmlAndAP versionAP $ redirectToPrettyJSON here
|
||||
where
|
||||
here = SharerPatchVersionR shr talkhid ptkhid
|
||||
|
||||
getRepoPatchesR :: ShrIdent -> RpIdent -> Handler TypedContent
|
||||
getRepoPatchesR shr rp = do
|
||||
(total, pages, mpage) <- runDB $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
rid <- getKeyBy404 $ UniqueRepo rp sid
|
||||
getPageAndNavCount (countPatches rid) (selectPatches rid)
|
||||
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRoutePageLocal <- getEncodeRoutePageLocal
|
||||
let here = RepoPatchesR shr rp
|
||||
pageUrl = encodeRoutePageLocal here
|
||||
encodeLT <- getEncodeKeyHashid
|
||||
encodeTAL <- getEncodeKeyHashid
|
||||
let patchUrl (Left (E.Value ltid, E.Value mtalid, E.Value mshr, E.Value mtupid)) =
|
||||
encodeRouteHome $
|
||||
case (mtalid, mshr, mtupid) of
|
||||
(Nothing, Nothing, Nothing) -> RepoPatchR shr rp $ encodeLT ltid
|
||||
(Just talid, Just shrA, Nothing) -> SharerPatchR shrA $ encodeTAL talid
|
||||
(Just _, Just _, Just _) -> RepoPatchR shr rp $ encodeLT ltid
|
||||
_ -> error "Impossible"
|
||||
patchUrl (Right (E.Value h, E.Value lu)) = ObjURI h lu
|
||||
|
||||
case mpage of
|
||||
Nothing -> provide here $ Collection
|
||||
{ collectionId = encodeRouteLocal here
|
||||
, collectionType = CollectionTypeOrdered
|
||||
, collectionTotalItems = Just total
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Just $ pageUrl 1
|
||||
, collectionLast = Just $ pageUrl pages
|
||||
, collectionItems = [] :: [Text]
|
||||
}
|
||||
Just (patches, navModel) ->
|
||||
let current = nmCurrent navModel
|
||||
in provide here $ CollectionPage
|
||||
{ collectionPageId = pageUrl current
|
||||
, collectionPageType = CollectionPageTypeOrdered
|
||||
, collectionPageTotalItems = Nothing
|
||||
, collectionPageCurrent = Just $ pageUrl current
|
||||
, collectionPageFirst = Just $ pageUrl 1
|
||||
, collectionPageLast = Just $ pageUrl pages
|
||||
, collectionPagePartOf = encodeRouteLocal here
|
||||
, collectionPagePrev =
|
||||
if current > 1
|
||||
then Just $ pageUrl $ current - 1
|
||||
else Nothing
|
||||
, collectionPageNext =
|
||||
if current < pages
|
||||
then Just $ pageUrl $ current + 1
|
||||
else Nothing
|
||||
, collectionPageStartIndex = Nothing
|
||||
, collectionPageItems = map patchUrl patches
|
||||
}
|
||||
where
|
||||
provide :: ActivityPub a => Route App -> a URIMode -> Handler TypedContent
|
||||
provide here a = provideHtmlAndAP a $ redirectToPrettyJSON here
|
||||
countPatches rid = count [TicketRepoLocalRepo ==. rid]
|
||||
selectPatches rid off lim = do
|
||||
tids <- E.select $ E.from $ \ (tcl `E.InnerJoin` trl) -> do
|
||||
E.on $ tcl E.^. TicketContextLocalId E.==. trl E.^. TicketRepoLocalContext
|
||||
E.where_ $ trl E.^. TicketRepoLocalRepo E.==. E.val rid
|
||||
E.orderBy [E.desc $ tcl E.^. TicketContextLocalTicket]
|
||||
E.offset $ fromIntegral off
|
||||
E.limit $ fromIntegral lim
|
||||
return $ tcl E.^. TicketContextLocalTicket
|
||||
let tids' = map E.unValue tids
|
||||
locals <- E.select $ E.from $ \ (lt `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s `E.LeftOuterJoin` tup)) -> do
|
||||
E.on $ tal E.?. TicketAuthorLocalId E.==. tup E.?. TicketUnderProjectAuthor
|
||||
E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
|
||||
E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
|
||||
E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket
|
||||
E.where_ $ lt E.^. LocalTicketTicket `E.in_` E.valList tids'
|
||||
E.orderBy [E.desc $ lt E.^. LocalTicketTicket]
|
||||
return
|
||||
( lt E.^. LocalTicketTicket
|
||||
, ( lt E.^. LocalTicketId
|
||||
, tal E.?. TicketAuthorLocalId
|
||||
, s E.?. SharerIdent
|
||||
, tup E.?. TicketUnderProjectId
|
||||
)
|
||||
)
|
||||
remotes <- E.select $ E.from $ \ (tcl `E.InnerJoin` tar `E.InnerJoin` rt `E.InnerJoin` ro `E.InnerJoin` i) -> do
|
||||
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
|
||||
E.on $ rt E.^. RemoteTicketIdent E.==. ro E.^. RemoteObjectId
|
||||
E.on $ tar E.^. TicketAuthorRemoteId E.==. rt E.^. RemoteTicketTicket
|
||||
E.on $ tcl E.^. TicketContextLocalId E.==. tar E.^. TicketAuthorRemoteTicket
|
||||
E.where_ $ tcl E.^. TicketContextLocalTicket `E.in_` E.valList tids'
|
||||
E.orderBy [E.desc $ tcl E.^. TicketContextLocalTicket]
|
||||
return
|
||||
( tcl E.^. TicketContextLocalTicket
|
||||
, ( i E.^. InstanceHost
|
||||
, ro E.^. RemoteObjectIdent
|
||||
)
|
||||
)
|
||||
return $
|
||||
map snd $
|
||||
LO.mergeBy
|
||||
(flip compare `on` fst)
|
||||
(map (second Left) locals)
|
||||
(map (second Right) remotes)
|
||||
|
||||
getRepoPatchR
|
||||
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
getRepoPatchR shr rp ltkhid = do
|
||||
(ticket, ptids, trl, author, massignee) <- runDB $ do
|
||||
(_, _, Entity tid t, _, _, Entity _ trl, ta, ptids) <- getRepoPatch404 shr rp ltkhid
|
||||
(,,,,) t ptids trl
|
||||
<$> bitraverse
|
||||
(\ (Entity _ tal, _) -> do
|
||||
p <- getJust $ ticketAuthorLocalAuthor tal
|
||||
getJust $ personIdent p
|
||||
)
|
||||
(\ (Entity _ tar) -> do
|
||||
ra <- getJust $ ticketAuthorRemoteAuthor tar
|
||||
ro <- getJust $ remoteActorIdent ra
|
||||
i <- getJust $ remoteObjectInstance ro
|
||||
return (i, ro)
|
||||
)
|
||||
ta
|
||||
<*> (for (ticketAssignee t) $ \ pidAssignee -> do
|
||||
p <- getJust pidAssignee
|
||||
getJust $ personIdent p
|
||||
)
|
||||
hLocal <- getsYesod siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodePatchId <- getEncodeKeyHashid
|
||||
let versionUrl = RepoPatchVersionR shr rp ltkhid . encodePatchId
|
||||
host =
|
||||
case author of
|
||||
Left _ -> hLocal
|
||||
Right (i, _) -> instanceHost i
|
||||
patchAP = AP.Ticket
|
||||
{ AP.ticketLocal = Just
|
||||
( hLocal
|
||||
, AP.TicketLocal
|
||||
{ AP.ticketId =
|
||||
encodeRouteLocal $ RepoPatchR shr rp ltkhid
|
||||
, AP.ticketReplies =
|
||||
encodeRouteLocal $ RepoPatchDiscussionR shr rp ltkhid
|
||||
, AP.ticketParticipants =
|
||||
encodeRouteLocal $ RepoPatchFollowersR shr rp ltkhid
|
||||
, AP.ticketTeam = Nothing
|
||||
, AP.ticketEvents =
|
||||
encodeRouteLocal $ RepoPatchEventsR shr rp ltkhid
|
||||
, AP.ticketDeps =
|
||||
encodeRouteLocal $ RepoPatchDepsR shr rp ltkhid
|
||||
, AP.ticketReverseDeps =
|
||||
encodeRouteLocal $ RepoPatchReverseDepsR shr rp ltkhid
|
||||
}
|
||||
)
|
||||
, AP.ticketAttributedTo =
|
||||
case author of
|
||||
Left sharer ->
|
||||
encodeRouteLocal $ SharerR $ sharerIdent sharer
|
||||
Right (_inztance, object) ->
|
||||
remoteObjectIdent object
|
||||
, AP.ticketPublished = Just $ ticketCreated ticket
|
||||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketContext = Just $ encodeRouteHome $ RepoR shr rp
|
||||
, AP.ticketSummary = TextHtml $ ticketTitle ticket
|
||||
, AP.ticketContent = TextHtml $ ticketDescription ticket
|
||||
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
|
||||
, AP.ticketAssignedTo =
|
||||
encodeRouteHome . SharerR . sharerIdent <$> massignee
|
||||
, AP.ticketIsResolved = ticketStatus ticket == TSClosed
|
||||
, AP.ticketAttachment = Just
|
||||
( hLocal
|
||||
, MergeRequest
|
||||
{ mrOrigin = Nothing
|
||||
, mrTarget =
|
||||
encodeRouteHome $
|
||||
case ticketRepoLocalBranch trl of
|
||||
Nothing -> RepoR shr rp
|
||||
Just b -> RepoBranchR shr rp b
|
||||
, mrPatch = NE.map (encodeRouteLocal . versionUrl) ptids
|
||||
}
|
||||
)
|
||||
}
|
||||
provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here
|
||||
where
|
||||
here = RepoPatchR shr rp ltkhid
|
||||
|
||||
getRepoPatchDiscussionR
|
||||
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
getRepoPatchDiscussionR shr rp ltkhid =
|
||||
getRepliesCollection (RepoPatchDiscussionR shr rp ltkhid) $ do
|
||||
(_, _, _, Entity _ lt, _, _, _, _) <- getRepoPatch404 shr rp ltkhid
|
||||
return $ localTicketDiscuss lt
|
||||
|
||||
getRepoPatchDeps
|
||||
:: Bool
|
||||
-> ShrIdent
|
||||
-> RpIdent
|
||||
-> KeyHashid LocalTicket
|
||||
-> Handler TypedContent
|
||||
getRepoPatchDeps forward shr rp ltkhid =
|
||||
getDependencyCollection here getTicketId404 forward
|
||||
where
|
||||
here =
|
||||
let route =
|
||||
if forward then RepoPatchDepsR else RepoPatchReverseDepsR
|
||||
in route shr rp ltkhid
|
||||
getTicketId404 = do
|
||||
(_, _, Entity tid _, _, _, _, _, _) <- getRepoPatch404 shr rp ltkhid
|
||||
return tid
|
||||
|
||||
getRepoPatchDepsR
|
||||
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
getRepoPatchDepsR = getRepoPatchDeps True
|
||||
|
||||
getRepoPatchReverseDepsR
|
||||
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
getRepoPatchReverseDepsR = getRepoPatchDeps False
|
||||
|
||||
getRepoPatchFollowersR
|
||||
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
getRepoPatchFollowersR shr rp ltkhid = getFollowersCollection here getFsid
|
||||
where
|
||||
here = RepoPatchFollowersR shr rp ltkhid
|
||||
getFsid = do
|
||||
(_, _, _, Entity _ lt, _, _, _, _) <- getRepoPatch404 shr rp ltkhid
|
||||
return $ localTicketFollowers lt
|
||||
|
||||
getRepoPatchEventsR
|
||||
:: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
getRepoPatchEventsR shr rp ltkhid = do
|
||||
_ <- runDB $ getRepoPatch404 shr rp ltkhid
|
||||
provideEmptyCollection
|
||||
CollectionTypeOrdered
|
||||
(RepoPatchEventsR shr rp ltkhid)
|
||||
|
||||
getRepoPatchVersionR
|
||||
:: ShrIdent
|
||||
-> RpIdent
|
||||
-> KeyHashid LocalTicket
|
||||
-> KeyHashid Patch
|
||||
-> Handler TypedContent
|
||||
getRepoPatchVersionR shr rp ltkhid ptkhid = do
|
||||
(vcs, patch, author) <- runDB $ do
|
||||
(_, Entity _ repo, Entity tid _, _, _, _, ta, _) <- getRepoPatch404 shr rp ltkhid
|
||||
(repoVcs repo,,)
|
||||
<$> do ptid <- decodeKeyHashid404 ptkhid
|
||||
pt <- get404 ptid
|
||||
unless (patchTicket pt == tid) notFound
|
||||
return pt
|
||||
<*> bitraverse
|
||||
(\ (Entity _ tal, _) -> do
|
||||
p <- getJust $ ticketAuthorLocalAuthor tal
|
||||
getJust $ personIdent p
|
||||
)
|
||||
(\ (Entity _ tar) -> do
|
||||
ra <- getJust $ ticketAuthorRemoteAuthor tar
|
||||
ro <- getJust $ remoteActorIdent ra
|
||||
i <- getJust $ remoteObjectInstance ro
|
||||
return (i, ro)
|
||||
)
|
||||
ta
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let versionAP = AP.Patch
|
||||
{ AP.patchId = encodeRouteLocal here
|
||||
, AP.patchAttributedTo =
|
||||
case author of
|
||||
Left sharer ->
|
||||
encodeRouteHome $ SharerR $ sharerIdent sharer
|
||||
Right (inztance, object) ->
|
||||
ObjURI
|
||||
(instanceHost inztance)
|
||||
(remoteObjectIdent object)
|
||||
, AP.patchPublished = patchCreated patch
|
||||
, AP.patchContext = encodeRouteLocal $ RepoPatchR shr rp ltkhid
|
||||
, AP.patchType =
|
||||
case vcs of
|
||||
VCSDarcs -> PatchTypeDarcs
|
||||
VCSGit -> error "TODO add PatchType for git patches"
|
||||
, AP.patchContent = patchContent patch
|
||||
}
|
||||
provideHtmlAndAP versionAP $ redirectToPrettyJSON here
|
||||
where
|
||||
here = RepoPatchVersionR shr rp ltkhid ptkhid
|
||||
|
|
|
|||
Loading…
Reference in a new issue