From 5dadc13ccea326a738beb8241fe1da60ab8ee467 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Thu, 14 Mar 2024 22:25:27 +0200
Subject: [PATCH] Deck: Serve AP version of collabs list page

---
 src/Vervis/Handler/Deck.hs | 98 ++++++++++++++++++++++++++------------
 1 file changed, 68 insertions(+), 30 deletions(-)

diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs
index 0be9469..626daeb 100644
--- a/src/Vervis/Handler/Deck.hs
+++ b/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
-        deck <- get404 deckID
-        actor <- getJust $ deckActor deck
-        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)
-    defaultLayout $(widgetFile "deck/collab/list")
+    collabs <- runDB $ do
+        _deck <- get404 deckID
+        grants <- getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
+        for grants $ \ (role, actor, _ct, time) ->
+            (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
+    h <- asksSite siteInstanceHost
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashPerson <- getEncodeKeyHashid
+    let makeItem (role, time, i) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome $ DeckR deckHash
+            , AP.relationshipProperty     = Left AP.RelHasCollab
+            , AP.relationshipObject       =
+                case i of
+                    Left personID -> encodeRouteHome $ PersonR $ hashPerson personID
+                    Right u -> u
+            , AP.relationshipAttributedTo = encodeRouteLocal $ DeckR deckHash
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        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
-        actorByKey <- getLocalActor actorID
-        case actorByKey of
-            LocalActorPerson personID -> return personID
-            _ -> error "Surprise, local inviter actor isn't a Person"
+    getHtml deckID = do
+        (deck, actor, collabs, invites, joins) <- handlerToWidget $ runDB $ do
+            deck <- get404 deckID
+            actor <- getJust $ deckActor deck
+            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