UI: Display personal resources using Permit records

src/Vervis/Actor.hs

@@ -80,6 +80,8 @@ module Vervis.Actor
     , sendToLocalActors
 
     , actorIsAddressed
+
+    , localActorType
     )
 where
 
@@ -714,3 +716,12 @@ actorIsAddressed recips = isJust . verify
     verify (LocalActorProject j) = do
         routes <- lookup j $ recipProjects recips
         guard $ routeProject routes
+
+localActorType :: LocalActorBy f -> AP.ActorType
+localActorType = \case
+    LocalActorPerson _ -> AP.ActorTypePerson
+    LocalActorRepo _ -> AP.ActorTypeRepo
+    LocalActorDeck _ -> AP.ActorTypeTicketTracker
+    LocalActorLoom _ -> AP.ActorTypePatchTracker
+    LocalActorProject _ -> AP.ActorTypeProject
+    LocalActorGroup _ -> AP.ActorTypeTeam

src/Vervis/Handler/Client.hs

@@ -53,12 +53,14 @@ import Control.Monad
 import Control.Monad.Trans.Except
 import Data.Bifunctor
 import Data.Bitraversable
+import Data.Function
 import Data.List
 import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
 import Text.Blaze.Html (preEscapedToHtml)
+import Optics.Core
 import Yesod.Auth
 import Yesod.Auth.Account
 import Yesod.Auth.Account.Message
@@ -89,6 +91,7 @@ import Data.EventTime.Local
 import Database.Persist.Local
 import Yesod.Form.Local
 
+import Vervis.Actor
 import Vervis.API
 import Vervis.Client
 import Vervis.Data.Actor
@@ -98,6 +101,7 @@ import Vervis.Form.Ticket
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.Settings
@@ -130,64 +134,87 @@ getHomeR = do
     where
     personalOverview :: Entity Person -> Handler Html
     personalOverview (Entity pid _person) = do
-        (repos, decks, looms, projects, groups) <- runDB $ (,,,,)
+        permits <- runDB $ do
-            <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
+            locals <- do
-                    E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
+                ls <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
-                    E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
+                    E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
-                    E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicRepoCollab
+                    E.where_ $ permit E.^. PermitPerson E.==. E.val pid
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
+                    E.orderBy [E.asc $ enable E.^. PermitTopicEnableLocalId]
-                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
+                    return
-                    E.orderBy [E.asc $ repo E.^. RepoId]
+                        ( permit E.^. PermitId
-                    return (repo, actor, collab)
+                        , permit E.^. PermitRole
+                        , topic E.^. PermitTopicLocalId
                         )
-            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do
+                for ls $ \ (E.Value permitID, E.Value role, E.Value topicID) -> do
-                    E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId
+                    topic <- getPermitTopicLocal topicID
-                    E.on $ topic E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId
+                    actorID <- do
-                    E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
+                        ma <- getLocalActorEntity topic
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab
+                        case ma of
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
+                            Nothing -> error "Impossible, we should have found the local actor in DB"
-                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
+                            Just a -> pure $ localActorID a
-                    E.orderBy [E.asc $ deck E.^. DeckId]
+                    actor <- getJust actorID
-                    return (deck, actor, collab)
+                    return
+                        ( permitID
+                        , role
+                        , localActorType topic
+                        , Left (topic, actor)
                         )
-            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do
+            remotes <- do
-                    E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId
+                rs <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
-                    E.on $ topic E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId
+                    E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
-                    E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLoomCollab
+                    E.where_ $ permit E.^. PermitPerson E.==. E.val pid
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
+                    E.orderBy [E.asc $ enable E.^. PermitTopicEnableRemoteId]
-                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
+                    return
-                    E.orderBy [E.asc $ loom E.^. LoomId]
+                        ( permit E.^. PermitId
-                    return (loom, actor, collab)
+                        , permit E.^. PermitRole
+                        , topic E.^. PermitTopicRemoteActor
                         )
-            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` project `E.InnerJoin` actor) -> do
+                for rs $ \ (E.Value permitID, E.Value role, E.Value remoteActorID) -> do
-                    E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
+                    remoteActor <- getJust remoteActorID
-                    E.on $ topic E.^. CollabTopicProjectProject E.==. project E.^. ProjectId
+                    remoteObject <- getJust $ remoteActorIdent remoteActor
-                    E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
+                    inztance <- getJust $ remoteObjectInstance remoteObject
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab
+                    return
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
+                        ( permitID
-                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
+                        , role
-                    E.orderBy [E.asc $ project E.^. ProjectId]
+                        , remoteActorType remoteActor
-                    return (project, actor, collab)
+                        , Right (inztance, remoteObject, remoteActor)
                         )
-            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` group `E.InnerJoin` actor) -> do
+            return $ locals ++ remotes
-                    E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
+        let (people, repos, decks, looms, projects, groups, others) =
-                    E.on $ topic E.^. CollabTopicGroupGroup E.==. group E.^. GroupId
+                partitionByActorType (view _3) (view _1) permits
-                    E.on $ topic E.^. CollabTopicGroupCollab E.==. enable E.^. CollabEnableCollab
+        if null people
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab
+            then pure ()
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
+            else error "Bug: Person as a PermitTopic"
-                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
-                    E.orderBy [E.asc $ group E.^. GroupId]
-                    return (group, actor, collab)
-                )
-        hashRepo <- getEncodeKeyHashid
-        hashDeck <- getEncodeKeyHashid
-        hashLoom <- getEncodeKeyHashid
-        hashProject <- getEncodeKeyHashid
-        hashGroup <- getEncodeKeyHashid
         defaultLayout $(widgetFile "personal-overview")
 
