diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 626daeb..2642a3c 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -79,7 +79,7 @@ import Data.Traversable import Database.Persist import Network.HTTP.Types.Method import Text.Blaze.Html (Html) -import Yesod.Auth (requireAuth) +import Yesod.Auth import Yesod.Core import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Form.Functions (runFormPost, runFormGet) @@ -257,6 +257,11 @@ getDeckTicketsR deckHash = selectRep $ do (Just (off, lim)) deckID (deck,actor,) <$> getPageAndNavCount countAllTickets selectTickets + permits <- do + mp <- maybeAuthId + case mp of + Nothing -> pure [] + Just personID -> runDB $ getPermitsForResource personID (Left $ deckActor deck) case mpage of Nothing -> redirectFirstPage here Just (rows, navModel) -> diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 194ed9a..20eafba 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -71,7 +71,7 @@ import Database.Persist import Network.HTTP.Types.Method import Optics.Core import Text.Blaze.Html (Html) -import Yesod.Auth (requireAuth) +import Yesod.Auth import Yesod.Core import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Form.Functions (runFormPost, runFormGet) @@ -161,12 +161,17 @@ postGroupNewR = do getGroupR :: KeyHashid Group -> Handler TypedContent getGroupR groupHash = do groupID <- decodeKeyHashid404 groupHash - (group, actor, sigKeyIDs) <- runDB $ do + mp <- maybeAuthId + (group, actor, sigKeyIDs, permits) <- runDB $ do g <- get404 groupID let aid = groupActor g a <- getJust aid sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId] - return (g, a, sigKeys) + permits <- + case mp of + Nothing -> pure [] + Just personID -> getPermitsForResource personID (Left aid) + return (g, a, sigKeys, permits) encodeRouteLocal <- getEncodeRouteLocal hashSigKey <- getEncodeKeyHashid diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index bbf075c..40bf679 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022, 2023 by fr33domlover . + - Written in 2022, 2023, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -48,7 +48,7 @@ import Data.Time.Clock import Data.Traversable import Database.Persist import Text.Blaze.Html (Html) -import Yesod.Auth (requireAuth) +import Yesod.Auth import Yesod.Core import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Form.Functions (runFormPost, runFormGet) @@ -87,6 +87,7 @@ import Vervis.Form.Tracker import Vervis.Foundation import Vervis.Model import Vervis.Paginate +import Vervis.Persist.Collab import Vervis.Recipient import Vervis.Settings import Vervis.Ticket @@ -210,6 +211,11 @@ getLoomClothsR loomHash = selectRep $ do (Just (off, lim)) loomID (loom,actor,) <$> getPageAndNavCount countAllTickets selectTickets + permits <- do + mp <- maybeAuthId + case mp of + Nothing -> pure [] + Just personID -> runDB $ getPermitsForResource personID (Left $ loomActor loom) case mpage of Nothing -> redirectFirstPage here Just (rows, navModel) -> diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 7b72d5a..8655f72 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -66,7 +66,7 @@ import Database.Persist import Network.HTTP.Types.Method import Optics.Core import Text.Blaze.Html (Html) -import Yesod.Auth (requireAuth) +import Yesod.Auth import Yesod.Core import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Form.Functions (runFormPost, runFormGet) @@ -125,12 +125,17 @@ import qualified Vervis.Client as C getProjectR :: KeyHashid Project -> Handler TypedContent getProjectR projectHash = do projectID <- decodeKeyHashid404 projectHash - (project, actor, sigKeyIDs) <- runDB $ do + mp <- maybeAuthId + (project, actor, sigKeyIDs, permits) <- runDB $ do d <- get404 projectID let aid = projectActor d a <- getJust aid sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId] - return (d, a, sigKeys) + permits <- + case mp of + Nothing -> pure [] + Just personID -> getPermitsForResource personID (Left aid) + return (d, a, sigKeys, permits) encodeRouteLocal <- getEncodeRouteLocal hashSigKey <- getEncodeKeyHashid diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 762bcae..bdf9a4e 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2022, 2023 + - Written in 2016, 2018, 2019, 2020, 2022, 2023, 2024 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index d5233bd..c39501c 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -51,6 +51,8 @@ module Vervis.Persist.Collab , verifyNoEnabledGroupChildren , getGrantActivityBody + + , getPermitsForResource ) where @@ -85,6 +87,7 @@ import Data.Maybe.Local import Database.Persist.Local import Vervis.Actor +import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.FedURI import Vervis.Model @@ -1060,3 +1063,76 @@ getGrantActivityBody k = do case AP.activitySpecific act of AP.GrantActivity g -> return (doc, g) _ -> error "Not a Grant activity" + +getPermitsForResource + :: MonadIO m + => PersonId + -> Either ActorId RemoteActorId + -> ReaderT SqlBackend m + [ ( Either (LocalActorBy Key, OutboxItemId) FedURI + , AP.Role + , Either + (LocalActorBy Key, Actor) + (Instance, RemoteObject, RemoteActor) + ) + ] +getPermitsForResource personID actor = do + exts <- + case actor of + Left actorID -> + E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do + E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceLocalPermit + E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit + E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit + E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + resource E.^. PermitTopicExtendResourceLocalActor E.==. E.val actorID + return + ( permit E.^. PermitId + , extend E.^. PermitTopicExtendId + , extend E.^. PermitTopicExtendRole + ) + Right actorID -> + E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do + E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceRemotePermit + E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit + E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit + E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + resource E.^. PermitTopicExtendResourceRemoteActor E.==. E.val actorID + return + ( permit E.^. PermitId + , extend E.^. PermitTopicExtendId + , extend E.^. PermitTopicExtendRole + ) + for exts $ \ (E.Value permitID, E.Value extendID, E.Value role) -> do + sender <- + requireEitherAlt + (getValBy $ UniquePermitTopicExtendLocal extendID) + (getValBy $ UniquePermitTopicExtendRemote extendID) + "PermitTopicExtend* neither" + "PermitTopicExtend* both" + (uExt, via) <- + case sender of + Left (PermitTopicExtendLocal _ enableID grantID) -> do + PermitTopicEnableLocal _ topicID _ <- getJust enableID + byk <- getPermitTopicLocal topicID + bye <- do + m <- getLocalActorEntity byk + case m of + Nothing -> error "I just found this PermitTopicLocal in DB but now the specific actor ID isn't found" + Just bye -> pure bye + a <- getJust $ localActorID bye + return (Left (byk, grantID), Left (byk, a)) + Right (PermitTopicExtendRemote _ enableID grantID) -> do + PermitTopicEnableRemote _ topicID _ <- getJust enableID + PermitTopicRemote _ remoteActorID <- getJust topicID + remoteActor <- getJust remoteActorID + remoteObject <- getJust $ remoteActorIdent remoteActor + inztance <- getJust $ remoteObjectInstance remoteObject + grant <- getJust grantID + u <- getRemoteActivityURI grant + return (Right u, Right (inztance, remoteObject, remoteActor)) + return (uExt, role, via) diff --git a/src/Vervis/Web/Darcs.hs b/src/Vervis/Web/Darcs.hs index 9451847..e9a6081 100644 --- a/src/Vervis/Web/Darcs.hs +++ b/src/Vervis/Web/Darcs.hs @@ -33,6 +33,7 @@ import Network.HTTP.Types import System.FilePath ((), joinPath) import System.Directory (doesFileExist) import Text.Blaze.Html (Html) +import Yesod.Auth import Yesod.Core hiding (joinPath) import Yesod.Core.Content (TypedContent, typeOctet) import Yesod.Core.Handler (selectRep, provideRep, sendFile, notFound) @@ -69,6 +70,7 @@ import Vervis.Foundation import Vervis.Path import Vervis.Model import Vervis.Paginate +import Vervis.Persist.Collab import Vervis.Readme import Vervis.Settings import Vervis.SourceTree @@ -78,6 +80,7 @@ import Vervis.Web.Repo import Vervis.Widget import Vervis.Widget.Person import Vervis.Widget.Repo +import Vervis.Widget.Tracker import qualified Vervis.Darcs as D @@ -94,6 +97,11 @@ getDarcsRepoSource repository actor repo dir loomIDs = do looms <- runDB $ for loomIDs $ \ loomID -> do loom <- getJust loomID (loomID,) <$> getJust (loomActor loom) + permits <- do + mp <- maybeAuthId + case mp of + Nothing -> pure [] + Just personID -> runDB $ getPermitsForResource personID (Left $ repoActor repository) defaultLayout $ do hashLoom <- getEncodeKeyHashid host <- asksSite siteInstanceHost diff --git a/src/Vervis/Web/Git.hs b/src/Vervis/Web/Git.hs index 5687e6d..5685f7a 100644 --- a/src/Vervis/Web/Git.hs +++ b/src/Vervis/Web/Git.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2022 + - Written in 2016, 2018, 2019, 2020, 2022, 2024 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -46,6 +46,7 @@ import Network.HTTP.Types import System.Directory (createDirectoryIfMissing) import System.Hourglass (dateCurrent) import Text.Blaze.Html (Html) +import Yesod.Auth import Yesod.Core import Yesod.Core.Content (TypedContent) import Yesod.Core.Handler (selectRep, provideRep, notFound) @@ -83,6 +84,7 @@ import Vervis.Model import Vervis.Model.Ident import Development.PatchMediaType import Vervis.Paginate +import Vervis.Persist.Collab import Vervis.Readme import Vervis.Settings import Vervis.SourceTree @@ -92,6 +94,7 @@ import Vervis.Web.Repo import Vervis.Widget import Vervis.Widget.Person import Vervis.Widget.Repo +import Vervis.Widget.Tracker import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Vervis.Git as G @@ -109,6 +112,11 @@ getGitRepoSource repository actor repo ref dir loomIDs = do looms <- runDB $ for loomIDs $ \ loomID -> do loom <- getJust loomID (loomID,) <$> getJust (loomActor loom) + permits <- do + mp <- maybeAuthId + case mp of + Nothing -> pure [] + Just personID -> runDB $ getPermitsForResource personID (Left $ repoActor repository) defaultLayout $ do hashLoom <- getEncodeKeyHashid host <- asksSite siteInstanceHost diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index e157ba0..4a22fff 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/src/Vervis/Widget/Tracker.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022, 2023 by fr33domlover . + - Written in 2019, 2022, 2023, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -22,6 +22,7 @@ module Vervis.Widget.Tracker , groupLinkFedW , actorLinkFedW , groupNavW + , personPermitsForResourceW ) where @@ -32,17 +33,22 @@ import Yesod.Core.Widget import Yesod.Persist.Core import Network.FedURI +import Yesod.FedURI import Yesod.Hashids import qualified Web.ActivityPub as AP import Vervis.Actor +import Vervis.Data.Actor import Vervis.Data.Collab +import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Settings +import qualified Vervis.Recipient as VR + deckNavW :: Entity Deck -> Actor -> Widget deckNavW (Entity deckID deck) actor = do deckHash <- encodeKeyHashid deckID @@ -172,3 +178,32 @@ actorLinkFedW (Right (inztance, object, actor)) = AP.ActorTypeProject -> '$' AP.ActorTypeTeam -> '&' AP.ActorTypeOther _ -> '?' + +personPermitsForResourceW + :: [ ( Either (LocalActorBy Key, OutboxItemId) FedURI + , AP.Role + , Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor) + ) + ] + -> Widget +personPermitsForResourceW [] = pure () +personPermitsForResourceW permits = do + encodeRouteHome <- getEncodeRouteHome + hashItem <- getEncodeKeyHashid + hashActor <- VR.getHashLocalActor + [whamlet| +

My access +