UI: In my-grants-for-given-resource display, list direct grants as well

Previously, only extensions were being displayed. Adding direct grants
required DB schema changes, which the previous huge commit did.

src/Vervis/Persist/Collab.hs

@@ -960,12 +960,57 @@ getPermitsForResource
     -> ReaderT SqlBackend m
         [ ( Either (LocalActorBy Key, OutboxItemId) FedURI
           , AP.Role
-          , Either
+          , Maybe
-              (LocalActorBy Key, Actor)
+                (Either
-              (Instance, RemoteObject, RemoteActor)
+                    (LocalActorBy Key, Actor)
+                    (Instance, RemoteObject, RemoteActor)
+                )
           )
         ]
 getPermitsForResource personID actor = do
+    direct <-
+        bitraverse
+            (\ resourceID ->
+                fmap (resourceID,) $
+                E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
+                    E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
+                    E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
+                    E.where_ $
+                        permit E.^. PermitPerson E.==. E.val personID E.&&.
+                        topic E.^. PermitTopicLocalTopic E.==. E.val resourceID
+                    return
+                        ( permit E.^. PermitRole
+                        , enable E.^. PermitTopicEnableLocalGrant
+                        )
+            )
+            (\ actorID ->
+                E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
+                    E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
+                    E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
+                    E.where_ $
+                        permit E.^. PermitPerson E.==. E.val personID E.&&.
+                        topic E.^. PermitTopicRemoteActor E.==. E.val actorID
+                    return
+                        ( permit E.^. PermitRole
+                        , enable E.^. PermitTopicEnableRemoteGrant
+                        )
+            )
+            actor
+    directsFinal <-
+        case direct of
+            Left (resourceID, ds) -> do
+                lr <- getLocalResource resourceID
+                let la = resourceToActor lr
+                return $
+                    map
+                        (\ (E.Value role, E.Value grantID) ->
+                            (Left (la, grantID), role, Nothing)
+                        )
+                        ds
+            Right ds -> for ds $ \ (E.Value role, E.Value grantID) -> do
+                grant <- getJust grantID
+                u <- getRemoteActivityURI grant
+                return (Right u, role, Nothing)
     exts <-
         case actor of
             Left resourceID ->
@@ -996,34 +1041,36 @@ getPermitsForResource personID actor = do
                         , extend E.^. PermitTopicExtendId
                         , extend E.^. PermitTopicExtendRole
                         )
-    for exts $ \ (E.Value permitID, E.Value extendID, E.Value role) -> do
+    extsFinal <-
-        sender <-
+        for exts $ \ (E.Value permitID, E.Value extendID, E.Value role) -> do
-            requireEitherAlt
+            sender <-
-                (getValBy $ UniquePermitTopicExtendLocal extendID)
+                requireEitherAlt
-                (getValBy $ UniquePermitTopicExtendRemote extendID)
+                    (getValBy $ UniquePermitTopicExtendLocal extendID)
-                "PermitTopicExtend* neither"
+                    (getValBy $ UniquePermitTopicExtendRemote extendID)
-                "PermitTopicExtend* both"
+                    "PermitTopicExtend* neither"
-        (uExt, via) <-
+                    "PermitTopicExtend* both"
-            case sender of
+            (uExt, via) <-
-                Left (PermitTopicExtendLocal _ enableID grantID) -> do
+                case sender of
-                    PermitTopicEnableLocal _ topicID _ <- getJust enableID
+                    Left (PermitTopicExtendLocal _ enableID grantID) -> do
-                    byk <- getPermitTopicLocal topicID
+                        PermitTopicEnableLocal _ topicID _ <- getJust enableID
-                    bye <- do
+                        byk <- getPermitTopicLocal topicID
-                        m <- getLocalResourceEntity byk
+                        bye <- do
-                        case m of
+                            m <- getLocalResourceEntity byk
-                            Nothing -> error "I just found this PermitTopicLocal in DB but now the specific actor ID isn't found"
+                            case m of
-                            Just bye -> pure bye
+                                Nothing -> error "I just found this PermitTopicLocal in DB but now the specific actor ID isn't found"
-                    Resource aid <- getJust $ localResourceID bye
+                                Just bye -> pure bye
-                    a <- getJust aid
+                        Resource aid <- getJust $ localResourceID bye
-                    let byk' = resourceToActor byk
+                        a <- getJust aid
-                    return (Left (byk', grantID), Left (byk', a))
+                        let byk' = resourceToActor byk
-                Right (PermitTopicExtendRemote _ enableID grantID) -> do
+                        return (Left (byk', grantID), Left (byk', a))
-                    PermitTopicEnableRemote _ topicID _ <- getJust enableID
+                    Right (PermitTopicExtendRemote _ enableID grantID) -> do
-                    PermitTopicRemote _ remoteActorID <- getJust topicID
+                        PermitTopicEnableRemote _ topicID _ <- getJust enableID
-                    remoteActor <- getJust remoteActorID
+                        PermitTopicRemote _ remoteActorID <- getJust topicID
-                    remoteObject <- getJust $ remoteActorIdent remoteActor
+                        remoteActor <- getJust remoteActorID
-                    inztance <- getJust $ remoteObjectInstance remoteObject
+                        remoteObject <- getJust $ remoteActorIdent remoteActor
-                    grant <- getJust grantID
+                        inztance <- getJust $ remoteObjectInstance remoteObject
-                    u <- getRemoteActivityURI grant
+                        grant <- getJust grantID
-                    return (Right u, Right (inztance, remoteObject, remoteActor))
+                        u <- getRemoteActivityURI grant
-        return (uExt, role, via)
+                        return (Right u, Right (inztance, remoteObject, remoteActor))
+            return (uExt, role, Just via)
+    return $ directsFinal ++ extsFinal

src/Vervis/Widget/Tracker.hs

@@ -182,7 +182,11 @@ actorLinkFedW (Right (inztance, object, actor)) =
 personPermitsForResourceW
     :: [ ( Either (LocalActorBy Key, OutboxItemId) FedURI
          , AP.Role
-         , Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor)
+         , Maybe
+            (Either
+                (LocalActorBy Key, Actor)
+                (Instance, RemoteObject, RemoteActor)
+            )
          )
        ]
     -> Widget
@@ -194,7 +198,7 @@ personPermitsForResourceW permits = do
     [whamlet|
         <h3>My access
         <ul>
-          $forall (u, role, via) <- permits
+          $forall (u, role, mvia) <- permits
             <li>
               $case u
                 $of Left (la, i)
@@ -204,6 +208,7 @@ personPermitsForResourceW permits = do
                   <a href="#{renderObjURI u'}">
                     Grant
               [ #{show role} ] #
-              \ via #
+              $maybe via <- mvia
-              [ ^{actorLinkFedW via} ]
+                \ via #
+                [ ^{actorLinkFedW via} ]
     |]