forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Serve AP version of component projects collection

Browse source
This commit is contained in:
Pere Lev 2024-07-04 14:17:21 +03:00
parent ef8151c7cb
commit 26ace5f9b8
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
3 changed files with 136 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

58
src/Vervis/Handler/Deck.hs
View file

@ -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

58
src/Vervis/Handler/Loom.hs
View file

@ -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

60
src/Vervis/Handler/Repo.hs
View file

@ -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