Refactor sharer-ticket and sharer-patch GET handler code to reuse similar parts

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

src/Vervis/Discussion.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

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
+getSharerPatchesR =
-    (total, pages, mpage) <- runDB $ do
+    getSharerWorkItems SharerPatchesR SharerPatchR countPatches selectPatches
-        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
-                    }
     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
+getSharerPatchDiscussionR shr talkhid =
-    (locals, remotes) <- runDB $ do
+    getRepliesCollection (SharerPatchDiscussionR shr talkhid) $ do
         (_, Entity _ lt, _, _) <- getSharerPatch404 shr talkhid
-        let did = localTicketDiscuss lt
+        return $ 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
 
 getSharerPatchDeps
     :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
-getSharerPatchDeps forward shr talkhid = do
+getSharerPatchDeps forward shr talkhid =
-    tdids <- runDB $ do
+    getDependencyCollection here getTicketId404 forward
-        (_, _, 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
     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
+    provideEmptyCollection
-    let team = Collection
+        CollectionTypeOrdered
-            { collectionId         = encodeRouteLocal here
+        (SharerPatchEventsR shr talkhid)
-            , collectionType       = CollectionTypeOrdered
-            , collectionTotalItems = Just 0
-            , collectionCurrent    = Nothing
-            , collectionFirst      = Nothing
-            , collectionLast       = Nothing
-            , collectionItems      = [] :: [Text]
-            }
-    provideHtmlAndAP team $ redirectToPrettyJSON here
-    where
-    here = SharerPatchEventsR shr talkhid

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
+getSharerTicketsR =
-    (total, pages, mpage) <- runDB $ do
+    getSharerWorkItems SharerTicketsR SharerTicketR countTickets selectTickets
-        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
-                    }
     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
+getSharerTicketDiscussionR shr talkhid =
-    (locals, remotes) <- runDB $ do
+    getRepliesCollection (SharerTicketDiscussionR shr talkhid) $ do
         (_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
-        let did = localTicketDiscuss lt
+        return $ 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
 
 getSharerTicketDeps
     :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
-getSharerTicketDeps forward shr talkhid = do
+getSharerTicketDeps forward shr talkhid =
-    tdids <- runDB $ do
+    getDependencyCollection here getTicketId404 forward
-        (_, _, 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
     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
+    provideEmptyCollection
-    let team = Collection
+        CollectionTypeUnordered
-            { collectionId         = encodeRouteLocal here
+        (SharerTicketTeamR shr talkhid)
-            , collectionType       = CollectionTypeUnordered
-            , collectionTotalItems = Just 0
-            , collectionCurrent    = Nothing
-            , collectionFirst      = Nothing
-            , collectionLast       = Nothing
-            , collectionItems      = [] :: [Text]
-            }
-    provideHtmlAndAP team $ redirectToPrettyJSON here
-    where
-    here = SharerTicketTeamR shr talkhid
 
 getSharerTicketEventsR
     :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerTicketEventsR shr talkhid = do
     _ <- runDB $ getSharerTicket404 shr talkhid
-    encodeRouteLocal <- getEncodeRouteLocal
+    provideEmptyCollection
-    let team = Collection
+        CollectionTypeOrdered
-            { collectionId         = encodeRouteLocal here
+        (SharerTicketEventsR shr talkhid)
-            , collectionType       = CollectionTypeOrdered
-            , collectionTotalItems = Just 0
-            , collectionCurrent    = Nothing
-            , collectionFirst      = Nothing
-            , collectionLast       = Nothing
-            , collectionItems      = [] :: [Text]
-            }
-    provideHtmlAndAP team $ redirectToPrettyJSON here
-    where
-    here = SharerTicketEventsR shr talkhid

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