UI: Display personal resources using Permit records
This commit is contained in:
Pere Lev
parent
5af2fdd58b
commit
119779b9b3
6 changed files with 219 additions and 107 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 _ -> '?'
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{GroupR $ hashGroup groupID}>
|
||||
&#{keyHashidText $ hashGroup groupID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your repos
|
||||
|
||||
<ul>
|
||||
$forall (Entity repoID _, Entity _ actor, Entity _ (Collab role)) <- repos
|
||||
$forall i <- repos
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{RepoR $ hashRepo repoID}>
|
||||
^#{keyHashidText $ hashRepo repoID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your ticket trackers
|
||||
|
||||
<ul>
|
||||
$forall (Entity deckID _, Entity _ actor, Entity _ (Collab role)) <- decks
|
||||
$forall i <- decks
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{DeckR $ hashDeck deckID}>
|
||||
=#{keyHashidText $ hashDeck deckID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your patch trackers
|
||||
|
||||
<ul>
|
||||
$forall (Entity loomID _, Entity _ actor, Entity _ (Collab role)) <- looms
|
||||
$forall i <- looms
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{LoomR $ hashLoom loomID}>
|
||||
+#{keyHashidText $ hashLoom loomID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your projects
|
||||
|
||||
<ul>
|
||||
$forall (Entity projectID _, Entity _ actor, Entity _ (Collab role)) <- projects
|
||||
$forall i <- projects
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{ProjectR $ hashProject projectID}>
|
||||
\$#{keyHashidText $ hashProject projectID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your resources of unrecognized type
|
||||
|
||||
<ul>
|
||||
$forall i <- others
|
||||
<li>
|
||||
^{item i}
|
||||
|
|
|
|||
Loading…
Reference in a new issue