forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Project team and followers

Browse source 
* Have a project team collection, content is the same as ticket team (but
  potentially ticket team allows people to opt out of updates on specific
  tickets, while project team isn't tied to any specific ticket or other child
  object)
* Have a project followers collection, and address it in ticket comments in
  addition to the already used recipients (project, ticket team, ticket
  followers)
This commit is contained in:
fr33domlover 2019-06-11 12:19:51 +00:00
parent 3f5d737f4c
commit 61d1029926
12 changed files with 265 additions and 125 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
config/models
View file

@ -214,9 +214,11 @@ Project
collabUser RoleId Maybe collabUser RoleId Maybe
collabAnon RoleId Maybe collabAnon RoleId Maybe
inbox InboxId inbox InboxId
followers FollowerSetId
UniqueProject ident sharer UniqueProject ident sharer
UniqueProjectInbox inbox UniqueProjectInbox inbox
UniqueProjectFollowers followers
Repo Repo
ident RpIdent ident RpIdent

2
config/routes
View file

@ -96,6 +96,8 @@
/s/#ShrIdent/p/!new ProjectNewR GET /s/#ShrIdent/p/!new ProjectNewR GET
/s/#ShrIdent/p/#PrjIdent ProjectR GET PUT POST /s/#ShrIdent/p/#PrjIdent ProjectR GET PUT POST
/s/#ShrIdent/p/#PrjIdent/inbox ProjectInboxR GET POST /s/#ShrIdent/p/#PrjIdent/inbox ProjectInboxR GET POST
/s/#ShrIdent/p/#PrjIdent/team ProjectTeamR GET
/s/#ShrIdent/p/#PrjIdent/followers ProjectFollowersR GET
/s/#ShrIdent/p/#PrjIdent/edit ProjectEditR GET /s/#ShrIdent/p/#PrjIdent/edit ProjectEditR GET
/s/#ShrIdent/p/#PrjIdent/d ProjectDevsR GET POST /s/#ShrIdent/p/#PrjIdent/d ProjectDevsR GET POST
/s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET /s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET

4
migrations/2019_06_10.model Normal file
View file

@ -0,0 +1,4 @@
FollowerSet
Project
followers FollowerSetId

127
src/Vervis/Federation.hs
View file

