Add repo-hosted patch routes and GET handlers

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

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