Deck: Serve AP version of collabs list page

src/Vervis/Handler/Deck.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022, 2023, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -407,38 +408,75 @@ postDeckUnfollowR _ = error "Temporarily disabled"
 getDeckStampR :: KeyHashid Deck -> KeyHashid SigKey -> Handler TypedContent
 getDeckStampR = servePerActorKey deckActor LocalActorDeck
 
-getDeckCollabsR :: KeyHashid Deck -> Handler Html
+getDeckCollabsR :: KeyHashid Deck -> Handler TypedContent
 getDeckCollabsR deckHash = do
     deckID <- decodeKeyHashid404 deckHash
-    (deck, actor, collabs, invites, joins) <- runDB $ do
+    collabs <- runDB $ do
-        deck <- get404 deckID
+        _deck <- get404 deckID
-        actor <- getJust $ deckActor deck
+        grants <- getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
-        collabs <- do
+        for grants $ \ (role, actor, _ct, time) ->
-            grants <-
+            (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
-                getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
+    h <- asksSite siteInstanceHost
-            for grants $ \ (role, actor, ct, time) ->
+    encodeRouteLocal <- getEncodeRouteLocal
-                (,role,ct,time) <$> getPersonWidgetInfo actor
+    encodeRouteHome <- getEncodeRouteHome
-        invites <- do
+    hashPerson <- getEncodeKeyHashid
-            invites' <-
+    let makeItem (role, time, i) = AP.Relationship
-                getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID
+            { AP.relationshipId           = Nothing
-            for invites' $ \ (inviter, recip, time, role) -> (,,,)
+            , AP.relationshipExtraTypes   = []
-                <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+            , AP.relationshipSubject      = encodeRouteHome $ DeckR deckHash
-                <*> getPersonWidgetInfo recip
+            , AP.relationshipProperty     = Left AP.RelHasCollab
-                <*> pure time
+            , AP.relationshipObject       =
-                <*> pure role
+                case i of
-        joins <- do
+                    Left personID -> encodeRouteHome $ PersonR $ hashPerson personID
-            joins' <-
+                    Right u -> u
-                getTopicJoins CollabTopicDeckCollab CollabTopicDeckDeck deckID
+            , AP.relationshipAttributedTo = encodeRouteLocal $ DeckR deckHash
-            for joins' $ \ (recip, time, role) ->
+            , AP.relationshipPublished    = Just time
-                (,time,role) <$> getPersonWidgetInfo recip
+            , AP.relationshipUpdated      = Nothing
-        return (deck, actor, collabs, invites, joins)
+            , AP.relationshipInstrument   = Just role
-    defaultLayout $(widgetFile "deck/collab/list")
+            }
+        collabsAP = AP.Collection
+            { AP.collectionId         = encodeRouteLocal $ DeckCollabsR deckHash
+            , AP.collectionType       = CollectionTypeUnordered
+            , AP.collectionTotalItems = Just $ length collabs
+            , AP.collectionCurrent    = Nothing
+            , AP.collectionFirst      = Nothing
+            , AP.collectionLast       = Nothing
+            , AP.collectionItems      = map (Doc h . makeItem) collabs
+            , AP.collectionContext    =
+                Just $ encodeRouteLocal $ DeckR deckHash
+            }
+    provideHtmlAndAP collabsAP $ getHtml deckID
     where
-    grabPerson actorID = do
+    getHtml deckID = do
-        actorByKey <- getLocalActor actorID
+        (deck, actor, collabs, invites, joins) <- handlerToWidget $ runDB $ do
-        case actorByKey of
+            deck <- get404 deckID
-            LocalActorPerson personID -> return personID
+            actor <- getJust $ deckActor deck
-            _ -> error "Surprise, local inviter actor isn't a Person"
+            collabs <- do
+                grants <-
+                    getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
+                for grants $ \ (role, actor, ct, time) ->
+                    (,role,ct,time) <$> getPersonWidgetInfo actor
+            invites <- do
+                invites' <-
+                    getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID
+                for invites' $ \ (inviter, recip, time, role) -> (,,,)
+                    <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+                    <*> getPersonWidgetInfo recip
+                    <*> pure time
+                    <*> pure role
+            joins <- do
+                joins' <-
+                    getTopicJoins CollabTopicDeckCollab CollabTopicDeckDeck deckID
+                for joins' $ \ (recip, time, role) ->
+                    (,time,role) <$> getPersonWidgetInfo recip
+            return (deck, actor, collabs, invites, joins)
+        $(widgetFile "deck/collab/list")
+        where
+        grabPerson actorID = do
+            actorByKey <- getLocalActor actorID
+            case actorByKey of
+                LocalActorPerson personID -> return personID
+                _ -> error "Surprise, local inviter actor isn't a Person"
 
 getDeckInviteR :: KeyHashid Deck -> Handler Html
 getDeckInviteR deckHash = do