Serve AP version of component projects collection

src/Vervis/Handler/Deck.hs

@@ -85,6 +85,7 @@ import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
 import Network.HTTP.Types.Method
+import Optics.Core
 import Text.Blaze.Html (Html)
 import Yesod.Auth
 import Yesod.Core
@@ -455,22 +456,53 @@ postDeckRemoveR deckHash collabID = do
     resourceID <- runDB $ deckResource <$> get404 deckID
     serveRemoveCollab resourceID (DeckCollabsR deckHash) collabID
 
-getDeckProjectsR :: KeyHashid Deck -> Handler Html
+getDeckProjectsR :: KeyHashid Deck -> Handler TypedContent
 getDeckProjectsR deckHash = do
     deckID <- decodeKeyHashid404 deckHash
+    stems <- runDB $ do
+        deck <- get404 deckID
+        getStems $ deckKomponent deck
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashProject <- getEncodeKeyHashid
+    let projectsAP = Collection
+            { collectionId         = encodeRouteLocal $ DeckProjectsR deckHash
+            , collectionType       = CollectionTypeUnordered
+            , collectionTotalItems = Just $ length stems
+            , collectionCurrent    = Nothing
+            , collectionFirst      = Nothing
+            , collectionLast       = Nothing
+            , collectionItems      =
+                map ( either
+                        ( encodeRouteHome
+                        . ProjectR
+                        . hashProject
+                        . fst
+                        )
+                        (\ (Instance h, RemoteObject _ lu , _) -> ObjURI h lu)
+                    . view _1
+                    )
+                    stems
+            , collectionContext    =
+                Just $ encodeRouteLocal $ DeckR deckHash
+            }
+    provideHtmlAndAP projectsAP $ getHtml deckID stems
+
+    where
+
+    getHtml deckID stems = do
         mp <- maybeAuthId
-    haveAdmin <- fmap isJust $ runDB $ runMaybeT $ do
+        haveAdmin <- handlerToWidget $ fmap isJust $ runDB $ runMaybeT $ do
             personID <- MaybeT $ pure mp
             deck <- lift $ get404 deckID
             MaybeT $ getCapability personID (Left $ deckResource deck) AP.RoleAdmin
-    ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm
+        ((_, widgetAP), enctypeAP) <- handlerToWidget $ runFormPost addProjectForm
-    (deck, actor, stems, drafts) <- runDB $ do
+        (deck, actor, drafts) <- handlerToWidget $ runDB $ do
             deck <- get404 deckID
             actor <- getJust $ deckActor deck
-        stems <- getStems $ deckKomponent deck
             drafts <- getStemDrafts $ deckKomponent deck
-        return (deck, actor, stems, drafts)
+            return (deck, actor, drafts)
-    defaultLayout $(widgetFile "deck/projects")
+        $(widgetFile "deck/projects")
 
 addProjectForm = renderDivs $
     areq fedUriField "(URI) Project" Nothing

src/Vervis/Handler/Loom.hs

@@ -61,6 +61,7 @@ import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
+import Optics.Core
 import Text.Blaze.Html (Html)
 import Yesod.Auth
 import Yesod.Core
@@ -407,22 +408,53 @@ postLoomRemoveR loomHash collabID = do
     resourceID <- runDB $ loomResource <$> get404 loomID
     serveRemoveCollab resourceID (LoomCollabsR loomHash) collabID
 
-getLoomProjectsR :: KeyHashid Loom -> Handler Html
+getLoomProjectsR :: KeyHashid Loom -> Handler TypedContent
 getLoomProjectsR loomHash = do
     loomID <- decodeKeyHashid404 loomHash
+    stems <- runDB $ do
+        loom <- get404 loomID
+        getStems $ loomKomponent loom
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashProject <- getEncodeKeyHashid
+    let projectsAP = AP.Collection
+            { AP.collectionId         = encodeRouteLocal $ LoomProjectsR loomHash
+            , AP.collectionType       = AP.CollectionTypeUnordered
+            , AP.collectionTotalItems = Just $ length stems
+            , AP.collectionCurrent    = Nothing
+            , AP.collectionFirst      = Nothing
+            , AP.collectionLast       = Nothing
+            , AP.collectionItems      =
+                map ( either
+                        ( encodeRouteHome
+                        . ProjectR
+                        . hashProject
+                        . fst
+                        )
+                        (\ (Instance h, RemoteObject _ lu , _) -> ObjURI h lu)
+                    . view _1
+                    )
+                    stems
+            , AP.collectionContext    =
+                Just $ encodeRouteLocal $ LoomR loomHash
+            }
+    provideHtmlAndAP projectsAP $ getHtml loomID stems
+
+    where
+
+    getHtml loomID stems = do
         mp <- maybeAuthId
