forge/Vervis
1
0
Fork 0
Code Pull requests Activity

DB: Move project inbox, outbox & followers into a new Actor table

Browse source
This commit is contained in:
fr33domlover 2022-07-19 12:12:49 +00:00
parent 86b35e9b56
commit 88b8027572
19 changed files with 272 additions and 124 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
config/models
View file

@ -32,6 +32,18 @@ RemoteObject
-- People -- People
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
Actor
name Text
desc Text
createdAt UTCTime
inbox InboxId
outbox OutboxId
followers FollowerSetId
UniqueActorInbox inbox
UniqueActorOutbox outbox
UniqueActorFollowers followers
Sharer Sharer
ident ShrIdent ident ShrIdent
name Text Maybe name Text Maybe
@ -265,6 +277,7 @@ RoleAccess
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
Project Project
actor ActorId
ident PrjIdent ident PrjIdent
sharer SharerId sharer SharerId
name Text Maybe name Text Maybe
@ -274,14 +287,9 @@ Project
wiki RepoId Maybe wiki RepoId Maybe
collabUser RoleId Maybe collabUser RoleId Maybe
collabAnon RoleId Maybe collabAnon RoleId Maybe
inbox InboxId
outbox OutboxId
followers FollowerSetId
UniqueProjectActor actor
UniqueProject ident sharer UniqueProject ident sharer
UniqueProjectInbox inbox
UniqueProjectOutbox outbox
UniqueProjectFollowers followers
Repo Repo
ident RpIdent ident RpIdent

11
migrations/2022_07_17_actor.model Normal file
View file

@ -0,0 +1,11 @@
Actor
name Text
desc Text
createdAt UTCTime
inbox InboxId
outbox OutboxId
followers FollowerSetId
UniqueActorInbox inbox
UniqueActorOutbox outbox
UniqueActorFollowers followers

28
migrations/2022_07_17_project_actor.model Normal file
View file

@ -0,0 +1,28 @@
Inbox
Outbox
FollowerSet
Actor
name Text
desc Text
createdAt UTCTime
inbox InboxId
outbox OutboxId
followers FollowerSetId
Project
actor ActorId
ident Text
sharer Int64
name Text Maybe
desc Text Maybe
workflow Int64
nextTicket Int
wiki Int64 Maybe
collabUser Int64 Maybe
collabAnon Int64 Maybe
inbox InboxId
outbox OutboxId
followers FollowerSetId

55
src/Vervis/API.hs
View file