@ -21,6 +21,7 @@ module Vervis.Federation
, fixRunningDeliveries , fixRunningDeliveries
, handleOutboxNote , handleOutboxNote
, retryOutboxDelivery , retryOutboxDelivery
, getFollowersCollection
) )
where where
@ -42,7 +43,7 @@ import Data.ByteString (ByteString)
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
import Data.Function import Data.Function
import Data.List (sort, deleteBy, nub, union, unionBy) import Data.List (sort, deleteBy, nub, union, unionBy, partition)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe import Data.Maybe
import Data.Semigroup import Data.Semigroup
@ -541,6 +542,9 @@ getFollowers fsid = do
mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)] mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)]
mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys
mergeConcat3 :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)] -> [(a, b)]
mergeConcat3 xs ys zs = mergeConcat xs $ LO.mergeBy (compare `on` fst) ys zs
fst3 :: (a, b, c) -> a fst3 :: (a, b, c) -> a
fst3 (x, _, _) = x fst3 (x, _, _) = x
@ -686,6 +690,12 @@ handleSharerInbox now shrRecip (Right iidSender) raw activity =
return $ "Activity already exists in inbox of /s/" <> recip return $ "Activity already exists in inbox of /s/" <> recip
Just _ -> return $ "Activity inserted to inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
data CreateNoteRecipColl
= CreateNoteRecipProjectFollowers
| CreateNoteRecipTicketParticipants
| CreateNoteRecipTicketTeam
deriving Eq
handleProjectInbox handleProjectInbox
:: UTCTime :: UTCTime
-> ShrIdent -> ShrIdent
@ -725,13 +735,13 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
hLocal <- getsYesod $ appInstanceHost . appSettings hLocal <- getsYesod $ appInstanceHost . appSettings
let colls = findRelevantCollections hLocal num audience let colls = findRelevantCollections hLocal num audience
mremotesHttp <- runDBExcept $ do mremotesHttp <- runDBExcept $ do
(sid, fsid, jid, ibid, did, meparent) <- getContextAndParent num mparent (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent
lift $ join <$> do lift $ join <$> do
mmid <- insertToDiscussion luNote published ibid did meparent fsid mmid <- insertToDiscussion luNote published ibid did meparent fsidTicket
for mmid $ \ (ractid, mid) -> do for mmid $ \ (ractid, mid) -> do
updateOrphans luNote did mid updateOrphans luNote did mid
for msig $ \ sig -> do for msig $ \ sig -> do
remoteRecips <- deliverLocal ractid colls sid fsid remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
(sig,) <$> deliverRemoteDB ractid jid sig remoteRecips (sig,) <$> deliverRemoteDB ractid jid sig remoteRecips
lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e) let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
@ -773,21 +783,24 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
guard $ h == hLocal guard $ h == hLocal
route <- decodeRouteLocal lu route <- decodeRouteLocal lu
case route of case route of
ProjectFollowersR shr prj
| shr == shrRecip && prj == prjRecip
-> Just CreateNoteRecipProjectFollowers
TicketParticipantsR shr prj num TicketParticipantsR shr prj num
| shr == shrRecip && prj == prjRecip && num == numCtx | shr == shrRecip && prj == prjRecip && num == numCtx
-> Just LocalTicketParticipants -> Just CreateNoteRecipTicketParticipants
TicketTeamR shr prj num TicketTeamR shr prj num
| shr == shrRecip && prj == prjRecip && num == numCtx | shr == shrRecip && prj == prjRecip && num == numCtx
-> Just LocalTicketTeam -> Just CreateNoteRecipTicketTeam
_ -> Nothing _ -> Nothing
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
getContextAndParent num mparent = do getContextAndParent num mparent = do
mt <- lift $ do mt <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- getBy404 $ UniqueProject prjRecip sid Entity jid j <- getBy404 $ UniqueProject prjRecip sid
fmap (jid, projectInbox j, sid ,) <$> fmap (jid, projectInbox j, projectFollowers j, sid ,) <$>
getValBy (UniqueTicket jid num) getValBy (UniqueTicket jid num)
(jid, ibid, sid, t) <- fromMaybeE mt "Context: No such local ticket" (jid, ibid, fsidProject, sid, t) <- fromMaybeE mt "Context: No such local ticket"
let did = ticketDiscuss t let did = ticketDiscuss t
meparent <- for mparent $ \ parent -> meparent <- for mparent $ \ parent ->
case parent of case parent of
@ -804,7 +817,7 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
return mid return mid
Nothing -> return $ Right $ l2f hParent luParent Nothing -> return $ Right $ l2f hParent luParent
return (sid, ticketFollowers t, jid, ibid, did, meparent) return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent)
insertToDiscussion luNote published ibid did meparent fsid = do insertToDiscussion luNote published ibid did meparent fsid = do
ractid <- either entityKey id <$> insertBy' RemoteActivity ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidSender { remoteActivityInstance = iidSender
@ -873,22 +886,27 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
return (rm E.^. RemoteMessageId, m E.^. MessageId) return (rm E.^. RemoteMessageId, m E.^. MessageId)
deliverLocal deliverLocal
:: RemoteActivityId :: RemoteActivityId
-> [LocalTicketRecipient] -> [CreateNoteRecipColl]
-> SharerId -> SharerId
-> FollowerSetId -> FollowerSetId
-> FollowerSetId
-> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
deliverLocal ractid recips sid fsid = do deliverLocal ractid recips sid fsidProject fsidTicket = do
(teamPids, teamRemotes) <- (teamPids, teamRemotes) <-
if LocalTicketTeam `elem` recips if CreateNoteRecipTicketTeam `elem` recips
then getTicketTeam sid then getTicketTeam sid
else return ([], []) else return ([], [])
(fsPids, fsRemotes) <- (tfsPids, tfsRemotes) <-
if LocalTicketParticipants `elem` recips if CreateNoteRecipTicketParticipants `elem` recips
then getFollowers fsid then getFollowers fsidTicket
else return ([], []) else return ([], [])
let pids = union teamPids fsPids (jfsPids, jfsRemotes) <-
if CreateNoteRecipProjectFollowers `elem` recips
then getFollowers fsidProject
else return ([], [])
let pids = union teamPids tfsPids `union` jfsPids
-- TODO inefficient, see the other TODOs about mergeConcat -- TODO inefficient, see the other TODOs about mergeConcat
remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes
for_ pids $ \ pid -> do for_ pids $ \ pid -> do
ibid <- personInbox <$> getJust pid ibid <- personInbox <$> getJust pid
ibiid <- insert $ InboxItem True ibiid <- insert $ InboxItem True
@ -985,6 +1003,7 @@ data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
data LocalProjectRecipient data LocalProjectRecipient
= LocalProject = LocalProject
| LocalProjectFollowers
| LocalTicketRelated Int LocalTicketRecipient | LocalTicketRelated Int LocalTicketRecipient
deriving (Eq, Ord) deriving (Eq, Ord)
@ -1002,8 +1021,9 @@ data LocalTicketRelatedSet
| BothTicketParticipantsAndTeam | BothTicketParticipantsAndTeam
data LocalProjectRelatedSet = LocalProjectRelatedSet data LocalProjectRelatedSet = LocalProjectRelatedSet
{ localRecipProject :: Bool { localRecipProject :: Bool
, localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)] , localRecipProjectFollowers :: Bool
, localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)]
} }
data LocalSharerRelatedSet = LocalSharerRelatedSet data LocalSharerRelatedSet = LocalSharerRelatedSet
@ -1084,8 +1104,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
t <- MaybeT $ getValBy $ UniqueTicket jid num t <- MaybeT $ getValBy $ UniqueTicket jid num
return (sid, projectInbox j, t) return (sid, projectInbox j, projectFollowers j, t)
(sid, ibidProject, t) <- fromMaybeE mt "Context: No such local ticket" (sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket"
let did = ticketDiscuss t let did = ticketDiscuss t
mmidParent <- for mparent $ \ parent -> mmidParent <- for mparent $ \ parent ->
case parent of case parent of
@ -1101,7 +1121,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
return mid return mid
lift $ insertUnique_ $ Follow pid (ticketFollowers t) False lift $ insertUnique_ $ Follow pid (ticketFollowers t) False
return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject)) return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject))
Nothing -> do Nothing -> do
(rd, rdnew) <- lift $ do (rd, rdnew) <- lift $ do
let (hContext, luContext) = f2l uContext let (hContext, luContext) = f2l uContext
@ -1202,6 +1222,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer
parseLocalRecipient (ProjectR shr prj) = parseLocalRecipient (ProjectR shr prj) =
Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject
parseLocalRecipient (ProjectFollowersR shr prj) =
Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProjectFollowers
parseLocalRecipient (TicketParticipantsR shr prj num) = parseLocalRecipient (TicketParticipantsR shr prj num) =
Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants
parseLocalRecipient (TicketTeamR shr prj num) = parseLocalRecipient (TicketTeamR shr prj num) =
@ -1225,9 +1247,11 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
(not . null) (not . null)
( map ( map
( second ( second
$ uncurry LocalProjectRelatedSet $ uncurry localProjectRelatedSet
. bimap . bimap
(not . null) ( bimap (not . null) (not . null)
. partition id
)
( map (second ltrs2ltrs) ( map (second ltrs2ltrs)
. groupWithExtract fst snd . groupWithExtract fst snd
) )
@ -1246,7 +1270,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
where where
lsr2e LocalSharer = Left () lsr2e LocalSharer = Left ()
lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr) lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr)
lpr2e LocalProject = Left () lpr2e LocalProject = Left False
lpr2e LocalProjectFollowers = Left True
lpr2e (LocalTicketRelated num ltr) = Right (num, ltr) lpr2e (LocalTicketRelated num ltr) = Right (num, ltr)
ltrs2ltrs (LocalTicketParticipants :| l) = ltrs2ltrs (LocalTicketParticipants :| l) =
if LocalTicketTeam `elem` l if LocalTicketTeam `elem` l
@ -1256,6 +1281,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
if LocalTicketParticipants `elem` l if LocalTicketParticipants `elem` l
then BothTicketParticipantsAndTeam then BothTicketParticipantsAndTeam
else OnlyTicketTeam else OnlyTicketTeam
localProjectRelatedSet (f, j) t =
LocalProjectRelatedSet j f t
parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))) parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
parseParent _ Nothing = return Nothing parseParent _ Nothing = return Nothing
@ -1288,6 +1315,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
(prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets" (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
unless (prj == prj') $ throwE "Note project recipients mismatch context's project" unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
unless (localRecipProject lprSet) $ throwE "Note context's project not addressed" unless (localRecipProject lprSet) $ throwE "Note context's project not addressed"
unless (localRecipProjectFollowers lprSet) $ throwE "Note context's project followers not addressed"
(num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets" (num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets"
unless (num == num') $ throwE "Note project recipients mismatch context's ticket number" unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
case ltrSet of case ltrSet of
@ -1389,7 +1417,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
:: PersonId :: PersonId
-> OutboxItemId -> OutboxItemId
-> [ShrIdent] -> [ShrIdent]
-> Maybe (SharerId, FollowerSetId, InboxId) -> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
-> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
deliverLocal pidAuthor obid recips mticket = do deliverLocal pidAuthor obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips recipPids <- traverse getPersonId $ nub recips
@ -1398,11 +1426,12 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
(morePids, remotes) <- (morePids, remotes) <-
lift $ case mticket of lift $ case mticket of
Nothing -> return ([], []) Nothing -> return ([], [])
Just (sid, fsid, _) -> do Just (sid, fsidT, _, fsidJ) -> do
(teamPids, teamRemotes) <- getTicketTeam sid (teamPids, teamRemotes) <- getTicketTeam sid
(fsPids, fsRemotes) <- getFollowers fsid (tfsPids, tfsRemotes) <- getFollowers fsidT
(jfsPids, jfsRemotes) <- getFollowers fsidJ
return return
( L.delete pidAuthor $ union teamPids fsPids ( L.delete pidAuthor $ union teamPids $ union tfsPids jfsPids
-- TODO this is inefficient! The way this combines -- TODO this is inefficient! The way this combines
-- same-host sharer lists is: -- same-host sharer lists is:
-- --
@ -1441,10 +1470,10 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
-- instances aren't repeated. Use a custom merge -- instances aren't repeated. Use a custom merge
-- where we can unionBy or LO.unionBy whenever both -- where we can unionBy or LO.unionBy whenever both
-- lists have the same instance. -- lists have the same instance.
, map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes
) )
lift $ do lift $ do
for_ mticket $ \ (_, _, ibidProject) -> do for_ mticket $ \ (_, _, ibidProject, _) -> do
ibiid <- insert $ InboxItem False ibiid <- insert $ InboxItem False
insert_ $ InboxItemLocal ibidProject obid ibiid insert_ $ InboxItemLocal ibidProject obid ibiid
for_ (union recipPids morePids) $ \ pid -> do for_ (union recipPids morePids) $ \ pid -> do
@ -1976,3 +2005,39 @@ retryOutboxDelivery = do
unless (and results) $ unless (and results) $
logError $ "Periodic FW delivery error for host " <> h logError $ "Periodic FW delivery error for host " <> h
return True return True
getFollowersCollection
:: Route App -> AppDB FollowerSetId -> Handler TypedContent
getFollowersCollection here getFsid = do
(locals, remotes) <- runDB $ do
fsid <- getFsid
(,) <$> do pids <- map (followPerson . entityVal) <$>
selectList [FollowTarget ==. fsid] []
sids <-
map (personIdent . entityVal) <$>
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
<*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
return
( i E.^. InstanceHost
, ra E.^. RemoteActorIdent
)
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let followersAP = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length locals + length remotes
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map (encodeRouteHome . SharerR) locals ++
map (uncurry l2f . bimap E.unValue E.unValue) remotes
}
provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])

1
src/Vervis/Form/Project.hs
View file

@ -116,6 +116,7 @@ editProjectAForm sid (Entity jid project) = Project
<*> aopt selectRole "User role" (Just $ projectCollabUser project) <*> aopt selectRole "User role" (Just $ projectCollabUser project)
<*> aopt selectRole "Guest role" (Just $ projectCollabAnon project) <*> aopt selectRole "Guest role" (Just $ projectCollabAnon project)
<*> pure (projectInbox project) <*> pure (projectInbox project)
<*> pure (projectFollowers project)
where where
selectWiki = selectWiki =
selectField $ selectField $

3
src/Vervis/Handler/Inbox.hs
View file

@ -458,7 +458,8 @@ postOutboxR shrAuthor = do
uTicket = encodeRecipRoute $ TicketR shrTicket prj num uTicket = encodeRecipRoute $ TicketR shrTicket prj num
(hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
collections = collections =
[ TicketParticipantsR shrTicket prj num [ ProjectFollowersR shrTicket prj
, TicketParticipantsR shrTicket prj num
, TicketTeamR shrTicket prj num , TicketTeamR shrTicket prj num
] ]
recips = ProjectR shrTicket prj : collections recips = ProjectR shrTicket prj : collections

1
src/Vervis/Handler/Person.hs
View file

@ -144,6 +144,7 @@ getPerson shr sharer person = do
, actorSummary = Nothing , actorSummary = Nothing
, actorInbox = route2local $ SharerInboxR shr , actorInbox = route2local $ SharerInboxR shr
, actorOutbox = Just $ route2local $ OutboxR shr , actorOutbox = Just $ route2local $ OutboxR shr
, actorFollowers = Nothing
, actorPublicKeys = , actorPublicKeys =
[ Left $ route2local ActorKey1R [ Left $ route2local ActorKey1R
, Left $ route2local ActorKey2R , Left $ route2local ActorKey2R

128
src/Vervis/Handler/Project.hs
View file

@ -27,6 +27,8 @@ module Vervis.Handler.Project
, getProjectDevR , getProjectDevR
, deleteProjectDevR , deleteProjectDevR
, postProjectDevR , postProjectDevR
, getProjectTeamR
, getProjectFollowersR
) )
where where
@ -47,9 +49,17 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Network.FedURI import Network.FedURI
import Web.ActivityPub import Web.ActivityPub hiding (Project (..))
import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import qualified Web.ActivityPub as AP
import Data.Either.Local
import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.Federation
import Vervis.Form.Project import Vervis.Form.Project
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
@ -78,6 +88,7 @@ postProjectsR shr = do
pid <- requireAuthId pid <- requireAuthId
runDB $ do runDB $ do
ibid <- insert Inbox ibid <- insert Inbox
fsid <- insert FollowerSet
let project = Project let project = Project
{ projectIdent = npIdent np { projectIdent = npIdent np
, projectSharer = sid , projectSharer = sid
@ -89,6 +100,7 @@ postProjectsR shr = do
, projectCollabAnon = Nothing , projectCollabAnon = Nothing
, projectCollabUser = Nothing , projectCollabUser = Nothing
, projectInbox = ibid , projectInbox = ibid
, projectFollowers = fsid
} }
jid <- insert project jid <- insert project
let collab = ProjectCollab let collab = ProjectCollab
@ -113,41 +125,40 @@ getProjectNewR shr = do
defaultLayout $(widgetFile "project/new") defaultLayout $(widgetFile "project/new")
getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectR shar proj = selectRep $ do getProjectR shar proj = do
provideRep $ do (project, workflow, wsharer, repos) <- runDB $ do
(project, workflow, wsharer, repos) <- runDB $ do Entity sid s <- getBy404 $ UniqueSharer shar
Entity sid s <- getBy404 $ UniqueSharer shar Entity pid p <- getBy404 $ UniqueProject proj sid
Entity pid p <- getBy404 $ UniqueProject proj sid w <- get404 $ projectWorkflow p
w <- get404 $ projectWorkflow p sw <-
sw <- if workflowSharer w == sid
if workflowSharer w == sid then return s
then return s else get404 $ workflowSharer w
else get404 $ workflowSharer w rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] return (p, w, sw, rs)
return (p, w, sw, rs)
defaultLayout $(widgetFile "project/one") route2fed <- getEncodeRouteHome
provideAP $ do route2local <- getEncodeRouteLocal
project <- runDB $ do let projectAP = AP.Project
Entity sid _s <- getBy404 $ UniqueSharer shar { AP.projectActor = Actor
Entity _pid p <- getBy404 $ UniqueProject proj sid { actorId = route2local $ ProjectR shar proj
return p , actorType = ActorTypeProject
route2fed <- getEncodeRouteHome , actorUsername = Nothing
route2local <- getEncodeRouteLocal , actorName =
let (host, me) = f2l $ route2fed $ ProjectR shar proj Just $ fromMaybe (prj2text proj) $ projectName project
return $ Doc host Actor , actorSummary = projectDesc project
{ actorId = me , actorInbox = route2local $ ProjectInboxR shar proj
, actorType = ActorTypeProject , actorOutbox = Nothing
, actorUsername = Nothing , actorFollowers =
, actorName = Just $ route2local $ ProjectFollowersR shar proj
Just $ fromMaybe (prj2text proj) $ projectName project , actorPublicKeys =
, actorSummary = projectDesc project [ Left $ route2local ActorKey1R
, actorInbox = route2local $ ProjectInboxR shar proj , Left $ route2local ActorKey2R
, actorOutbox = Nothing ]
, actorPublicKeys = }
[ Left $ route2local ActorKey1R , AP.projectTeam = route2local $ ProjectTeamR shar proj
, Left $ route2local ActorKey2R
]
} }
provideHtmlAndAP projectAP $(widgetFile "project/one")
putProjectR :: ShrIdent -> PrjIdent -> Handler Html putProjectR :: ShrIdent -> PrjIdent -> Handler Html
putProjectR shr prj = do putProjectR shr prj = do
@ -273,3 +284,50 @@ postProjectDevR shr rp dev = do
case mmethod of case mmethod of
Just "DELETE" -> deleteProjectDevR shr rp dev Just "DELETE" -> deleteProjectDevR shr rp dev
_ -> notFound _ -> notFound
getProjectTeamR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectTeamR shr prj = do
memberShrs <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
_jid <- getKeyBy404 $ UniqueProject prj sid
id_ <-
requireEitherAlt
(getKeyBy $ UniquePersonIdent sid)
(getKeyBy $ UniqueGroup sid)
"Found sharer that is neither person nor group"
"Found sharer that is both person and group"
case id_ of
Left pid -> return [shr]
Right gid -> do
pids <-
map (groupMemberPerson . entityVal) <$>
selectList [GroupMemberGroup ==. gid] []
sids <-
map (personIdent . entityVal) <$>
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
let here = ProjectTeamR shr prj
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let team = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length memberShrs
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
}
provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
getProjectFollowersR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectFollowersR shr prj = getFollowersCollection here getFsid
where
here = ProjectFollowersR shr prj
getFsid = do
sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid
return $ projectFollowers j

