UI: When logged in, display my delegated access to a given local resource

This displays only delegated Grants, not direct ones. Direct ones will be added in the next commits, as they require some extra changes in the database.
2024-04-20 01:59:13 +03:00 · 2024-04-20 01:59:13 +03:00 · fc9d56dd34
commit fc9d56dd34
parent 4fe3f9f332
15 changed files with 178 additions and 18 deletions
--- 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) ->
--- 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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) ->
--- 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
--- 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 <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
--- 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)
--- 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
--- 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 <fr33domlover@riseup.net>.
 -
 - ♡ 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
--- 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 <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ 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|
+        <h3>My access
+        <ul>
+          $forall (u, role, via) <- permits
+            <li>
+              $case u
+                $of Left (la, i)
+                  <a href="#{renderObjURI $ encodeRouteHome $ activityRoute (hashActor la) (hashItem i)}">
+                    Grant
+                $of Right u'
+                  <a href="#{renderObjURI u'}">
+                    Grant
+              [ #{show role} ] #
+              \ via #
+              [ ^{actorLinkFedW via} ]
+    |]
--- a/templates/cloth/list.hamlet
+++ b/templates/cloth/list.hamlet
@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018, 2022 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@ -14,6 +14,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.

 ^{loomNavW (Entity loomID loom) actor}

+^{personPermitsForResourceW permits}
+
 <p>
  <a href=@{ClothNewR loomHash}>Create new…

--- a/templates/group/one.hamlet
+++ b/templates/group/one.hamlet
@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@ -13,3 +13,5 @@ $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.

 ^{groupNavW (Entity groupID group) actor}
+
+^{personPermitsForResourceW permits}
--- a/templates/project/one.hamlet
+++ b/templates/project/one.hamlet
@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@ -13,3 +13,5 @@ $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.

 ^{projectNavW (Entity projectID project) actor}
+
+^{personPermitsForResourceW permits}
--- a/templates/repo/source-darcs.hamlet
+++ b/templates/repo/source-darcs.hamlet
@ -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 <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
@ -56,6 +56,8 @@ $# ^{personNavW user}
      <a href=@{LoomClothsR $ hashLoom loomID}>
        [🧩 Patches]

+^{personPermitsForResourceW permits}
+
 ^{followButton}

 $if not $ null looms
--- a/templates/repo/source-git.hamlet
+++ b/templates/repo/source-git.hamlet
@ -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 <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
@ -56,6 +56,8 @@ $# ^{personNavW user}
      <a href=@{LoomClothsR $ hashLoom loomID}>
        [🧩 Merge Requests]

+^{personPermitsForResourceW permits}
+
 ^{followButton}

 $if not $ null looms
--- a/templates/ticket/list.hamlet
+++ b/templates/ticket/list.hamlet
@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018, 2022 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@ -14,6 +14,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.

 ^{deckNavW (Entity deckID deck) actor}

+^{personPermitsForResourceW permits}
+
 <p>
  <a href=@{TicketNewR deckHash}>Create new…