diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 2c8165e..68f47dd 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -47,6 +47,7 @@ module Vervis.ActivityPub , RemoteRecipient (..) , deliverLocal' , insertRemoteActivityToLocalInboxes + , provideEmptyCollection ) where @@ -1064,3 +1065,17 @@ insertRemoteActivityToLocalInboxes requireOwner ractid = insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing where makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid + +provideEmptyCollection :: CollectionType -> Route App -> Handler TypedContent +provideEmptyCollection typ here = do + encodeRouteLocal <- getEncodeRouteLocal + let coll = Collection + { collectionId = encodeRouteLocal here + , collectionType = typ + , collectionTotalItems = Just 0 + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = [] :: [Text] + } + provideHtmlAndAP coll $ redirectToPrettyJSON here diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Discussion.hs index 0d5151d..2ce47c9 100644 --- a/src/Vervis/Discussion.hs +++ b/src/Vervis/Discussion.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -17,6 +17,7 @@ module Vervis.Discussion ( MessageTreeNodeAuthor (..) , MessageTreeNode (..) , getDiscussionTree + , getRepliesCollection ) where @@ -27,11 +28,17 @@ import Data.Maybe (isNothing, mapMaybe) import Data.Text (Text) import Data.Tree (Forest) import Database.Esqueleto hiding (isNothing) +import Yesod.Core.Content import Yesod.Persist.Core (runDB) import qualified Data.HashMap.Lazy as M (fromList, lookup) +import qualified Database.Esqueleto as E import Network.FedURI +import Web.ActivityPub +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids import Data.Tree.Local (sortForestOn) @@ -104,3 +111,50 @@ sortByTime = sortForestOn $ messageCreated . mtnMessage -- old to new. getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode) getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid + +getRepliesCollection :: Route App -> AppDB DiscussionId -> Handler TypedContent +getRepliesCollection here getDiscussionId404 = do + (locals, remotes) <- runDB $ do + did <- getDiscussionId404 + (,) <$> selectLocals did <*> selectRemotes did + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + encodeHid <- getEncodeKeyHashid + let localUri' = localUri encodeRouteHome encodeHid + replies = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length locals + length remotes + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map localUri' locals ++ map remoteUri remotes + } + provideHtmlAndAP replies $ redirectToPrettyJSON here + where + selectLocals did = + E.select $ E.from $ + \ (m `E.InnerJoin` lm `E.InnerJoin` p `E.InnerJoin` s) -> do + E.on $ p E.^. PersonIdent E.==. s E.^. SharerId + E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId + E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest + E.where_ $ + m E.^. MessageRoot E.==. E.val did E.&&. + E.isNothing (m E.^. MessageParent) E.&&. + E.isNothing (lm E.^. LocalMessageUnlinkedParent) + return (s E.^. SharerIdent, lm E.^. LocalMessageId) + selectRemotes did = + E.select $ E.from $ + \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId + E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest + E.where_ $ + m E.^. MessageRoot E.==. E.val did E.&&. + E.isNothing (m E.^. MessageParent) E.&&. + E.isNothing (rm E.^. RemoteMessageLostParent) + return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) + localUri encR encH (E.Value shrAuthor, E.Value lmid) = + encR $ MessageR shrAuthor (encH lmid) + remoteUri (E.Value h, E.Value lu) = ObjURI h lu diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 1b7d1db..29124b9 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -44,7 +44,9 @@ import qualified Web.ActivityPub as AP import Data.Paginate.Local import Yesod.Persist.Local +import Vervis.ActivityPub import Vervis.API +import Vervis.Discussion import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -52,56 +54,12 @@ import Vervis.Model.Ident import Vervis.Model.Ticket import Vervis.Paginate import Vervis.Patch +import Vervis.Ticket getSharerPatchesR :: ShrIdent -> Handler TypedContent -getSharerPatchesR shr = do - (total, pages, mpage) <- runDB $ do - sid <- getKeyBy404 $ UniqueSharer shr - pid <- getKeyBy404 $ UniquePersonIdent sid - getPageAndNavCount (countPatches pid) (selectPatches pid) - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal - encodeRoutePageLocal <- getEncodeRoutePageLocal - let pageUrl = encodeRoutePageLocal here - encodeTicketKey <- getEncodeKeyHashid - let patchUrl = SharerPatchR shr . encodeTicketKey - - case mpage of - Nothing -> provide $ 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 $ 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 (encodeRouteHome . patchUrl . E.unValue) patches - } +getSharerPatchesR = + getSharerWorkItems SharerPatchesR SharerPatchR countPatches selectPatches where - here = SharerPatchesR shr - provide :: ActivityPub a => a URIMode -> Handler TypedContent - provide a = provideHtmlAndAP a $ redirectToPrettyJSON here countPatches pid = fmap toOne $ E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup) -> do E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor @@ -208,87 +166,23 @@ getSharerPatchR shr talkhid = do getSharerPatchDiscussionR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchDiscussionR shr talkhid = do - (locals, remotes) <- runDB $ do +getSharerPatchDiscussionR shr talkhid = + getRepliesCollection (SharerPatchDiscussionR shr talkhid) $ do (_, Entity _ lt, _, _) <- getSharerPatch404 shr talkhid - let did = localTicketDiscuss lt - (,) <$> selectLocals did <*> selectRemotes did - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - encodeHid <- getEncodeKeyHashid - let localUri' = localUri encodeRouteHome encodeHid - replies = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ length locals + length remotes - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = - map localUri' locals ++ map remoteUri remotes - } - provideHtmlAndAP replies $ redirectToPrettyJSON here - where - here = SharerPatchDiscussionR shr talkhid - selectLocals did = - E.select $ E.from $ - \ (m `E.InnerJoin` lm `E.InnerJoin` p `E.InnerJoin` s) -> do - E.on $ p E.^. PersonIdent E.==. s E.^. SharerId - E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId - E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest - E.where_ $ - m E.^. MessageRoot E.==. E.val did E.&&. - E.isNothing (m E.^. MessageParent) E.&&. - E.isNothing (lm E.^. LocalMessageUnlinkedParent) - return (s E.^. SharerIdent, lm E.^. LocalMessageId) - selectRemotes did = - E.select $ E.from $ - \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do - E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId - E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId - E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest - E.where_ $ - m E.^. MessageRoot E.==. E.val did E.&&. - E.isNothing (m E.^. MessageParent) E.&&. - E.isNothing (rm E.^. RemoteMessageLostParent) - return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) - localUri encR encH (E.Value shrAuthor, E.Value lmid) = - encR $ MessageR shrAuthor (encH lmid) - remoteUri (E.Value h, E.Value lu) = ObjURI h lu + return $ localTicketDiscuss lt getSharerPatchDeps :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerPatchDeps forward shr talkhid = do - tdids <- runDB $ do - (_, _, Entity tid _, _) <- getSharerPatch404 shr talkhid - let (from, to) = - if forward - then (TicketDependencyParent, TicketDependencyChild) - else (TicketDependencyChild, TicketDependencyParent) - E.select $ E.from $ \ (td `E.InnerJoin` t) -> do - E.on $ td E.^. to E.==. t E.^. TicketId - E.where_ $ td E.^. from E.==. E.val tid - return $ td E.^. TicketDependencyId - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - encodeHid <- getEncodeKeyHashid - let deps = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ length tdids - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = - map (encodeRouteHome . TicketDepR . encodeHid . E.unValue) - tdids - } - provideHtmlAndAP deps $ redirectToPrettyJSON here +getSharerPatchDeps forward shr talkhid = + getDependencyCollection here getTicketId404 forward where here = let route = - if forward then SharerPatchDepsR else SharerTicketReverseDepsR + if forward then SharerPatchDepsR else SharerPatchReverseDepsR in route shr talkhid + getTicketId404 = do + (_, _, Entity tid _, _) <- getSharerPatch404 shr talkhid + return tid getSharerPatchDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent @@ -311,16 +205,6 @@ getSharerPatchEventsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent getSharerPatchEventsR shr talkhid = do _ <- runDB $ getSharerPatch404 shr talkhid - encodeRouteLocal <- getEncodeRouteLocal - let team = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeOrdered - , collectionTotalItems = Just 0 - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = [] :: [Text] - } - provideHtmlAndAP team $ redirectToPrettyJSON here - where - here = SharerPatchEventsR shr talkhid + provideEmptyCollection + CollectionTypeOrdered + (SharerPatchEventsR shr talkhid) diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index beed48c..7c32779 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -121,7 +121,9 @@ import Data.Paginate.Local import Database.Persist.Local import Yesod.Persist.Local +import Vervis.ActivityPub import Vervis.API +import Vervis.Discussion import Vervis.Federation import Vervis.FedURI import Vervis.Form.Ticket @@ -1129,54 +1131,9 @@ getProjectTicketEventsR getProjectTicketEventsR _shr _prj _ltkhid = error "TODO not implemented" getSharerTicketsR :: ShrIdent -> Handler TypedContent -getSharerTicketsR shr = do - (total, pages, mpage) <- runDB $ do - sid <- getKeyBy404 $ UniqueSharer shr - pid <- getKeyBy404 $ UniquePersonIdent sid - getPageAndNavCount (countTickets pid) (selectTickets pid) - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal - encodeRoutePageLocal <- getEncodeRoutePageLocal - let pageUrl = encodeRoutePageLocal here - encodeTicketKey <- getEncodeKeyHashid - let ticketUrl = SharerTicketR shr . encodeTicketKey - - case mpage of - Nothing -> provide $ Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeOrdered - , collectionTotalItems = Just total - , collectionCurrent = Nothing - , collectionFirst = Just $ pageUrl 1 - , collectionLast = Just $ pageUrl pages - , collectionItems = [] :: [Text] - } - Just (tickets, navModel) -> - let current = nmCurrent navModel - in provide $ 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 (encodeRouteHome . ticketUrl . E.unValue) tickets - } +getSharerTicketsR = + getSharerWorkItems SharerTicketsR SharerTicketR countTickets selectTickets where - here = SharerTicketsR shr - provide :: ActivityPub a => a URIMode -> Handler TypedContent - provide a = provideHtmlAndAP a $ redirectToPrettyJSON here countTickets pid = fmap toOne $ E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` pt) -> do E.on $ E.just (lt E.^. LocalTicketTicket) E.==. pt E.?. PatchTicket @@ -1280,87 +1237,23 @@ getSharerTicketR shr talkhid = do getSharerTicketDiscussionR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerTicketDiscussionR shr talkhid = do - (locals, remotes) <- runDB $ do +getSharerTicketDiscussionR shr talkhid = + getRepliesCollection (SharerTicketDiscussionR shr talkhid) $ do (_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid - let did = localTicketDiscuss lt - (,) <$> selectLocals did <*> selectRemotes did - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - encodeHid <- getEncodeKeyHashid - let localUri' = localUri encodeRouteHome encodeHid - replies = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ length locals + length remotes - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = - map localUri' locals ++ map remoteUri remotes - } - provideHtmlAndAP replies $ redirectToPrettyJSON here - where - here = SharerTicketDiscussionR shr talkhid - selectLocals did = - E.select $ E.from $ - \ (m `E.InnerJoin` lm `E.InnerJoin` p `E.InnerJoin` s) -> do - E.on $ p E.^. PersonIdent E.==. s E.^. SharerId - E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId - E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest - E.where_ $ - m E.^. MessageRoot E.==. E.val did E.&&. - E.isNothing (m E.^. MessageParent) E.&&. - E.isNothing (lm E.^. LocalMessageUnlinkedParent) - return (s E.^. SharerIdent, lm E.^. LocalMessageId) - selectRemotes did = - E.select $ E.from $ - \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do - E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId - E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId - E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest - E.where_ $ - m E.^. MessageRoot E.==. E.val did E.&&. - E.isNothing (m E.^. MessageParent) E.&&. - E.isNothing (rm E.^. RemoteMessageLostParent) - return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) - localUri encR encH (E.Value shrAuthor, E.Value lmid) = - encR $ MessageR shrAuthor (encH lmid) - remoteUri (E.Value h, E.Value lu) = ObjURI h lu + return $ localTicketDiscuss lt getSharerTicketDeps :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerTicketDeps forward shr talkhid = do - tdids <- runDB $ do - (_, _, Entity tid _, _) <- getSharerTicket404 shr talkhid - let (from, to) = - if forward - then (TicketDependencyParent, TicketDependencyChild) - else (TicketDependencyChild, TicketDependencyParent) - E.select $ E.from $ \ (td `E.InnerJoin` t) -> do - E.on $ td E.^. to E.==. t E.^. TicketId - E.where_ $ td E.^. from E.==. E.val tid - return $ td E.^. TicketDependencyId - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - encodeHid <- getEncodeKeyHashid - let deps = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ length tdids - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = - map (encodeRouteHome . TicketDepR . encodeHid . E.unValue) - tdids - } - provideHtmlAndAP deps $ redirectToPrettyJSON here +getSharerTicketDeps forward shr talkhid = + getDependencyCollection here getTicketId404 forward where here = let route = if forward then SharerTicketDepsR else SharerTicketReverseDepsR in route shr talkhid + getTicketId404 = do + (_, _, Entity tid _, _) <- getSharerTicket404 shr talkhid + return tid getSharerTicketDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent @@ -1383,34 +1276,14 @@ getSharerTicketTeamR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent getSharerTicketTeamR shr talkhid = do _ <- runDB $ getSharerTicket404 shr talkhid - encodeRouteLocal <- getEncodeRouteLocal - let team = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just 0 - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = [] :: [Text] - } - provideHtmlAndAP team $ redirectToPrettyJSON here - where - here = SharerTicketTeamR shr talkhid + provideEmptyCollection + CollectionTypeUnordered + (SharerTicketTeamR shr talkhid) getSharerTicketEventsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent getSharerTicketEventsR shr talkhid = do _ <- runDB $ getSharerTicket404 shr talkhid - encodeRouteLocal <- getEncodeRouteLocal - let team = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeOrdered - , collectionTotalItems = Just 0 - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = [] :: [Text] - } - provideHtmlAndAP team $ redirectToPrettyJSON here - where - here = SharerTicketEventsR shr talkhid + provideEmptyCollection + CollectionTypeOrdered + (SharerTicketEventsR shr talkhid) diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index f29194e..e022079 100644 --- a/src/Vervis/Ticket.hs +++ b/src/Vervis/Ticket.hs @@ -31,6 +31,9 @@ module Vervis.Ticket , getSharerTicket404 , getProjectTicket , getProjectTicket404 + + , getSharerWorkItems + , getDependencyCollection ) where @@ -45,18 +48,28 @@ import Data.Text (Text) import Data.Traversable import Database.Esqueleto import Yesod.Core (notFound) +import Yesod.Core.Content +import Yesod.Persist.Core +import qualified Database.Esqueleto as E import qualified Database.Persist as P +import Web.ActivityPub hiding (Ticket, Project) +import Yesod.ActivityPub +import Yesod.FedURI import Yesod.Hashids import Data.Either.Local +import Data.Paginate.Local import Database.Persist.Local +import Yesod.Persist.Local -import Vervis.Foundation (AppDB) +import Vervis.FedURI +import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Workflow +import Vervis.Paginate import Vervis.Widget.Ticket (TicketSummary (..)) -- | Get summaries of all the tickets in the given project. @@ -567,3 +580,89 @@ getProjectTicket404 shr prj ltkhid = do case mticket of Nothing -> notFound Just ticket -> return ticket + +getSharerWorkItems + :: ToBackendKey SqlBackend record + => (ShrIdent -> Route App) + -> (ShrIdent -> KeyHashid record -> Route App) + -> (PersonId -> AppDB Int) + -> (PersonId -> Int -> Int -> AppDB [Value (Key record)]) + -> ShrIdent + -> Handler TypedContent +getSharerWorkItems mkhere itemRoute countItems selectItems shr = do + (total, pages, mpage) <- runDB $ do + sid <- getKeyBy404 $ UniqueSharer shr + pid <- getKeyBy404 $ UniquePersonIdent sid + getPageAndNavCount (countItems pid) (selectItems pid) + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + encodeRoutePageLocal <- getEncodeRoutePageLocal + let here = mkhere shr + pageUrl = encodeRoutePageLocal here + encodeTicketKey <- getEncodeKeyHashid + let ticketUrl = itemRoute shr . encodeTicketKey + + 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 (tickets, 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 (encodeRouteHome . ticketUrl . unValue) tickets + } + where + provide :: ActivityPub a => Route App -> a URIMode -> Handler TypedContent + provide here a = provideHtmlAndAP a $ redirectToPrettyJSON here + +getDependencyCollection + :: Route App -> AppDB TicketId -> Bool -> Handler TypedContent +getDependencyCollection here getTicketId404 forward = do + tdids <- runDB $ do + tid <- getTicketId404 + let (from, to) = + if forward + then (TicketDependencyParent, TicketDependencyChild) + else (TicketDependencyChild, TicketDependencyParent) + E.select $ E.from $ \ (td `E.InnerJoin` t) -> do + E.on $ td E.^. to E.==. t E.^. TicketId + E.where_ $ td E.^. from E.==. E.val tid + return $ td E.^. TicketDependencyId + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + encodeHid <- getEncodeKeyHashid + let deps = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length tdids + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map (encodeRouteHome . TicketDepR . encodeHid . E.unValue) + tdids + } + provideHtmlAndAP deps $ redirectToPrettyJSON here