From d9c00cba1fe06f89a668a2d770f4aff8f60846aa Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 26 May 2020 14:51:11 +0000 Subject: [PATCH] Add repo-hosted patch routes and GET handlers --- config/routes | 11 ++ src/Vervis/Handler/Patch.hs | 296 +++++++++++++++++++++++++++++++++++- 2 files changed, 306 insertions(+), 1 deletion(-) diff --git a/config/routes b/config/routes index 1f337f1..db5d3d6 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 719283a..24b61d4 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -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