61
src/Vervis/Handler/Ticket.hs
View file

@ -101,6 +101,7 @@ import Data.Maybe.Local (partitionMaybePairs)
import Database.Persist.Local import Database.Persist.Local
import Yesod.Persist.Local import Yesod.Persist.Local
import Vervis.Federation
import Vervis.Form.Ticket import Vervis.Form.Ticket
import Vervis.Foundation import Vervis.Foundation
import Vervis.Handler.Discussion import Vervis.Handler.Discussion
@ -894,49 +895,14 @@ getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketReverseDepsR = getTicketDeps False getTicketReverseDepsR = getTicketDeps False
getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketParticipantsR shr prj num = do getTicketParticipantsR shr prj num = getFollowersCollection here getFsid
(locals, remotes) <- runDB $ do where
here = TicketParticipantsR shr prj num
getFsid = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
jid <- getKeyBy404 $ UniqueProject prj sid jid <- getKeyBy404 $ UniqueProject prj sid
t <- getValBy404 $ UniqueTicket jid num t <- getValBy404 $ UniqueTicket jid num
let fsid = ticketFollowers t return $ ticketFollowers t
(,) <$> do pids <- map (followPerson . entityVal) <$>
selectList [FollowTarget ==. fsid] []
sids <-
map (personIdent . entityVal) <$>
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
<*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
return
( i E.^. InstanceHost
, ra E.^. RemoteActorIdent
)
hLocal <- getsYesod $ appInstanceHost . appSettings
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let doc = Doc hLocal Collection
{ collectionId =
encodeRouteLocal $ TicketParticipantsR shr prj num
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length locals + length remotes
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map (encodeRouteHome . SharerR) locals ++
map (uncurry l2f . bimap E.unValue E.unValue) remotes
}
selectRep $ do
provideAP $ pure doc
provideRep $ defaultLayout $
[whamlet|
<div><pre>#{encodePrettyToLazyText doc}
|]
getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketTeamR shr prj num = do getTicketTeamR shr prj num = do
@ -961,11 +927,13 @@ getTicketTeamR shr prj num = do
selectList [PersonId <-. pids] [] selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$> map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] [] selectList [SharerId <-. sids] []
hLocal <- getsYesod $ appInstanceHost . appSettings
let here = TicketTeamR shr prj num
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
let doc = Doc hLocal Collection let team = Collection
{ collectionId = encodeRouteLocal $ TicketTeamR shr prj num { collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered , collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length memberShrs , collectionTotalItems = Just $ length memberShrs
, collectionCurrent = Nothing , collectionCurrent = Nothing
@ -973,12 +941,7 @@ getTicketTeamR shr prj num = do
, collectionLast = Nothing , collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs , collectionItems = map (encodeRouteHome . SharerR) memberShrs
} }
selectRep $ do provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
provideAP $ pure doc
provideRep $ defaultLayout $
[whamlet|
<div><pre>#{encodePrettyToLazyText doc}
|]
getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketEventsR shr prj num = error "TODO not implemented" getTicketEventsR shr prj num = error "TODO not implemented"

