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.

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

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

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

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

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.

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)

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

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

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} ]
+    |]

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…
 

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}

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}

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

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

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…