@ -87,7 +87,7 @@ import Crypto.PublicVerifKey
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest import Network.HTTP.Digest
import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..)) import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), Project (..), Actor (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
import Yesod.FedURI import Yesod.FedURI
@ -1199,13 +1199,13 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
] ]
(recipsC, ibid, actor) = (recipsC, ibid, actor) =
case ent of case ent of
Left (Entity _ j) -> Left (Entity _ j, a) ->
let prj = projectIdent j let prj = projectIdent j
in ( [ LocalPersonCollectionProjectTeam shr prj in ( [ LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj , LocalPersonCollectionProjectFollowers shr prj
, LocalPersonCollectionSharerFollowers shrUser , LocalPersonCollectionSharerFollowers shrUser
] ]
, projectInbox j , actorInbox a
, LocalActorProject shr prj , LocalActorProject shr prj
) )
Right (Entity _ r, _, _, _) -> Right (Entity _ r, _, _, _) ->
@ -1465,8 +1465,9 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueProject prj sid MaybeT $ getBy $ UniqueProject prj sid
ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project" ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now a <- lift $ getJust $ projectActor j
return (shr, Left ej, obiidAccept) obiidAccept <- lift $ insertEmptyOutboxItem (actorOutbox a) now
return (shr, Left (ej, a), obiidAccept)
prepareProject now (Left (WITRepo shr rp mb typ diff)) = Left <$> do prepareProject now (Left (WITRepo shr rp mb typ diff)) = Left <$> do
mer <- lift $ runMaybeT $ do mer <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
@ -1515,7 +1516,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
, ticketContextLocalAccept = obiidAccept , ticketContextLocalAccept = obiidAccept
} }
case ent of case ent of
Left (Entity jid _) -> do Left (Entity jid _, _) -> do
insert_ TicketProjectLocal insert_ TicketProjectLocal
{ ticketProjectLocalContext = tclid { ticketProjectLocalContext = tclid
, ticketProjectLocalProject = jid , ticketProjectLocalProject = jid
@ -1707,7 +1708,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
talkhid <- encodeKeyHashid talid talkhid <- encodeKeyHashid talid
let (outboxItemRoute, actorRoute) = let (outboxItemRoute, actorRoute) =
case ent of case ent of
Left (Entity _ j) -> Left (Entity _ j, _) ->
let prj = projectIdent j let prj = projectIdent j
in (ProjectOutboxItemR shrJ prj, ProjectR shrJ prj) in (ProjectOutboxItemR shrJ prj, ProjectR shrJ prj)
Right (Entity _ r, _, _, _) -> Right (Entity _ r, _, _, _) ->
@ -1846,14 +1847,16 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getValBy $ UniqueProject prj sid MaybeT $ getValBy $ UniqueProject prj sid
project <- fromMaybeE mproject "Follow object: No such project in DB" project <- fromMaybeE mproject "Follow object: No such project in DB"
return (projectFollowers project, projectInbox project, False, projectOutbox project) actor <- lift $ getJust $ projectActor project
return (actorFollowers actor, actorInbox actor, False, actorOutbox actor)
getFollowee (FolloweeProjectTicket shr prj ltkhid) = do getFollowee (FolloweeProjectTicket shr prj ltkhid) = do
(_, Entity _ j, _, Entity _ lt, _, _, _, _) <- do (_, Entity _ j, _, Entity _ lt, _, _, _, _) <- do
mticket <- lift $ runMaybeT $ do mticket <- lift $ runMaybeT $ do
ltid <- decodeKeyHashidM ltkhid ltid <- decodeKeyHashidM ltkhid
MaybeT $ getProjectTicket shr prj ltid MaybeT $ getProjectTicket shr prj ltid
fromMaybeE mticket "Follow object: No such project-ticket in DB" fromMaybeE mticket "Follow object: No such project-ticket in DB"
return (localTicketFollowers lt, projectInbox j, False, projectOutbox j) a <- lift $ getJust $ projectActor j
return (localTicketFollowers lt, actorInbox a, False, actorOutbox a)
getFollowee (FolloweeRepo shr rp) = do getFollowee (FolloweeRepo shr rp) = do
mrepo <- lift $ runMaybeT $ do mrepo <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
@ -1971,8 +1974,9 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
Left (WITProject shr prj) -> Just . Left <$> do Left (WITProject shr prj) -> Just . Left <$> do
mproj <- lift $ runMaybeT $ do mproj <- lift $ runMaybeT $ do
Entity sid s <- MaybeT $ getBy $ UniqueSharer shr Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
ej <- MaybeT $ getBy $ UniqueProject prj sid ej@(Entity _ j) <- MaybeT $ getBy $ UniqueProject prj sid
return (s, ej) a <- lift $ getJust $ projectActor j
return (s, ej, a)
fromMaybeE mproj "Offer target no such local project in DB" fromMaybeE mproj "Offer target no such local project in DB"
Left (WITRepo shr rp mb typ diffs) -> Just . Right <$> do Left (WITRepo shr rp mb typ diffs) -> Just . Right <$> do
mproj <- lift $ runMaybeT $ do mproj <- lift $ runMaybeT $ do
@ -2022,12 +2026,12 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
maccept <- lift $ for mproject $ \ project -> do maccept <- lift $ for mproject $ \ project -> do
let obid = let obid =
case project of case project of
Left (_, Entity _ j) -> projectOutbox j Left (_, _, a) -> actorOutbox a
Right (_, Entity _ r, _, _, _) -> repoOutbox r Right (_, Entity _ r, _, _, _) -> repoOutbox r
obiidAccept <- insertEmptyOutboxItem obid now obiidAccept <- insertEmptyOutboxItem obid now
let insertTXL = let insertTXL =
case project of case project of
Left (_, Entity jid _) -> Left (_, Entity jid _, _) ->
\ tclid -> insert_ $ TicketProjectLocal tclid jid \ tclid -> insert_ $ TicketProjectLocal tclid jid
Right (_, Entity rid _, mb, _, _) -> Right (_, Entity rid _, mb, _, _) ->
\ tclid -> insert_ $ TicketRepoLocal tclid rid mb \ tclid -> insert_ $ TicketRepoLocal tclid rid mb
@ -2040,9 +2044,9 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
(docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid
let (actor, ibid) = let (actor, ibid) =
case project of case project of
Left (s, Entity _ j) -> Left (s, Entity _ j, a) ->
( LocalActorProject (sharerIdent s) (projectIdent j) ( LocalActorProject (sharerIdent s) (projectIdent j)
, projectInbox j , actorInbox a
) )
Right (s, Entity _ r, _, _, _) -> Right (s, Entity _ r, _, _, _) ->
( LocalActorRepo (sharerIdent s) (repoIdent r) ( LocalActorRepo (sharerIdent s) (repoIdent r)
@ -2237,7 +2241,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
insertAccept shrUser luOffer project obiidAccept ltid = do insertAccept shrUser luOffer project obiidAccept ltid = do
let (collections, outboxItemRoute, projectRoute, ticketRoute) = let (collections, outboxItemRoute, projectRoute, ticketRoute) =
case project of case project of
Left (s, Entity _ j) -> Left (s, Entity _ j, _) ->
let shr = sharerIdent s let shr = sharerIdent s
prj = projectIdent j prj = projectIdent j
in ( [ LocalPersonCollectionProjectTeam shr prj in ( [ LocalPersonCollectionProjectTeam shr prj
@ -2395,8 +2399,8 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget =
MaybeT (getValBy $ UniquePersonIdent sid) MaybeT (getValBy $ UniquePersonIdent sid)
WorkItemProjectTicket shr prj _ -> do WorkItemProjectTicket shr prj _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
projectInbox <$> j <- MaybeT $ getValBy $ UniqueProject prj sid
MaybeT (getValBy $ UniqueProject prj sid) lift $ actorInbox <$> getJust (projectActor j)
WorkItemRepoProposal shr rp _ -> do WorkItemRepoProposal shr rp _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
repoInbox <$> repoInbox <$>
@ -2422,8 +2426,9 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget =
return (personOutbox p, personInbox p) return (personOutbox p, personInbox p)
WorkItemProjectTicket shr prj _ -> do WorkItemProjectTicket shr prj _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
j <- MaybeT (getValBy $ UniqueProject prj sid) j <- MaybeT $ getValBy $ UniqueProject prj sid
return (projectOutbox j, projectInbox j) a <- lift $ getJust $ projectActor j
return (actorOutbox a, actorInbox a)
WorkItemRepoProposal shr rp _ -> do WorkItemRepoProposal shr rp _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
r <- MaybeT (getValBy $ UniqueRepo rp sid) r <- MaybeT (getValBy $ UniqueRepo rp sid)
@ -2646,8 +2651,9 @@ resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObjec
return (personOutbox p, personInbox p) return (personOutbox p, personInbox p)
WorkItemProjectTicket shr prj _ -> do WorkItemProjectTicket shr prj _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
j <- MaybeT (getValBy $ UniqueProject prj sid) j <- MaybeT $ getValBy $ UniqueProject prj sid
return (projectOutbox j, projectInbox j) a <- lift $ getJust $ projectActor j
return (actorOutbox a, actorInbox a)
WorkItemRepoProposal shr rp _ -> do WorkItemRepoProposal shr rp _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
r <- MaybeT (getValBy $ UniqueRepo rp sid) r <- MaybeT (getValBy $ UniqueRepo rp sid)
@ -2765,8 +2771,9 @@ undoC (Entity _pidUser personUser) sharerUser summary audience undo@(Undo uObjec
return (personOutbox p, personInbox p) return (personOutbox p, personInbox p)
WorkItemProjectTicket shr prj _ -> do WorkItemProjectTicket shr prj _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
j <- MaybeT (getValBy $ UniqueProject prj sid) j <- MaybeT $ getValBy $ UniqueProject prj sid
return (projectOutbox j, projectInbox j) a <- lift $ getJust $ projectActor j
return (actorOutbox a, actorInbox a)
WorkItemRepoProposal shr rp _ -> do WorkItemRepoProposal shr rp _ -> do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
r <- MaybeT (getValBy $ UniqueRepo rp sid) r <- MaybeT (getValBy $ UniqueRepo rp sid)

37
src/Vervis/ActivityPub.hs
View file

@ -38,7 +38,7 @@ module Vervis.ActivityPub
, checkForward , checkForward
, parseTarget , parseTarget
--, checkDep --, checkDep
, getProjectAndDeps --, getProjectAndDeps
, deliverRemoteDB' , deliverRemoteDB'
, deliverRemoteDB'' , deliverRemoteDB''
, deliverRemoteHttp , deliverRemoteHttp
@ -110,7 +110,7 @@ import Yesod.HttpSignature
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest import Network.HTTP.Digest
import Web.ActivityPub hiding (Author (..), Ticket, Project, Repo) import Web.ActivityPub hiding (Author (..), Ticket, Project (..), Repo, Actor (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.MonadSite import Yesod.MonadSite
import Yesod.FedURI import Yesod.FedURI
@ -515,6 +515,7 @@ checkDep hProject shrProject prjProject u = do
_ -> throwE "Expected ticket route, got non-ticket route" _ -> throwE "Expected ticket route, got non-ticket route"
-} -}
{-
getProjectAndDeps shr prj {-deps-} = do getProjectAndDeps shr prj {-deps-} = do
msid <- lift $ getKeyBy $ UniqueSharer shr msid <- lift $ getKeyBy $ UniqueSharer shr
sid <- fromMaybeE msid "Offer target: no such local sharer" sid <- fromMaybeE msid "Offer target: no such local sharer"
@ -526,6 +527,7 @@ getProjectAndDeps shr prj {-deps-} = do
fromMaybeE mtid "Local dep: No such ticket number in DB" fromMaybeE mtid "Local dep: No such ticket number in DB"
-} -}
return (sid, jid, projectInbox j, projectFollowers j{-, tids-}) return (sid, jid, projectInbox j, projectFollowers j{-, tids-})
-}
data Recip data Recip
= RecipRA (Entity RemoteActor) = RecipRA (Entity RemoteActor)
@ -918,8 +920,13 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
[prj | (prj, j) <- projects [prj | (prj, j) <- projects
, localRecipProject $ localRecipProjectDirect j , localRecipProject $ localRecipProjectDirect j
] ]
in map (projectInbox . entityVal) <$> in fmap (map E.unValue) $
selectList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] E.select $ E.from $ \ (j `E.InnerJoin` a) -> do
E.on $ j E.^. ProjectActor E.==. a E.^. ActorId
E.where_ $
j E.^. ProjectSharer E.==. E.val sid E.&&.
j E.^. ProjectIdent `E.in_` E.valList prjs
return $ a E.^. ActorInbox
getRepoInboxes sid repos = getRepoInboxes sid repos =
let rps = let rps =
[rp | (rp, r) <- repos [rp | (rp, r) <- repos
@ -983,8 +990,13 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
(localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj)) (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj))
] ]
fsidsJ <- fsidsJ <-
map (projectFollowers . entityVal) <$> fmap (map E.unValue) $
selectList [ProjectSharer ==. sid, ProjectIdent <-. prjsJ] [] E.select $ E.from $ \ (j `E.InnerJoin` a) -> do
E.on $ j E.^. ProjectActor E.==. a E.^. ActorId
E.where_ $
j E.^. ProjectSharer E.==. E.val sid E.&&.
j E.^. ProjectIdent `E.in_` E.valList prjsJ
return $ a E.^. ActorFollowers
let prjsT = let prjsT =
if requireOwner if requireOwner
then then
@ -1274,7 +1286,8 @@ getActivity (Left (actor, obiid)) = Just . Left <$> do
j <- do j <- do
mj <- lift $ getValBy $ UniqueProject prj sid mj <- lift $ getValBy $ UniqueProject prj sid
fromMaybeE mj "No such project" fromMaybeE mj "No such project"
return $ projectOutbox j a <- lift $ getJust $ projectActor j
return $ actorOutbox a
getActorOutbox (LocalActorRepo shr rp) = do getActorOutbox (LocalActorRepo shr rp) = do
sid <- do sid <- do
msid <- lift $ getKeyBy $ UniqueSharer shr msid <- lift $ getKeyBy $ UniqueSharer shr
@ -1295,12 +1308,16 @@ data ActorEntity
getOutboxActorEntity obid = do getOutboxActorEntity obid = do
mp <- getBy $ UniquePersonOutbox obid mp <- getBy $ UniquePersonOutbox obid
mj <- getBy $ UniqueProjectOutbox obid ma <- getBy $ UniqueActorOutbox obid
mr <- getBy $ UniqueRepoOutbox obid mr <- getBy $ UniqueRepoOutbox obid
case (mp, mj, mr) of case (mp, ma, mr) of
(Nothing, Nothing, Nothing) -> error "obid not in use" (Nothing, Nothing, Nothing) -> error "obid not in use"
(Just p, Nothing, Nothing) -> return $ ActorPerson p (Just p, Nothing, Nothing) -> return $ ActorPerson p
(Nothing, Just j, Nothing) -> return $ ActorProject j (Nothing, Just (Entity aid _), Nothing) -> do
mj <- getBy $ UniqueProjectActor aid
case mj of
Nothing -> error "found Actor not in use by any Project"
Just j -> return $ ActorProject j
(Nothing, Nothing, Just r) -> return $ ActorRepo r (Nothing, Nothing, Just r) -> return $ ActorRepo r
_ -> error "obid used by multiple actors" _ -> error "obid used by multiple actors"

8
src/Vervis/Client.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -54,7 +54,7 @@ import qualified Data.Text.Lazy as TL
import Development.PatchMediaType import Development.PatchMediaType
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Follow, Ticket, Project, Repo) import Web.ActivityPub hiding (Follow, Ticket, Project (..), Repo, Actor (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -428,8 +428,8 @@ undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee =
msid <- lift $ getKeyBy $ UniqueSharer shrFollowee msid <- lift $ getKeyBy $ UniqueSharer shrFollowee
fromMaybeE msid "No such local sharer" fromMaybeE msid "No such local sharer"
mj <- lift $ getValBy $ UniqueProject prjFollowee sidFollowee mj <- lift $ getValBy $ UniqueProject prjFollowee sidFollowee
projectFollowers <$> j <- fromMaybeE mj "Unfollow target no such local project"
fromMaybeE mj "Unfollow target no such local project" lift $ actorFollowers <$> getJust (projectActor j)
undoFollowTicket undoFollowTicket
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)

13
src/Vervis/Federation.hs
View file

@ -197,11 +197,14 @@ handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalProject jid
getBy404 $ UniquePersonIdent sid getBy404 $ UniquePersonIdent sid
mobi <- lift $ get obiid mobi <- lift $ get obiid
obi <- fromMaybeE mobi "Local activity: No such ID in DB" obi <- fromMaybeE mobi "Local activity: No such ID in DB"
mjidOutbox <- maidOutbox <-
lift $ getKeyBy $ UniqueProjectOutbox $ outboxItemOutbox obi lift $ getKeyBy $ UniqueActorOutbox $ outboxItemOutbox obi
jidOutbox <- aidOutbox <-
fromMaybeE mjidOutbox "Local activity not in a project outbox" fromMaybeE maidOutbox "Local activity not in an actor outbox"
j <- lift $ getJust jidOutbox mejOutbox <-
lift $ getBy $ UniqueProjectActor aidOutbox
Entity jidOutbox j <-
fromMaybeE mejOutbox "Local activity not in a project outbox"
s <- lift $ getJust $ projectSharer j s <- lift $ getJust $ projectSharer j
unless (sharerIdent s == shrActivity) $ unless (sharerIdent s == shrActivity) $
throwE "Local activity: ID invalid, hashid and author shr mismatch" throwE "Local activity: ID invalid, hashid and author shr mismatch"

7
src/Vervis/Federation/Discussion.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -53,7 +53,7 @@ import Yesod.HttpSignature
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest import Network.HTTP.Digest
import Web.ActivityPub import Web.ActivityPub hiding (Project (..), Actor (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -434,7 +434,8 @@ projectCreateNoteF now shrRecip prjRecip author body mfwd luCreate note = do
getProjectRecip404 = do getProjectRecip404 = do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- getBy404 $ UniqueProject prjRecip sid Entity jid j <- getBy404 $ UniqueProject prjRecip sid
return (jid, projectInbox j) a <- getJust $ projectActor j
return (jid, actorInbox a)
repoCreateNoteF repoCreateNoteF
:: UTCTime :: UTCTime

28
src/Vervis/Federation/Offer.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -63,7 +63,7 @@ import qualified Data.Text.Lazy as TL
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Ticket (..), Follow) import Web.ActivityPub hiding (Ticket (..), Follow, Project (..), Actor (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -466,8 +466,8 @@ projectFollowF shr prj =
objRoute objRoute
(ProjectR shr prj) (ProjectR shr prj)
getRecip getRecip
(projectInbox . fst) (actorInbox . fst)
(projectOutbox . fst) (actorOutbox . fst)
followers followers
(ProjectOutboxItemR shr prj) (ProjectOutboxItemR shr prj)
where where
@ -480,17 +480,18 @@ projectFollowF shr prj =
getRecip mltkhid = do getRecip mltkhid = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid j <- getValBy404 $ UniqueProject prj sid
a <- getJust $ projectActor j
mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do
ltid <- decodeKeyHashidM ltkhid ltid <- decodeKeyHashidM ltkhid
(_, _, _, Entity _ lt, _, _, _, _) <- MaybeT $ getProjectTicket shr prj ltid (_, _, _, Entity _ lt, _, _, _, _) <- MaybeT $ getProjectTicket shr prj ltid
return lt return lt
return $ return $
case mmt of case mmt of
Nothing -> Just (j, Nothing) Nothing -> Just (a, Nothing)
Just Nothing -> Nothing Just Nothing -> Nothing
Just (Just t) -> Just (j, Just t) Just (Just t) -> Just (a, Just t)
followers (j, Nothing) = projectFollowers j followers (a, Nothing) = actorFollowers a
followers (_, Just lt) = localTicketFollowers lt followers (_, Just lt) = localTicketFollowers lt
repoFollowF repoFollowF
@ -715,10 +716,11 @@ projectUndoF
projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do
object <- parseActivity uObj object <- parseActivity uObj
mmmhttp <- runDBExcept $ do mmmhttp <- runDBExcept $ do
Entity jid j <- lift $ do (Entity jid j, a) <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueProject prjRecip sid ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid
mractid <- lift $ insertToInbox now author body (projectInbox j) luUndo False (ej,) <$> getJust (projectActor j)
mractid <- lift $ insertToInbox now author body (actorInbox a) luUndo False
for mractid $ \ ractid -> do for mractid $ \ ractid -> do
mobject' <- getActivity object mobject' <- getActivity object
lift $ for mobject' $ \ object' -> do lift $ for mobject' $ \ object' -> do
@ -728,7 +730,7 @@ projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do
for mobject'' $ \ object'' -> do for mobject'' $ \ object'' -> do
(result, mfwdColl, macceptAuds) <- (result, mfwdColl, macceptAuds) <-
case object'' of case object'' of
Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (projectFollowers j) erf Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (actorFollowers a) erf
Right tr -> deleteResolve myWorkItem prepareAccept tr Right tr -> deleteResolve myWorkItem prepareAccept tr
mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
let sieve = makeRecipientSet [] colls let sieve = makeRecipientSet [] colls
@ -739,14 +741,14 @@ projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do
sieve False False localRecips sieve False False localRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAcceptOnUndo (LocalActorProject shrRecip prjRecip) author luUndo obiidAccept acceptAuds insertAcceptOnUndo (LocalActorProject shrRecip prjRecip) author luUndo obiidAccept acceptAuds
knownRemoteRecipsAccept <- knownRemoteRecipsAccept <-
deliverLocal' deliverLocal'
False False
(LocalActorProject shrRecip prjRecip) (LocalActorProject shrRecip prjRecip)
(projectInbox j) (actorInbox a)
obiidAccept obiidAccept
localRecipsAccept localRecipsAccept
(obiidAccept,docAccept,fwdHostsAccept,) <$> (obiidAccept,docAccept,fwdHostsAccept,) <$>

38
src/Vervis/Federation/Ticket.hs
View file

@ -78,7 +78,7 @@ import qualified Data.Text.Lazy as TL
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Patch, Ticket (..), Repo (..)) import Web.ActivityPub hiding (Patch, Ticket (..), Repo (..), Project (..), Actor (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -325,7 +325,8 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
Entity jid j <- do Entity jid j <- do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueProject prjRecip sid getBy404 $ UniqueProject prjRecip sid
mractid <- insertToInbox now author body (projectInbox j) luOffer False a <- getJust $ projectActor j
mractid <- insertToInbox now author body (actorInbox a) luOffer False
for mractid $ \ ractid -> do for mractid $ \ ractid -> do
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
let sieve = let sieve =
@ -341,7 +342,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
sieve False False localRecips sieve False False localRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
(obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do (obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do
obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now
(_, ltid) <- insertLocalTicket now author (flip TicketProjectLocal jid) summary content source ractid obiidAccept (_, ltid) <- insertLocalTicket now author (flip TicketProjectLocal jid) summary content source ractid obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept shrRecip prjRecip author luOffer ltid obiidAccept insertAccept shrRecip prjRecip author luOffer ltid obiidAccept
@ -349,7 +350,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
deliverLocal' deliverLocal'
False False
(LocalActorProject shrRecip prjRecip) (LocalActorProject shrRecip prjRecip)
(projectInbox j) (actorInbox a)
obiidAccept obiidAccept
localRecipsAccept localRecipsAccept
(obiidAccept,docAccept,fwdHostsAccept,) <$> (obiidAccept,docAccept,fwdHostsAccept,) <$>
@ -946,9 +947,10 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa
Entity jid j <- do Entity jid j <- do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueProject prjRecip sid getBy404 $ UniqueProject prjRecip sid
mractid <- insertToInbox now author body (projectInbox j) luCreate False a <- getJust $ projectActor j
mractid <- insertToInbox now author body (actorInbox a) luCreate False
for mractid $ \ ractid -> do for mractid $ \ ractid -> do
obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now
let makeTPL tclid = TicketProjectLocal tclid jid let makeTPL tclid = TicketProjectLocal tclid jid
result <- insertRemoteTicket makeTPL author (AP.ticketId tlocal) published title desc src ractid obiidAccept result <- insertRemoteTicket makeTPL author (AP.ticketId tlocal) published title desc src ractid obiidAccept
unless (isRight result) $ delete obiidAccept unless (isRight result) $ delete obiidAccept
@ -972,7 +974,7 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa
deliverLocal' deliverLocal'
False False
(LocalActorProject shrRecip prjRecip) (LocalActorProject shrRecip prjRecip)
(projectInbox j) (actorInbox a)
obiidAccept obiidAccept
localRecipsAccept localRecipsAccept
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
@ -2191,9 +2193,10 @@ projectOfferDepF
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do
(parent, child) <- checkDepAndTarget dep uTarget (parent, child) <- checkDepAndTarget dep uTarget
Entity jidRecip projectRecip <- lift $ runDB $ do (Entity jidRecip projectRecip, actorRecip) <- lift $ runDB $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueProject prjRecip sid ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid
(ej,) <$> getJust (projectActor j)
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
relevantParent <- relevantParent <-
for (ticketRelevance shrRecip prjRecip parent) $ \ parentLtid -> do for (ticketRelevance shrRecip prjRecip parent) $ \ parentLtid -> do
@ -2205,7 +2208,7 @@ projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do
childDetail <- getWorkItemDetail "Child" child childDetail <- getWorkItemDetail "Child" child
return (parentLtid, parentAuthor, childDetail) return (parentLtid, parentAuthor, childDetail)
mhttp <- runSiteDBExcept $ do mhttp <- runSiteDBExcept $ do
mractid <- lift $ insertToInbox' now author body (projectInbox projectRecip) luOffer False mractid <- lift $ insertToInbox' now author body (actorInbox actorRecip) luOffer False
for mractid $ \ (ractid, ibiid) -> do for mractid $ \ (ractid, ibiid) -> do
insertDepOffer ibiid parent child insertDepOffer ibiid parent child
mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do
@ -2223,7 +2226,7 @@ projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do
sieve False False localRecips sieve False False localRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips
mremotesHttpAccept <- lift $ for relevantParent $ \ (parentLtid, parentAuthor, childDetail) -> do mremotesHttpAccept <- lift $ for relevantParent $ \ (parentLtid, parentAuthor, childDetail) -> do
obiidAccept <- insertEmptyOutboxItem (projectOutbox projectRecip) now obiidAccept <- insertEmptyOutboxItem (actorOutbox actorRecip) now
tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept luOffer obiidAccept tdid parentLtid parentAuthor childDetail insertAccept luOffer obiidAccept tdid parentLtid parentAuthor childDetail
@ -2231,7 +2234,7 @@ projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do
deliverLocal' deliverLocal'
False False
(LocalActorProject shrRecip prjRecip) (LocalActorProject shrRecip prjRecip)
(projectInbox projectRecip) (actorInbox actorRecip)
obiidAccept obiidAccept
localRecipsAccept localRecipsAccept
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
@ -2679,9 +2682,10 @@ projectResolveF
projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObject) = do projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObject) = do
object <- parseWorkItem "Resolve object" uObject object <- parseWorkItem "Resolve object" uObject
mmmmhttp <- runDBExcept $ do mmmmhttp <- runDBExcept $ do
Entity jidRecip projectRecip <- lift $ do (Entity jidRecip projectRecip, actorRecip) <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueProject prjRecip sid ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid
(ej,) <$> getJust (projectActor j)
mltid <- mltid <-
case relevantObject object of case relevantObject object of
Nothing -> do Nothing -> do
@ -2690,7 +2694,7 @@ projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObjec
Right _ -> return () Right _ -> return ()
return Nothing return Nothing
Just ltid -> Just . (ltid,) <$> getObjectLtid ltid Just ltid -> Just . (ltid,) <$> getObjectLtid ltid
mractid <- lift $ insertToInbox now author body (projectInbox projectRecip) luResolve False mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luResolve False
lift $ for mractid $ \ ractid -> for mltid $ \ (ltid, tid) -> do lift $ for mractid $ \ ractid -> for mltid $ \ (ltid, tid) -> do
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
ltkhid <- encodeKeyHashid ltid ltkhid <- encodeKeyHashid ltid
@ -2707,7 +2711,7 @@ projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObjec
localRecipSieve' localRecipSieve'
sieve False False localRecips sieve False False localRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips
obiidAccept <- insertEmptyOutboxItem (projectOutbox projectRecip) now obiidAccept <- insertEmptyOutboxItem (actorOutbox actorRecip) now
mmtrrid <- insertResolve author ltid ractid obiidAccept mmtrrid <- insertResolve author ltid ractid obiidAccept
case mmtrrid of case mmtrrid of
Just (Just _) -> update tid [TicketStatus =. TSClosed] Just (Just _) -> update tid [TicketStatus =. TSClosed]
@ -2719,7 +2723,7 @@ projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObjec
deliverLocal' deliverLocal'
False False
(LocalActorProject shrRecip prjRecip) (LocalActorProject shrRecip prjRecip)
(projectInbox projectRecip) (actorInbox actorRecip)
obiidAccept obiidAccept
localRecipsAccept localRecipsAccept
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>

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

@ -113,7 +113,8 @@ newProjectCollabForm sid jid = renderDivs $ newProjectCollabAForm sid jid
editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
editProjectAForm sid (Entity jid project) = Project editProjectAForm sid (Entity jid project) = Project
<$> pure (projectIdent project) <$> pure (projectActor project)
<*> pure (projectIdent project)
<*> pure (projectSharer project) <*> pure (projectSharer project)
<*> aopt textField "Name" (Just $ projectName project) <*> aopt textField "Name" (Just $ projectName project)
<*> aopt textField "Description" (Just $ projectDesc project) <*> aopt textField "Description" (Just $ projectDesc project)
@ -122,9 +123,6 @@ editProjectAForm sid (Entity jid project) = Project
<*> aopt selectWiki "Wiki" (Just $ projectWiki project) <*> aopt selectWiki "Wiki" (Just $ projectWiki 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 (projectOutbox project)
<*> pure (projectFollowers project)
where where
selectWiki = selectWiki =
selectField $ selectField $

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

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -75,7 +75,7 @@ import qualified Database.Esqueleto as E
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub import Web.ActivityPub hiding (Project (..), Actor (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
import Yesod.FedURI import Yesod.FedURI
@ -257,7 +257,8 @@ getProjectInboxR shr prj = getInbox here getInboxId
getInboxId = do getInboxId = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid j <- getValBy404 $ UniqueProject prj sid
return $ projectInbox j a <- getJust $ projectActor j
return $ actorInbox a
getRepoInboxR :: ShrIdent -> RpIdent -> Handler TypedContent getRepoInboxR :: ShrIdent -> RpIdent -> Handler TypedContent
getRepoInboxR shr rp = getInbox here getInboxId getRepoInboxR shr rp = getInbox here getInboxId
@ -430,7 +431,8 @@ getProjectOutboxR shr prj = getOutbox here getObid
getObid = do getObid = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid j <- getValBy404 $ UniqueProject prj sid
return $ projectOutbox j a <- getJust $ projectActor j
return $ actorOutbox a
getProjectOutboxItemR getProjectOutboxItemR
:: ShrIdent -> PrjIdent -> KeyHashid OutboxItem -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid OutboxItem -> Handler TypedContent
@ -440,7 +442,8 @@ getProjectOutboxItemR shr prj obikhid = getOutboxItem here getObid obikhid
getObid = do getObid = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid j <- getValBy404 $ UniqueProject prj sid
return $ projectOutbox j a <- getJust $ projectActor j
return $ actorOutbox a
getRepoOutboxR :: ShrIdent -> RpIdent -> Handler TypedContent getRepoOutboxR :: ShrIdent -> RpIdent -> Handler TypedContent
getRepoOutboxR shr rp = getOutbox here getObid getRepoOutboxR shr rp = getOutbox here getObid

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

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -42,7 +42,7 @@ import Yesod.Hashids
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model hiding (Actor (..))
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Secure import Vervis.Secure
import Vervis.Settings import Vervis.Settings

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

@ -51,7 +51,7 @@ import qualified Database.Esqueleto as E
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Project (..), Repo (..)) import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.MonadSite import Yesod.MonadSite
@ -97,8 +97,17 @@ postProjectsR shr = do
ibid <- insert Inbox ibid <- insert Inbox
obid <- insert Outbox obid <- insert Outbox
fsid <- insert FollowerSet fsid <- insert FollowerSet
aid <- insert Actor
{ actorName = fromMaybe "" $ npName np
, actorDesc = fromMaybe "" $ npDesc np
, actorCreatedAt = now
, actorInbox = ibid
, actorOutbox = obid
, actorFollowers = fsid
}
let project = Project let project = Project
{ projectIdent = npIdent np { projectActor = aid
, projectIdent = npIdent np
, projectSharer = sid , projectSharer = sid
, projectName = npName np , projectName = npName np
, projectDesc = npDesc np , projectDesc = npDesc np
@ -107,9 +116,6 @@ postProjectsR shr = do
, projectWiki = Nothing , projectWiki = Nothing
, projectCollabAnon = Nothing , projectCollabAnon = Nothing
, projectCollabUser = Nothing , projectCollabUser = Nothing
, projectInbox = ibid
, projectOutbox = obid
, projectFollowers = fsid
} }
jid <- insert project jid <- insert project
@ -141,7 +147,7 @@ getProjectNewR shr = do
getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectR shar proj = do getProjectR shar proj = do
(project, workflow, wsharer, repos) <- runDB $ do (actor, 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
@ -150,29 +156,30 @@ getProjectR shar proj = do
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) a <- getJust $ projectActor p
return (a, p, w, sw, rs)
route2fed <- getEncodeRouteHome route2fed <- getEncodeRouteHome
route2local <- getEncodeRouteLocal route2local <- getEncodeRouteLocal
let projectAP = AP.Project let projectAP = AP.Project
{ AP.projectActor = Actor { AP.projectActor = AP.Actor
{ actorId = route2local $ ProjectR shar proj { AP.actorId = route2local $ ProjectR shar proj
, actorType = ActorTypeProject , AP.actorType = ActorTypeProject
, actorUsername = Nothing , AP.actorUsername = Nothing
, actorName = , AP.actorName =
Just $ fromMaybe (prj2text proj) $ projectName project Just $ fromMaybe (prj2text proj) $ projectName project
, actorSummary = projectDesc project , AP.actorSummary = projectDesc project
, actorInbox = route2local $ ProjectInboxR shar proj , AP.actorInbox = route2local $ ProjectInboxR shar proj
, actorOutbox = , AP.actorOutbox =
Just $ route2local $ ProjectOutboxR shar proj Just $ route2local $ ProjectOutboxR shar proj
, actorFollowers = , AP.actorFollowers =
Just $ route2local $ ProjectFollowersR shar proj Just $ route2local $ ProjectFollowersR shar proj
, actorFollowing = Nothing , AP.actorFollowing = Nothing
, actorPublicKeys = , AP.actorPublicKeys =
[ Left $ route2local ActorKey1R [ Left $ route2local ActorKey1R
, Left $ route2local ActorKey2R , Left $ route2local ActorKey2R
] ]
, actorSshKeys = [] , AP.actorSshKeys = []
} }
, AP.projectTeam = route2local $ ProjectTeamR shar proj , AP.projectTeam = route2local $ ProjectTeamR shar proj
} }
@ -180,7 +187,7 @@ getProjectR shar proj = do
followW followW
(ProjectFollowR shar proj) (ProjectFollowR shar proj)
(ProjectUnfollowR shar proj) (ProjectUnfollowR shar proj)
(return $ projectFollowers project) (return $ actorFollowers actor)
provideHtmlAndAP projectAP $(widgetFile "project/one") provideHtmlAndAP projectAP $(widgetFile "project/one")
putProjectR :: ShrIdent -> PrjIdent -> Handler Html putProjectR :: ShrIdent -> PrjIdent -> Handler Html
@ -240,7 +247,8 @@ postProjectDevsR shr rp = do
(sid, jid, obid) <- runDB $ do (sid, jid, obid) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid j <- getBy404 $ UniqueProject rp sid Entity jid j <- getBy404 $ UniqueProject rp sid
return (sid, jid, projectOutbox j) a <- getJust $ projectActor j
return (sid, jid, actorOutbox a)
((result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid ((result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid
case result of case result of
FormSuccess nc -> do FormSuccess nc -> do
@ -390,4 +398,5 @@ getProjectFollowersR shr prj = getFollowersCollection here getFsid
getFsid = do getFsid = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid j <- getValBy404 $ UniqueProject prj sid
return $ projectFollowers j a <- getJust $ projectActor j
return $ actorFollowers a

2
src/Vervis/Handler/Repo.hs
View file

@ -117,7 +117,7 @@ import Vervis.Foundation
import Vervis.Handler.Repo.Darcs import Vervis.Handler.Repo.Darcs
import Vervis.Handler.Repo.Git import Vervis.Handler.Repo.Git
import Vervis.Path import Vervis.Path
import Vervis.Model import Vervis.Model hiding (Actor (..))
import Vervis.Model.Ident import Vervis.Model.Ident
import Development.PatchMediaType import Development.PatchMediaType
import Vervis.Paginate import Vervis.Paginate

12
src/Vervis/Handler/Sharer.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -137,13 +137,13 @@ getSharerFollowingR shr = do
selectList [PersonFollowers <-. fsids] [] selectList [PersonFollowers <-. fsids] []
map (SharerR . sharerIdent . entityVal) <$> map (SharerR . sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] [] selectList [SharerId <-. sids] []
getProjects fsids = do getProjects fsids =
jids <- selectKeysList [ProjectFollowers <-. fsids] [] fmap (map $ \ (E.Value shr, E.Value prj) -> ProjectR shr prj) $
pairs <- E.select $ E.from $ \ (j `E.InnerJoin` s) -> do E.select $ E.from $ \ (a `E.InnerJoin` j `E.InnerJoin` s) -> do
E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId
E.where_ $ j E.^. ProjectId `E.in_` E.valList jids E.on $ a E.^. ActorId E.==. j E.^. ProjectActor
E.where_ $ a E.^. ActorFollowers `E.in_` E.valList fsids
return (s E.^. SharerIdent, j E.^. ProjectIdent) return (s E.^. SharerIdent, j E.^. ProjectIdent)
return $ map (\ (E.Value shr, E.Value prj) -> ProjectR shr prj) pairs
getTickets fsids = do getTickets fsids = do
ltids <- selectKeysList [LocalTicketFollowers <-. fsids] [] ltids <- selectKeysList [LocalTicketFollowers <-. fsids] []
triples <- triples <-

44
src/Vervis/Migration.hs
View file

@ -1829,6 +1829,50 @@ changes hLocal ctx =
, removeEntity "RepoCollab" , removeEntity "RepoCollab"
-- 287 -- 287
, removeEntity "ProjectCollab" , removeEntity "ProjectCollab"
-- 288
, addEntities model_2022_07_17
-- 289
, addFieldRefRequired''
"Project"
(do ibid <- insert Inbox289
obid <- insert Outbox289
fsid <- insert FollowerSet289
insertEntity $ Actor289 "" "" defaultTime ibid obid fsid
)
(Just $ \ (Entity aidTemp aTemp) -> do
js <- selectList ([] :: [Filter Project289]) []
for js $ \ (Entity jid j) -> do
aid <- insert Actor289
{ actor289Name = fromMaybe "" $ project289Name j
, actor289Desc = fromMaybe "" $ project289Desc j
, actor289CreatedAt = defaultTime
, actor289Inbox = project289Inbox j
, actor289Outbox = project289Outbox j
, actor289Followers = project289Followers j
}
update jid [Project289Actor =. aid]
delete aidTemp
delete $ actor289Inbox aTemp
delete $ actor289Outbox aTemp
delete $ actor289Followers aTemp
)
"actor"
"Actor"
-- 290
, addUnique "Project" $ Unique "UniqueProjectActor" ["actor"]
-- 291
, removeUnique "Project" "UniqueProjectInbox"
-- 292
, removeUnique "Project" "UniqueProjectOutbox"
-- 293
, removeUnique "Project" "UniqueProjectFollowers"
-- 294
, removeField "Project" "inbox"
-- 295
, removeField "Project" "outbox"
-- 296
, removeField "Project" "followers"
] ]
migrateDB migrateDB

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

@ -259,6 +259,13 @@ module Vervis.Migration.Model
, Repo285Generic (..) , Repo285Generic (..)
, RepoCollab285 , RepoCollab285
, RepoCollab285Generic (..) , RepoCollab285Generic (..)
, model_2022_07_17
, Project289
, Inbox289Generic (..)
, Outbox289Generic (..)
, FollowerSet289Generic (..)
, Actor289Generic (..)
, Project289Generic (..)
) )
where where
@ -501,3 +508,9 @@ model_2022_06_14 = $(schema "2022_06_14_collab")
makeEntitiesMigration "285" makeEntitiesMigration "285"
$(modelFile "migrations/2022_06_14_collab_mig.model") $(modelFile "migrations/2022_06_14_collab_mig.model")
model_2022_07_17 :: [Entity SqlBackend]
model_2022_07_17 = $(schema "2022_07_17_actor")
makeEntitiesMigration "289"
$(modelFile "migrations/2022_07_17_project_actor.model")

4
src/Vervis/RemoteActorStore.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -65,7 +65,7 @@ import Web.ActivityPub
import Yesod.MonadSite import Yesod.MonadSite
import Vervis.FedURI import Vervis.FedURI
import Vervis.Model import Vervis.Model hiding (Actor (..))
newtype InstanceMutex = InstanceMutex (TVar (HashMap Host (MVar ()))) newtype InstanceMutex = InstanceMutex (TVar (HashMap Host (MVar ())))