14
src/Vervis/Migration.hs
View file

@ -649,6 +649,20 @@ changes hLocal ctx =
insert_ $ InboxItemLocal2019Fill ibid obid ibiid insert_ $ InboxItemLocal2019Fill ibid obid ibiid
Right ractid -> Right ractid ->
insert_ $ InboxItemRemote2019Fill ibid ractid ibiid insert_ $ InboxItemRemote2019Fill ibid ractid ibiid
-- 110
, addFieldRefRequired'
"Project"
FollowerSet20190610
(Just $ do
jids <- selectKeysList ([] :: [Filter Project20190610]) []
for_ jids $ \ jid -> do
fsid <- insert FollowerSet20190610
update jid [Project20190610Followers =. fsid]
)
"followers"
"FollowerSet"
-- 111
, addUnique "Project" $ Unique "UniqueProjectFollowers" ["followers"]
] ]
migrateDB migrateDB

5
src/Vervis/Migration/Model.hs
View file

@ -79,6 +79,8 @@ module Vervis.Migration.Model
, Message2019FillGeneric (..) , Message2019FillGeneric (..)
, LocalMessage2019FillGeneric (..) , LocalMessage2019FillGeneric (..)
, RemoteMessage2019FillGeneric (..) , RemoteMessage2019FillGeneric (..)
, FollowerSet20190610Generic (..)
, Project20190610
) )
where where
@ -183,3 +185,6 @@ makeEntitiesMigration "20190609"
makeEntitiesMigration "2019Fill" makeEntitiesMigration "2019Fill"
$(modelFile "migrations/2019_06_09_fill.model") $(modelFile "migrations/2019_06_09_fill.model")
makeEntitiesMigration "20190610"
$(modelFile "migrations/2019_06_10.model")