+        where
+
+        partitionByActorType
+            :: Eq b
+            => (a -> AP.ActorType)
+            -> (a -> b)
+            -> [a]
+            -> ([a], [a], [a], [a], [a], [a], [a])
+        partitionByActorType typ key xs =
+            let p = filter ((== AP.ActorTypePerson) . typ) xs
+                r = filter ((== AP.ActorTypeRepo) . typ) xs
+                d = filter ((== AP.ActorTypeTicketTracker) . typ) xs
+                l = filter ((== AP.ActorTypePatchTracker) . typ) xs
+                j = filter ((== AP.ActorTypeProject) . typ) xs
+                g = filter ((== AP.ActorTypeTeam) . typ) xs
+                x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g)
+            in  (p, r, d, l, j, g, x)
+
+        item (_permitID, role, _typ, actor) =
+            [whamlet|
+                [
+                #{show role}
+                ]
+                ^{actorLinkFedW actor}
+            |]
+
 getBrowseR :: Handler Html
 getBrowseR = do
     (people, groups, repos, decks, looms, projects) <- runDB $

src/Vervis/Persist/Collab.hs

@@ -17,6 +17,7 @@ module Vervis.Persist.Collab
     ( getCollabTopic
     , getCollabTopic'
     , getCollabRecip
+    , getPermitTopicLocal
     , getPermitTopic
     , getStemIdent
     , getStemProject
@@ -112,23 +113,11 @@ getCollabRecip collabID =
         "Collab without recip"
         "Collab with both local and remote recip"
 
-getPermitTopic
+getPermitTopicLocal
     :: MonadIO m
-    => PermitId
+    => PermitTopicLocalId
-    -> ReaderT SqlBackend m
+    -> ReaderT SqlBackend m (LocalActorBy Key)
-        (Either
+getPermitTopicLocal localID = do
-            (PermitTopicLocalId, LocalActorBy Key)
-            (PermitTopicRemoteId, RemoteActorId)
-        )
-getPermitTopic permitID = do
-    topic <-
-        requireEitherAlt
-            (getKeyBy $ UniquePermitTopicLocal permitID)
-            (getBy $ UniquePermitTopicRemote permitID)
-            "Permit without topic"
-            "Permit with both local and remote topic"
-    bitraverse
-        (\ localID -> (localID,) <$> do
     options <-
         sequence
             [ fmap (LocalActorRepo . permitTopicRepoRepo) <$>
@@ -146,7 +135,24 @@ getPermitTopic permitID = do
         options
         "Found Permit without topic"
         "Found Permit with multiple topics"
+
+getPermitTopic
+    :: MonadIO m
+    => PermitId
+    -> ReaderT SqlBackend m
+        (Either
+            (PermitTopicLocalId, LocalActorBy Key)
+            (PermitTopicRemoteId, RemoteActorId)
         )
+getPermitTopic permitID = do
+    topic <-
+        requireEitherAlt
+            (getKeyBy $ UniquePermitTopicLocal permitID)
+            (getBy $ UniquePermitTopicRemote permitID)
+            "Permit without topic"
+            "Permit with both local and remote topic"
+    bitraverse
+        (\ localID -> (localID,) <$> getPermitTopicLocal localID)
         (\ (Entity topicID (PermitTopicRemote _ actorID)) ->
             return (topicID, actorID)
         )

src/Vervis/Widget/Person.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -31,6 +31,8 @@ import Network.FedURI
 import Yesod.Auth.Unverified
 import Yesod.Hashids
 
+import qualified Web.ActivityPub as AP
+
 import Database.Persist.Local
 
 import Vervis.Foundation
@@ -54,13 +56,22 @@ personLinkFedW (Left (ep, a)) = personLinkW ep a
 personLinkFedW (Right (inztance, object, actor)) =
     [whamlet|
         <a href="#{renderObjURI uActor}">
+          #{marker $ remoteActorType actor} #
           $maybe name <- remoteActorName actor
-            #{name}
+            #{name} @ #{renderAuthority $ instanceHost inztance}
           $nothing
             #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
     |]
     where
     uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
+    marker = \case
+        AP.ActorTypePerson -> '~'
+        AP.ActorTypeRepo -> '^'
+        AP.ActorTypeTicketTracker -> '='
+        AP.ActorTypePatchTracker -> '+'
+        AP.ActorTypeProject -> '$'
+        AP.ActorTypeTeam -> '&'
+        AP.ActorTypeOther _ -> '?'
 
 followW :: Route App -> Route App -> FollowerSetId -> Widget
 followW followRoute unfollowRoute fsid = do

src/Vervis/Widget/Tracker.hs

@@ -19,19 +19,26 @@ module Vervis.Widget.Tracker
     , projectNavW
     , componentLinkFedW
     , projectLinkFedW
+    , actorLinkFedW
     , groupNavW
     )
 where
 
+import Database.Persist
 import Database.Persist.Types
 import Yesod.Core.Widget
+import Yesod.Persist.Core
 
 import Network.FedURI
 import Yesod.Hashids
 
+import qualified Web.ActivityPub as AP
+
+import Vervis.Actor
 import Vervis.Data.Collab
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Model.Ident
 import Vervis.Settings
 
 deckNavW :: Entity Deck -> Actor -> Widget
@@ -110,3 +117,66 @@ projectLinkFedW (Right (inztance, object, actor)) =
     |]
     where
     uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
+
+actorLinkW :: LocalActorBy Key -> Actor -> Widget
+actorLinkW (LocalActorPerson k) actor = do
+    p <- handlerToWidget $ runDB $ getJust k
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{PersonR h}>
+          ~#{username2text $ personUsername p} #{actorName actor}
+    |]
+actorLinkW (LocalActorRepo k) actor = do
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{RepoR h}>
+          ^#{keyHashidText h} #{actorName actor}
+    |]
+actorLinkW (LocalActorDeck k) actor = do
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{DeckR h}>
+          =#{keyHashidText h} #{actorName actor}
+    |]
+actorLinkW (LocalActorLoom k) actor = do
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{LoomR h}>
+          +#{keyHashidText h} #{actorName actor}
+    |]
+actorLinkW (LocalActorProject k) actor = do
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{ProjectR h}>
+          \$#{keyHashidText h} #{actorName actor}
+    |]
+actorLinkW (LocalActorGroup k) actor = do
+    h <- encodeKeyHashid k
+    [whamlet|
+        <a href=@{GroupR h}>
+          &#{keyHashidText h} #{actorName actor}
+    |]
+
+actorLinkFedW
+    :: Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor)
+    -> Widget
+actorLinkFedW (Left (c, a)) = actorLinkW c a
+actorLinkFedW (Right (inztance, object, actor)) =
+    [whamlet|
+        <a href="#{renderObjURI uActor}">
+          #{marker $ remoteActorType actor} #
+          $maybe name <- remoteActorName actor
+            #{name} @ #{renderAuthority $ instanceHost inztance}
+          $nothing
+            #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
+    |]
+    where
+    uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
+    marker = \case
+        AP.ActorTypePerson -> '~'
+        AP.ActorTypeRepo -> '^'
+        AP.ActorTypeTicketTracker -> '='
+        AP.ActorTypePatchTracker -> '+'
+        AP.ActorTypeProject -> '$'
+        AP.ActorTypeTeam -> '&'
+        AP.ActorTypeOther _ -> '?'

templates/personal-overview.hamlet

@@ -67,54 +67,41 @@ $#       Comment on a ticket or merge request
 <h2>Your teams
 
 <ul>
-  $forall (Entity groupID _, Entity _ actor, Entity _ (Collab role)) <- groups
+  $forall i <- groups
     <li>
-      [
+      ^{item i}
-      #{show role}
-      ]
-      <a href=@{GroupR $ hashGroup groupID}>
-        &#{keyHashidText $ hashGroup groupID} #{actorName actor}
 
 <h2>Your repos
 
 <ul>
-  $forall (Entity repoID _, Entity _ actor, Entity _ (Collab role)) <- repos
+  $forall i <- repos
     <li>
-      [
+      ^{item i}
-      #{show role}
-      ]
-      <a href=@{RepoR $ hashRepo repoID}>
-        ^#{keyHashidText $ hashRepo repoID} #{actorName actor}
 
 <h2>Your ticket trackers
 
 <ul>
-  $forall (Entity deckID _, Entity _ actor, Entity _ (Collab role)) <- decks
+  $forall i <- decks
     <li>
-      [
+      ^{item i}
-      #{show role}
-      ]
-      <a href=@{DeckR $ hashDeck deckID}>
-        =#{keyHashidText $ hashDeck deckID} #{actorName actor}
 
 <h2>Your patch trackers
 
 <ul>
-  $forall (Entity loomID _, Entity _ actor, Entity _ (Collab role)) <- looms
+  $forall i <- looms
     <li>
-      [
+      ^{item i}
-      #{show role}
-      ]
-      <a href=@{LoomR $ hashLoom loomID}>
-        +#{keyHashidText $ hashLoom loomID} #{actorName actor}
 
 <h2>Your projects
 
 <ul>
-  $forall (Entity projectID _, Entity _ actor, Entity _ (Collab role)) <- projects
+  $forall i <- projects
     <li>
-      [
+      ^{item i}
-      #{show role}
+
-      ]
+<h2>Your resources of unrecognized type
-      <a href=@{ProjectR $ hashProject projectID}>
+
-        \$#{keyHashidText $ hashProject projectID} #{actorName actor}
+<ul>
+  $forall i <- others
+    <li>
+      ^{item i}