-    haveAdmin <- fmap isJust $ runDB $ runMaybeT $ do
+        haveAdmin <- handlerToWidget $ fmap isJust $ runDB $ runMaybeT $ do
             personID <- MaybeT $ pure mp
             loom <- lift $ get404 loomID
             MaybeT $ getCapability personID (Left $ loomResource loom) AP.RoleAdmin
-    ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm
+        ((_, widgetAP), enctypeAP) <- handlerToWidget $ runFormPost addProjectForm
-    (loom, actor, stems, drafts) <- runDB $ do
+        (loom, actor, drafts) <- handlerToWidget $ runDB $ do
             loom <- get404 loomID
             actor <- getJust $ loomActor loom
-        stems <- getStems $ loomKomponent loom
             drafts <- getStemDrafts $ loomKomponent loom
-        return (loom, actor, stems, drafts)
+            return (loom, actor, drafts)
-    defaultLayout $(widgetFile "loom/projects")
+        $(widgetFile "loom/projects")
 
 addProjectForm = renderDivs $
     areq fedUriField "(URI) Project" Nothing

src/Vervis/Handler/Repo.hs

@@ -123,6 +123,7 @@ import Network.Git.Transport.HTTP.Fetch.UploadRequest
 import Network.Git.Types
 import Network.HTTP.Types.Method
 import Network.Wai (strictRequestBody)
+import Optics.Core
 import System.Directory
 import System.FilePath
 import System.Hourglass (dateCurrent)
@@ -835,23 +836,54 @@ postRepoRemoveR repoHash collabID = do
 addProjectForm = renderDivs $
     areq fedUriField "(URI) Project" Nothing
 
-getRepoProjectsR :: KeyHashid Repo -> Handler Html
+getRepoProjectsR :: KeyHashid Repo -> Handler TypedContent
 getRepoProjectsR repoHash = do
     repoID <- decodeKeyHashid404 repoHash
+    stems <- runDB $ do
+        repo <- get404 repoID
+        getStems $ repoKomponent repo
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashProject <- getEncodeKeyHashid
+    let projectsAP = AP.Collection
+            { AP.collectionId         = encodeRouteLocal $ RepoProjectsR repoHash
+            , AP.collectionType       = AP.CollectionTypeUnordered
+            , AP.collectionTotalItems = Just $ length stems
+            , AP.collectionCurrent    = Nothing
+            , AP.collectionFirst      = Nothing
+            , AP.collectionLast       = Nothing
+            , AP.collectionItems      =
+                map ( either
+                        ( encodeRouteHome
+                        . ProjectR
+                        . hashProject
+                        . fst
+                        )
+                        (\ (Instance h, RemoteObject _ lu , _) -> ObjURI h lu)
+                    . view _1
+                    )
+                    stems
+            , AP.collectionContext    =
+                Just $ encodeRouteLocal $ RepoR repoHash
+            }
+    provideHtmlAndAP projectsAP $ getHtml repoID stems
+
+    where
+
+    getHtml repoID stems = do
         mp <- maybeAuthId
-    haveAdmin <- fmap isJust $ runDB $ runMaybeT $ do
+        haveAdmin <- handlerToWidget $ fmap isJust $ runDB $ runMaybeT $ do
             personID <- MaybeT $ pure mp
             repo <- lift $ get404 repoID
             MaybeT $ getCapability personID (Left $ repoResource repo) AP.RoleAdmin
-    ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm
+        ((_, widgetAP), enctypeAP) <- handlerToWidget $ runFormPost addProjectForm
-    (repo, actor, stems, drafts) <- runDB $ do
+        (repo, actor, drafts) <- handlerToWidget $ runDB $ do
             repo <- get404 repoID
             actor <- getJust $ repoActor repo
-        stems <- getStems $ repoKomponent repo
             drafts <- getStemDrafts $ repoKomponent repo
-        return (repo, actor, stems, drafts)
+            return (repo, actor, drafts)
         hashLoom <- getEncodeKeyHashid
-    defaultLayout $(widgetFile "repo/projects")
+        $(widgetFile "repo/projects")
 
 postRepoAddProjectR :: KeyHashid Repo -> Handler ()
 postRepoAddProjectR repoHash = do