42
src/Web/ActivityPub.hs
View file

@ -31,6 +31,7 @@ module Web.ActivityPub
, Owner (..) , Owner (..)
, PublicKey (..) , PublicKey (..)
, Actor (..) , Actor (..)
, Project (..)
, CollectionType (..) , CollectionType (..)
, Collection (..) , Collection (..)
, CollectionPageType (..) , CollectionPageType (..)
@ -188,6 +189,7 @@ instance ActivityPub a => ToJSON (Doc a) where
<> toSeries h v <> toSeries h v
data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
deriving Eq
instance FromJSON ActorType where instance FromJSON ActorType where
parseJSON = withText "ActorType" $ pure . parse parseJSON = withText "ActorType" $ pure . parse
@ -312,6 +314,7 @@ data Actor = Actor
, actorSummary :: Maybe Text , actorSummary :: Maybe Text
, actorInbox :: LocalURI , actorInbox :: LocalURI
, actorOutbox :: Maybe LocalURI , actorOutbox :: Maybe LocalURI
, actorFollowers :: Maybe LocalURI
, actorPublicKeys :: [Either LocalURI PublicKey] , actorPublicKeys :: [Either LocalURI PublicKey]
} }
@ -327,6 +330,7 @@ instance ActivityPub Actor where
<*> o .:? "summary" <*> o .:? "summary"
<*> withHost host (f2l <$> o .: "inbox") <*> withHost host (f2l <$> o .: "inbox")
<*> withHostMaybe host (fmap f2l <$> o .:? "outbox") <*> withHostMaybe host (fmap f2l <$> o .:? "outbox")
<*> withHostMaybe host (fmap f2l <$> o .:? "followers")
<*> withHost host (parsePublicKeySet =<< o .: "publicKey") <*> withHost host (parsePublicKeySet =<< o .: "publicKey")
where where
withHost h a = do withHost h a = do
@ -334,15 +338,35 @@ instance ActivityPub Actor where
if h == h' if h == h'
then return v then return v
else fail "URI host mismatch" else fail "URI host mismatch"
toSeries host (Actor id_ typ musername mname msummary inbox outbox pkeys) toSeries host
= "id" .= l2f host id_ (Actor id_ typ musername mname msummary inbox outbox followers pkeys)
<> "type" .= typ = "id" .= l2f host id_
<> "preferredUsername" .=? musername <> "type" .= typ
<> "name" .=? mname <> "preferredUsername" .=? musername
<> "summary" .=? msummary <> "name" .=? mname
<> "inbox" .= l2f host inbox <> "summary" .=? msummary
<> "outbox" .=? (l2f host <$> outbox) <> "inbox" .= l2f host inbox
<> "publicKey" `pair` encodePublicKeySet host pkeys <> "outbox" .=? (l2f host <$> outbox)
<> "followers" .=? (l2f host <$> followers)
<> "publicKey" `pair` encodePublicKeySet host pkeys
data Project = Project
{ projectActor :: Actor
, projectTeam :: LocalURI
}
instance ActivityPub Project where
jsonldContext _ = ContextActor
parseObject o = do
(h, a) <- parseObject o
unless (actorType a == ActorTypeProject) $
fail "Actor type isn't Project"
fmap (h,) $
Project a
<$> withHost h (f2l <$> o .: (frg <> "team"))
toSeries host (Project actor team)
= toSeries host actor
<> (frg <> "team") .= l2f host team
data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered