diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 37bd97c..2baa83f 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/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 - mp <- maybeAuthId - haveAdmin <- 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 - (deck, actor, stems, drafts) <- runDB $ do + stems <- runDB $ do deck <- get404 deckID - actor <- getJust $ deckActor deck - stems <- getStems $ deckKomponent deck - drafts <- getStemDrafts $ deckKomponent deck - return (deck, actor, stems, drafts) - defaultLayout $(widgetFile "deck/projects") + 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 <- handlerToWidget $ fmap isJust $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + deck <- lift $ get404 deckID + MaybeT $ getCapability personID (Left $ deckResource deck) AP.RoleAdmin + ((_, widgetAP), enctypeAP) <- handlerToWidget $ runFormPost addProjectForm + (deck, actor, drafts) <- handlerToWidget $ runDB $ do + deck <- get404 deckID + actor <- getJust $ deckActor deck + drafts <- getStemDrafts $ deckKomponent deck + return (deck, actor, drafts) + $(widgetFile "deck/projects") addProjectForm = renderDivs $ areq fedUriField "(URI) Project" Nothing diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index cd70a5a..d3a97c3 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/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 - mp <- maybeAuthId - haveAdmin <- 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 - (loom, actor, stems, drafts) <- runDB $ do + stems <- runDB $ do loom <- get404 loomID - actor <- getJust $ loomActor loom - stems <- getStems $ loomKomponent loom - drafts <- getStemDrafts $ loomKomponent loom - return (loom, actor, stems, drafts) - defaultLayout $(widgetFile "loom/projects") + 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 <- handlerToWidget $ fmap isJust $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + loom <- lift $ get404 loomID + MaybeT $ getCapability personID (Left $ loomResource loom) AP.RoleAdmin + ((_, widgetAP), enctypeAP) <- handlerToWidget $ runFormPost addProjectForm + (loom, actor, drafts) <- handlerToWidget $ runDB $ do + loom <- get404 loomID + actor <- getJust $ loomActor loom + drafts <- getStemDrafts $ loomKomponent loom + return (loom, actor, drafts) + $(widgetFile "loom/projects") addProjectForm = renderDivs $ areq fedUriField "(URI) Project" Nothing diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 763e3fb..8985045 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/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 - mp <- maybeAuthId - haveAdmin <- 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 - (repo, actor, stems, drafts) <- runDB $ do + stems <- runDB $ do repo <- get404 repoID - actor <- getJust $ repoActor repo - stems <- getStems $ repoKomponent repo - drafts <- getStemDrafts $ repoKomponent repo - return (repo, actor, stems, drafts) - hashLoom <- getEncodeKeyHashid - defaultLayout $(widgetFile "repo/projects") + 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 <- handlerToWidget $ fmap isJust $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + repo <- lift $ get404 repoID + MaybeT $ getCapability personID (Left $ repoResource repo) AP.RoleAdmin + ((_, widgetAP), enctypeAP) <- handlerToWidget $ runFormPost addProjectForm + (repo, actor, drafts) <- handlerToWidget $ runDB $ do + repo <- get404 repoID + actor <- getJust $ repoActor repo + drafts <- getStemDrafts $ repoKomponent repo + return (repo, actor, drafts) + hashLoom <- getEncodeKeyHashid + $(widgetFile "repo/projects") postRepoAddProjectR :: KeyHashid Repo -> Handler () postRepoAddProjectR repoHash = do