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
collabAnon RoleId Maybe
inbox InboxId
followers FollowerSetId
UniqueProject ident sharer
UniqueProjectInbox inbox
UniqueProjectFollowers followers
Repo
ident RpIdent

2
config/routes
View file

@ -96,6 +96,8 @@
/s/#ShrIdent/p/!new ProjectNewR GET
/s/#ShrIdent/p/#PrjIdent ProjectR GET PUT 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/d ProjectDevsR GET POST
/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
, handleOutboxNote
, retryOutboxDelivery
, getFollowersCollection
)
where
@ -42,7 +43,7 @@ import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
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.Maybe
import Data.Semigroup
@ -541,6 +542,9 @@ getFollowers fsid = do
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
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 (x, _, _) = x
@ -686,6 +690,12 @@ handleSharerInbox now shrRecip (Right iidSender) raw activity =
return $ "Activity already exists in inbox of /s/" <> recip
Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
data CreateNoteRecipColl
= CreateNoteRecipProjectFollowers
| CreateNoteRecipTicketParticipants
| CreateNoteRecipTicketTeam
deriving Eq
handleProjectInbox
:: UTCTime
-> ShrIdent
@ -725,13 +735,13 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
hLocal <- getsYesod $ appInstanceHost . appSettings
let colls = findRelevantCollections hLocal num audience
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
mmid <- insertToDiscussion luNote published ibid did meparent fsid
mmid <- insertToDiscussion luNote published ibid did meparent fsidTicket
for mmid $ \ (ractid, mid) -> do
updateOrphans luNote did mid
for msig $ \ sig -> do
remoteRecips <- deliverLocal ractid colls sid fsid
remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
(sig,) <$> deliverRemoteDB ractid jid sig remoteRecips
lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
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
route <- decodeRouteLocal lu
case route of
ProjectFollowersR shr prj
| shr == shrRecip && prj == prjRecip
-> Just CreateNoteRecipProjectFollowers
TicketParticipantsR shr prj num
| shr == shrRecip && prj == prjRecip && num == numCtx
-> Just LocalTicketParticipants
-> Just CreateNoteRecipTicketParticipants
TicketTeamR shr prj num
| shr == shrRecip && prj == prjRecip && num == numCtx
-> Just LocalTicketTeam
-> Just CreateNoteRecipTicketTeam
_ -> Nothing
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
getContextAndParent num mparent = do
mt <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- getBy404 $ UniqueProject prjRecip sid
fmap (jid, projectInbox j, sid ,) <$>
fmap (jid, projectInbox j, projectFollowers j, sid ,) <$>
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
meparent <- for mparent $ \ parent ->
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"
return mid
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
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidSender
@ -873,22 +886,27 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
return (rm E.^. RemoteMessageId, m E.^. MessageId)
deliverLocal
:: RemoteActivityId
-> [LocalTicketRecipient]
-> [CreateNoteRecipColl]
-> SharerId
-> FollowerSetId
-> FollowerSetId
-> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
deliverLocal ractid recips sid fsid = do
deliverLocal ractid recips sid fsidProject fsidTicket = do
(teamPids, teamRemotes) <-
if LocalTicketTeam `elem` recips
if CreateNoteRecipTicketTeam `elem` recips
then getTicketTeam sid
else return ([], [])
(fsPids, fsRemotes) <-
if LocalTicketParticipants `elem` recips
then getFollowers fsid
(tfsPids, tfsRemotes) <-
if CreateNoteRecipTicketParticipants `elem` recips
then getFollowers fsidTicket
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
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
ibid <- personInbox <$> getJust pid
ibiid <- insert $ InboxItem True
@ -985,6 +1003,7 @@ data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
data LocalProjectRecipient
= LocalProject
| LocalProjectFollowers
| LocalTicketRelated Int LocalTicketRecipient
deriving (Eq, Ord)
@ -1002,8 +1021,9 @@ data LocalTicketRelatedSet
| BothTicketParticipantsAndTeam
data LocalProjectRelatedSet = LocalProjectRelatedSet
{ localRecipProject :: Bool
, localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)]
{ localRecipProject :: Bool
, localRecipProjectFollowers :: Bool
, localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)]
}
data LocalSharerRelatedSet = LocalSharerRelatedSet
@ -1084,8 +1104,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
t <- MaybeT $ getValBy $ UniqueTicket jid num
return (sid, projectInbox j, t)
(sid, ibidProject, t) <- fromMaybeE mt "Context: No such local ticket"
return (sid, projectInbox j, projectFollowers j, t)
(sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket"
let did = ticketDiscuss t
mmidParent <- for mparent $ \ parent ->
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"
return mid
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
(rd, rdnew) <- lift $ do
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 (ProjectR shr prj) =
Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject
parseLocalRecipient (ProjectFollowersR shr prj) =
Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProjectFollowers
parseLocalRecipient (TicketParticipantsR shr prj num) =
Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants
parseLocalRecipient (TicketTeamR shr prj num) =
@ -1225,9 +1247,11 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
(not . null)
( map
( second
$ uncurry LocalProjectRelatedSet
$ uncurry localProjectRelatedSet
. bimap
(not . null)
( bimap (not . null) (not . null)
. partition id
)
( map (second ltrs2ltrs)
. groupWithExtract fst snd
)
@ -1246,7 +1270,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
where
lsr2e LocalSharer = Left ()
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)
ltrs2ltrs (LocalTicketParticipants :| l) =
if LocalTicketTeam `elem` l
@ -1256,6 +1281,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
if LocalTicketParticipants `elem` l
then BothTicketParticipantsAndTeam
else OnlyTicketTeam
localProjectRelatedSet (f, j) t =
LocalProjectRelatedSet j f t
parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
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"
unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
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"
unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
case ltrSet of
@ -1389,7 +1417,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
:: PersonId
-> OutboxItemId
-> [ShrIdent]
-> Maybe (SharerId, FollowerSetId, InboxId)
-> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
-> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
deliverLocal pidAuthor obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips
@ -1398,11 +1426,12 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
(morePids, remotes) <-
lift $ case mticket of
Nothing -> return ([], [])
Just (sid, fsid, _) -> do
Just (sid, fsidT, _, fsidJ) -> do
(teamPids, teamRemotes) <- getTicketTeam sid
(fsPids, fsRemotes) <- getFollowers fsid
(tfsPids, tfsRemotes) <- getFollowers fsidT
(jfsPids, jfsRemotes) <- getFollowers fsidJ
return
( L.delete pidAuthor $ union teamPids fsPids
( L.delete pidAuthor $ union teamPids $ union tfsPids jfsPids
-- TODO this is inefficient! The way this combines
-- 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
-- where we can unionBy or LO.unionBy whenever both
-- 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
for_ mticket $ \ (_, _, ibidProject) -> do
for_ mticket $ \ (_, _, ibidProject, _) -> do
ibiid <- insert $ InboxItem False
insert_ $ InboxItemLocal ibidProject obid ibiid
for_ (union recipPids morePids) $ \ pid -> do
@ -1976,3 +2005,39 @@ retryOutboxDelivery = do
unless (and results) $
logError $ "Periodic FW delivery error for host " <> h
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 "Guest role" (Just $ projectCollabAnon project)
<*> pure (projectInbox project)
<*> pure (projectFollowers project)
where
selectWiki =
selectField $

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

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

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

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

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

@ -27,6 +27,8 @@ module Vervis.Handler.Project
, getProjectDevR
, deleteProjectDevR
, postProjectDevR
, getProjectTeamR
, getProjectFollowersR
)
where
@ -47,9 +49,17 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
import qualified Database.Esqueleto as E
import Network.FedURI
import Web.ActivityPub
import Web.ActivityPub hiding (Project (..))
import Yesod.ActivityPub
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.Foundation
import Vervis.Model
@ -78,6 +88,7 @@ postProjectsR shr = do
pid <- requireAuthId
runDB $ do
ibid <- insert Inbox
fsid <- insert FollowerSet
let project = Project
{ projectIdent = npIdent np
, projectSharer = sid
@ -89,6 +100,7 @@ postProjectsR shr = do
, projectCollabAnon = Nothing
, projectCollabUser = Nothing
, projectInbox = ibid
, projectFollowers = fsid
}
jid <- insert project
let collab = ProjectCollab
@ -113,41 +125,40 @@ getProjectNewR shr = do
defaultLayout $(widgetFile "project/new")
getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectR shar proj = selectRep $ do
provideRep $ do
(project, workflow, wsharer, repos) <- runDB $ do
Entity sid s <- getBy404 $ UniqueSharer shar
Entity pid p <- getBy404 $ UniqueProject proj sid
w <- get404 $ projectWorkflow p
sw <-
if workflowSharer w == sid
then return s
else get404 $ workflowSharer w
rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
return (p, w, sw, rs)
defaultLayout $(widgetFile "project/one")
provideAP $ do
project <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shar
Entity _pid p <- getBy404 $ UniqueProject proj sid
return p
route2fed <- getEncodeRouteHome
route2local <- getEncodeRouteLocal
let (host, me) = f2l $ route2fed $ ProjectR shar proj
return $ Doc host Actor
{ actorId = me
, actorType = ActorTypeProject
, actorUsername = Nothing
, actorName =
Just $ fromMaybe (prj2text proj) $ projectName project
, actorSummary = projectDesc project
, actorInbox = route2local $ ProjectInboxR shar proj
, actorOutbox = Nothing
, actorPublicKeys =
[ Left $ route2local ActorKey1R
, Left $ route2local ActorKey2R
]
getProjectR shar proj = do
(project, workflow, wsharer, repos) <- runDB $ do
Entity sid s <- getBy404 $ UniqueSharer shar
Entity pid p <- getBy404 $ UniqueProject proj sid
w <- get404 $ projectWorkflow p
sw <-
if workflowSharer w == sid
then return s
else get404 $ workflowSharer w
rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
return (p, w, sw, rs)
route2fed <- getEncodeRouteHome
route2local <- getEncodeRouteLocal
let projectAP = AP.Project
{ AP.projectActor = Actor
{ actorId = route2local $ ProjectR shar proj
, actorType = ActorTypeProject
, actorUsername = Nothing
, actorName =
Just $ fromMaybe (prj2text proj) $ projectName project
, actorSummary = projectDesc project
, actorInbox = route2local $ ProjectInboxR shar proj
, actorOutbox = Nothing
, actorFollowers =
Just $ route2local $ ProjectFollowersR shar proj
, actorPublicKeys =
[ Left $ route2local ActorKey1R
, Left $ route2local ActorKey2R
]
}
, AP.projectTeam = route2local $ ProjectTeamR shar proj
}
provideHtmlAndAP projectAP $(widgetFile "project/one")
putProjectR :: ShrIdent -> PrjIdent -> Handler Html
putProjectR shr prj = do
@ -273,3 +284,50 @@ postProjectDevR shr rp dev = do
case mmethod of
Just "DELETE" -> deleteProjectDevR shr rp dev
_ -> 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 Yesod.Persist.Local
import Vervis.Federation
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Handler.Discussion
@ -894,49 +895,14 @@ getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketReverseDepsR = getTicketDeps False
getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketParticipantsR shr prj num = do
(locals, remotes) <- runDB $ do
getTicketParticipantsR shr prj num = getFollowersCollection here getFsid
where
here = TicketParticipantsR shr prj num
getFsid = do
sid <- getKeyBy404 $ UniqueSharer shr
jid <- getKeyBy404 $ UniqueProject prj sid
t <- getValBy404 $ UniqueTicket jid num
let fsid = 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}
|]
return $ ticketFollowers t
getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketTeamR shr prj num = do
@ -961,11 +927,13 @@ getTicketTeamR shr prj num = do
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
hLocal <- getsYesod $ appInstanceHost . appSettings
let here = TicketTeamR shr prj num
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let doc = Doc hLocal Collection
{ collectionId = encodeRouteLocal $ TicketTeamR shr prj num
let team = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length memberShrs
, collectionCurrent = Nothing
@ -973,12 +941,7 @@ getTicketTeamR shr prj num = do
, collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
}
selectRep $ do
provideAP $ pure doc
provideRep $ defaultLayout $
[whamlet|
<div><pre>#{encodePrettyToLazyText doc}
|]
provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
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
Right ractid ->
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

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

@ -79,6 +79,8 @@ module Vervis.Migration.Model
, Message2019FillGeneric (..)
, LocalMessage2019FillGeneric (..)
, RemoteMessage2019FillGeneric (..)
, FollowerSet20190610Generic (..)
, Project20190610
)
where
@ -183,3 +185,6 @@ makeEntitiesMigration "20190609"
makeEntitiesMigration "2019Fill"
$(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 (..)
, PublicKey (..)
, Actor (..)
, Project (..)
, CollectionType (..)
, Collection (..)
, CollectionPageType (..)
@ -188,6 +189,7 @@ instance ActivityPub a => ToJSON (Doc a) where
<> toSeries h v
data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
deriving Eq
instance FromJSON ActorType where
parseJSON = withText "ActorType" $ pure . parse
@ -312,6 +314,7 @@ data Actor = Actor
, actorSummary :: Maybe Text
, actorInbox :: LocalURI
, actorOutbox :: Maybe LocalURI
, actorFollowers :: Maybe LocalURI
, actorPublicKeys :: [Either LocalURI PublicKey]
}
@ -327,6 +330,7 @@ instance ActivityPub Actor where
<*> o .:? "summary"
<*> withHost host (f2l <$> o .: "inbox")
<*> withHostMaybe host (fmap f2l <$> o .:? "outbox")
<*> withHostMaybe host (fmap f2l <$> o .:? "followers")
<*> withHost host (parsePublicKeySet =<< o .: "publicKey")
where
withHost h a = do
@ -334,15 +338,35 @@ instance ActivityPub Actor where
if h == h'
then return v
else fail "URI host mismatch"
toSeries host (Actor id_ typ musername mname msummary inbox outbox pkeys)
= "id" .= l2f host id_
<> "type" .= typ
<> "preferredUsername" .=? musername
<> "name" .=? mname
<> "summary" .=? msummary
<> "inbox" .= l2f host inbox
<> "outbox" .=? (l2f host <$> outbox)
<> "publicKey" `pair` encodePublicKeySet host pkeys
toSeries host
(Actor id_ typ musername mname msummary inbox outbox followers pkeys)
= "id" .= l2f host id_
<> "type" .= typ
<> "preferredUsername" .=? musername
<> "name" .=? mname
<> "summary" .=? msummary
<> "inbox" .= l2f host inbox
<> "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