From 119779b9b30650f24756fa9d7c7a29b69da05f3d Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 9 Dec 2023 07:13:34 +0200 Subject: [PATCH] UI: Display personal resources using Permit records --- src/Vervis/Actor.hs | 11 +++ src/Vervis/Handler/Client.hs | 139 +++++++++++++++++------------ src/Vervis/Persist/Collab.hs | 44 +++++---- src/Vervis/Widget/Person.hs | 15 +++- src/Vervis/Widget/Tracker.hs | 70 +++++++++++++++ templates/personal-overview.hamlet | 47 ++++------ 6 files changed, 219 insertions(+), 107 deletions(-) diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 04c4921..22b1f72 100644 --- a/src/Vervis/Actor.hs +++ b/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 diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 4bf69bd..c017650 100644 --- a/src/Vervis/Handler/Client.hs +++ b/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 $ (,,,,) - <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do - E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId - E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId - E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicRepoCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid - E.orderBy [E.asc $ repo E.^. RepoId] - return (repo, actor, collab) - ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do - E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId - E.on $ topic E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId - E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid - E.orderBy [E.asc $ deck E.^. DeckId] - return (deck, actor, collab) - ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do - E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId - E.on $ topic E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId - E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLoomCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid - E.orderBy [E.asc $ loom E.^. LoomId] - return (loom, actor, collab) - ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` project `E.InnerJoin` actor) -> do - E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId - E.on $ topic E.^. CollabTopicProjectProject E.==. project E.^. ProjectId - E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid - E.orderBy [E.asc $ project E.^. ProjectId] - return (project, actor, collab) - ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` group `E.InnerJoin` actor) -> do - E.on $ group E.^. GroupActor E.==. actor E.^. ActorId - E.on $ topic E.^. CollabTopicGroupGroup E.==. group E.^. GroupId - E.on $ topic E.^. CollabTopicGroupCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - 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 + permits <- runDB $ do + locals <- do + ls <- 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 pid + E.orderBy [E.asc $ enable E.^. PermitTopicEnableLocalId] + return + ( permit E.^. PermitId + , permit E.^. PermitRole + , topic E.^. PermitTopicLocalId + ) + for ls $ \ (E.Value permitID, E.Value role, E.Value topicID) -> do + topic <- getPermitTopicLocal topicID + actorID <- do + ma <- getLocalActorEntity topic + case ma of + Nothing -> error "Impossible, we should have found the local actor in DB" + Just a -> pure $ localActorID a + actor <- getJust actorID + return + ( permitID + , role + , localActorType topic + , Left (topic, actor) + ) + remotes <- do + rs <- 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 pid + E.orderBy [E.asc $ enable E.^. PermitTopicEnableRemoteId] + return + ( permit E.^. PermitId + , permit E.^. PermitRole + , topic E.^. PermitTopicRemoteActor + ) + for rs $ \ (E.Value permitID, E.Value role, E.Value remoteActorID) -> do + remoteActor <- getJust remoteActorID + remoteObject <- getJust $ remoteActorIdent remoteActor + inztance <- getJust $ remoteObjectInstance remoteObject + return + ( permitID + , role + , remoteActorType remoteActor + , Right (inztance, remoteObject, remoteActor) + ) + return $ locals ++ remotes + let (people, repos, decks, looms, projects, groups, others) = + partitionByActorType (view _3) (view _1) permits + if null people + then pure () + else error "Bug: Person as a PermitTopic" 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 $ diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 4caaef5..aeb816b 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -17,6 +17,7 @@ module Vervis.Persist.Collab ( getCollabTopic , getCollabTopic' , getCollabRecip + , getPermitTopicLocal , getPermitTopic , getStemIdent , getStemProject @@ -112,6 +113,29 @@ getCollabRecip collabID = "Collab without recip" "Collab with both local and remote recip" +getPermitTopicLocal + :: MonadIO m + => PermitTopicLocalId + -> ReaderT SqlBackend m (LocalActorBy Key) +getPermitTopicLocal localID = do + options <- + sequence + [ fmap (LocalActorRepo . permitTopicRepoRepo) <$> + getValBy (UniquePermitTopicRepo localID) + , fmap (LocalActorDeck . permitTopicDeckDeck) <$> + getValBy (UniquePermitTopicDeck localID) + , fmap (LocalActorLoom . permitTopicLoomLoom) <$> + getValBy (UniquePermitTopicLoom localID) + , fmap (LocalActorProject . permitTopicProjectProject) <$> + getValBy (UniquePermitTopicProject localID) + , fmap (LocalActorGroup . permitTopicGroupGroup) <$> + getValBy (UniquePermitTopicGroup localID) + ] + exactlyOneJust + options + "Found Permit without topic" + "Found Permit with multiple topics" + getPermitTopic :: MonadIO m => PermitId @@ -128,25 +152,7 @@ getPermitTopic permitID = do "Permit without topic" "Permit with both local and remote topic" bitraverse - (\ localID -> (localID,) <$> do - options <- - sequence - [ fmap (LocalActorRepo . permitTopicRepoRepo) <$> - getValBy (UniquePermitTopicRepo localID) - , fmap (LocalActorDeck . permitTopicDeckDeck) <$> - getValBy (UniquePermitTopicDeck localID) - , fmap (LocalActorLoom . permitTopicLoomLoom) <$> - getValBy (UniquePermitTopicLoom localID) - , fmap (LocalActorProject . permitTopicProjectProject) <$> - getValBy (UniquePermitTopicProject localID) - , fmap (LocalActorGroup . permitTopicGroupGroup) <$> - getValBy (UniquePermitTopicGroup localID) - ] - exactlyOneJust - options - "Found Permit without topic" - "Found Permit with multiple topics" - ) + (\ localID -> (localID,) <$> getPermitTopicLocal localID) (\ (Entity topicID (PermitTopicRemote _ actorID)) -> return (topicID, actorID) ) diff --git a/src/Vervis/Widget/Person.hs b/src/Vervis/Widget/Person.hs index 862fc76..9231148 100644 --- a/src/Vervis/Widget/Person.hs +++ b/src/Vervis/Widget/Person.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2022 by fr33domlover . + - Written in 2016, 2019, 2022, 2023 by fr33domlover . - - ♡ 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| + #{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 diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index 17edc8e..2ae7e59 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/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| + + ~#{username2text $ personUsername p} #{actorName actor} + |] +actorLinkW (LocalActorRepo k) actor = do + h <- encodeKeyHashid k + [whamlet| + + ^#{keyHashidText h} #{actorName actor} + |] +actorLinkW (LocalActorDeck k) actor = do + h <- encodeKeyHashid k + [whamlet| + + =#{keyHashidText h} #{actorName actor} + |] +actorLinkW (LocalActorLoom k) actor = do + h <- encodeKeyHashid k + [whamlet| + + +#{keyHashidText h} #{actorName actor} + |] +actorLinkW (LocalActorProject k) actor = do + h <- encodeKeyHashid k + [whamlet| + + \$#{keyHashidText h} #{actorName actor} + |] +actorLinkW (LocalActorGroup k) actor = do + h <- encodeKeyHashid k + [whamlet| + + &#{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| + + #{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 _ -> '?' diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index dd4b9dd..7cbc5fb 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -67,54 +67,41 @@ $# Comment on a ticket or merge request

Your teams