From 88b8027572468204f0a1d6bad4c510de2a9e1fb9 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 19 Jul 2022 12:12:49 +0000 Subject: [PATCH] DB: Move project inbox, outbox & followers into a new Actor table --- config/models | 20 ++++++--- migrations/2022_07_17_actor.model | 11 +++++ migrations/2022_07_17_project_actor.model | 28 ++++++++++++ src/Vervis/API.hs | 55 +++++++++++++---------- src/Vervis/ActivityPub.hs | 37 ++++++++++----- src/Vervis/Client.hs | 8 ++-- src/Vervis/Federation.hs | 13 +++--- src/Vervis/Federation/Discussion.hs | 7 +-- src/Vervis/Federation/Offer.hs | 28 ++++++------ src/Vervis/Federation/Ticket.hs | 38 +++++++++------- src/Vervis/Form/Project.hs | 6 +-- src/Vervis/Handler/Inbox.hs | 13 +++--- src/Vervis/Handler/Person.hs | 4 +- src/Vervis/Handler/Project.hs | 53 +++++++++++++--------- src/Vervis/Handler/Repo.hs | 2 +- src/Vervis/Handler/Sharer.hs | 12 ++--- src/Vervis/Migration.hs | 44 ++++++++++++++++++ src/Vervis/Migration/Model.hs | 13 ++++++ src/Vervis/RemoteActorStore.hs | 4 +- 19 files changed, 272 insertions(+), 124 deletions(-) create mode 100644 migrations/2022_07_17_actor.model create mode 100644 migrations/2022_07_17_project_actor.model diff --git a/config/models b/config/models index cb38de6..e083ca1 100644 --- a/config/models +++ b/config/models @@ -32,6 +32,18 @@ RemoteObject -- People ------------------------------------------------------------------------------- +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + Sharer ident ShrIdent name Text Maybe @@ -265,6 +277,7 @@ RoleAccess ------------------------------------------------------------------------------- Project + actor ActorId ident PrjIdent sharer SharerId name Text Maybe @@ -274,14 +287,9 @@ Project wiki RepoId Maybe collabUser RoleId Maybe collabAnon RoleId Maybe - inbox InboxId - outbox OutboxId - followers FollowerSetId + UniqueProjectActor actor UniqueProject ident sharer - UniqueProjectInbox inbox - UniqueProjectOutbox outbox - UniqueProjectFollowers followers Repo ident RpIdent diff --git a/migrations/2022_07_17_actor.model b/migrations/2022_07_17_actor.model new file mode 100644 index 0000000..d029d2b --- /dev/null +++ b/migrations/2022_07_17_actor.model @@ -0,0 +1,11 @@ +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers diff --git a/migrations/2022_07_17_project_actor.model b/migrations/2022_07_17_project_actor.model new file mode 100644 index 0000000..3df260a --- /dev/null +++ b/migrations/2022_07_17_project_actor.model @@ -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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 10da867..a2dee7b 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -87,7 +87,7 @@ import Crypto.PublicVerifKey import Database.Persist.JSON import Network.FedURI 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.Auth.Unverified import Yesod.FedURI @@ -1199,13 +1199,13 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT ] (recipsC, ibid, actor) = case ent of - Left (Entity _ j) -> + Left (Entity _ j, a) -> let prj = projectIdent j in ( [ LocalPersonCollectionProjectTeam shr prj , LocalPersonCollectionProjectFollowers shr prj , LocalPersonCollectionSharerFollowers shrUser ] - , projectInbox j + , actorInbox a , LocalActorProject shr prj ) Right (Entity _ r, _, _, _) -> @@ -1465,8 +1465,9 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getBy $ UniqueProject prj sid ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project" - obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now - return (shr, Left ej, obiidAccept) + a <- lift $ getJust $ projectActor j + obiidAccept <- lift $ insertEmptyOutboxItem (actorOutbox a) now + return (shr, Left (ej, a), obiidAccept) prepareProject now (Left (WITRepo shr rp mb typ diff)) = Left <$> do mer <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr @@ -1515,7 +1516,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT , ticketContextLocalAccept = obiidAccept } case ent of - Left (Entity jid _) -> do + Left (Entity jid _, _) -> do insert_ TicketProjectLocal { ticketProjectLocalContext = tclid , ticketProjectLocalProject = jid @@ -1707,7 +1708,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT talkhid <- encodeKeyHashid talid let (outboxItemRoute, actorRoute) = case ent of - Left (Entity _ j) -> + Left (Entity _ j, _) -> let prj = projectIdent j in (ProjectOutboxItemR shrJ prj, ProjectR shrJ prj) Right (Entity _ r, _, _, _) -> @@ -1846,14 +1847,16 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getValBy $ UniqueProject prj sid 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 (_, Entity _ j, _, Entity _ lt, _, _, _, _) <- do mticket <- lift $ runMaybeT $ do ltid <- decodeKeyHashidM ltkhid MaybeT $ getProjectTicket shr prj ltid 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 mrepo <- lift $ runMaybeT $ do 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 mproj <- lift $ runMaybeT $ do Entity sid s <- MaybeT $ getBy $ UniqueSharer shr - ej <- MaybeT $ getBy $ UniqueProject prj sid - return (s, ej) + ej@(Entity _ j) <- MaybeT $ getBy $ UniqueProject prj sid + a <- lift $ getJust $ projectActor j + return (s, ej, a) fromMaybeE mproj "Offer target no such local project in DB" Left (WITRepo shr rp mb typ diffs) -> Just . Right <$> do mproj <- lift $ runMaybeT $ do @@ -2022,12 +2026,12 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar maccept <- lift $ for mproject $ \ project -> do let obid = case project of - Left (_, Entity _ j) -> projectOutbox j + Left (_, _, a) -> actorOutbox a Right (_, Entity _ r, _, _, _) -> repoOutbox r obiidAccept <- insertEmptyOutboxItem obid now let insertTXL = case project of - Left (_, Entity jid _) -> + Left (_, Entity jid _, _) -> \ tclid -> insert_ $ TicketProjectLocal tclid jid Right (_, Entity 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 let (actor, ibid) = case project of - Left (s, Entity _ j) -> + Left (s, Entity _ j, a) -> ( LocalActorProject (sharerIdent s) (projectIdent j) - , projectInbox j + , actorInbox a ) Right (s, Entity _ 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 let (collections, outboxItemRoute, projectRoute, ticketRoute) = case project of - Left (s, Entity _ j) -> + Left (s, Entity _ j, _) -> let shr = sharerIdent s prj = projectIdent j in ( [ LocalPersonCollectionProjectTeam shr prj @@ -2395,8 +2399,8 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = MaybeT (getValBy $ UniquePersonIdent sid) WorkItemProjectTicket shr prj _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr - projectInbox <$> - MaybeT (getValBy $ UniqueProject prj sid) + j <- MaybeT $ getValBy $ UniqueProject prj sid + lift $ actorInbox <$> getJust (projectActor j) WorkItemRepoProposal shr rp _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr repoInbox <$> @@ -2422,8 +2426,9 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = return (personOutbox p, personInbox p) WorkItemProjectTicket shr prj _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr - j <- MaybeT (getValBy $ UniqueProject prj sid) - return (projectOutbox j, projectInbox j) + j <- MaybeT $ getValBy $ UniqueProject prj sid + a <- lift $ getJust $ projectActor j + return (actorOutbox a, actorInbox a) WorkItemRepoProposal shr rp _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr r <- MaybeT (getValBy $ UniqueRepo rp sid) @@ -2646,8 +2651,9 @@ resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObjec return (personOutbox p, personInbox p) WorkItemProjectTicket shr prj _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr - j <- MaybeT (getValBy $ UniqueProject prj sid) - return (projectOutbox j, projectInbox j) + j <- MaybeT $ getValBy $ UniqueProject prj sid + a <- lift $ getJust $ projectActor j + return (actorOutbox a, actorInbox a) WorkItemRepoProposal shr rp _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr 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) WorkItemProjectTicket shr prj _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr - j <- MaybeT (getValBy $ UniqueProject prj sid) - return (projectOutbox j, projectInbox j) + j <- MaybeT $ getValBy $ UniqueProject prj sid + a <- lift $ getJust $ projectActor j + return (actorOutbox a, actorInbox a) WorkItemRepoProposal shr rp _ -> do sid <- MaybeT $ getKeyBy $ UniqueSharer shr r <- MaybeT (getValBy $ UniqueRepo rp sid) diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 73c69cb..a891448 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -38,7 +38,7 @@ module Vervis.ActivityPub , checkForward , parseTarget --, checkDep - , getProjectAndDeps + --, getProjectAndDeps , deliverRemoteDB' , deliverRemoteDB'' , deliverRemoteHttp @@ -110,7 +110,7 @@ import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI 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.MonadSite import Yesod.FedURI @@ -515,6 +515,7 @@ checkDep hProject shrProject prjProject u = do _ -> throwE "Expected ticket route, got non-ticket route" -} +{- getProjectAndDeps shr prj {-deps-} = do msid <- lift $ getKeyBy $ UniqueSharer shr 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" -} return (sid, jid, projectInbox j, projectFollowers j{-, tids-}) +-} data Recip = RecipRA (Entity RemoteActor) @@ -918,8 +920,13 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci [prj | (prj, j) <- projects , localRecipProject $ localRecipProjectDirect j ] - in map (projectInbox . entityVal) <$> - selectList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] + in fmap (map E.unValue) $ + 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 = let rps = [rp | (rp, r) <- repos @@ -983,8 +990,13 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj)) ] fsidsJ <- - map (projectFollowers . entityVal) <$> - selectList [ProjectSharer ==. sid, ProjectIdent <-. prjsJ] [] + fmap (map E.unValue) $ + 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 = if requireOwner then @@ -1274,7 +1286,8 @@ getActivity (Left (actor, obiid)) = Just . Left <$> do j <- do mj <- lift $ getValBy $ UniqueProject prj sid fromMaybeE mj "No such project" - return $ projectOutbox j + a <- lift $ getJust $ projectActor j + return $ actorOutbox a getActorOutbox (LocalActorRepo shr rp) = do sid <- do msid <- lift $ getKeyBy $ UniqueSharer shr @@ -1295,12 +1308,16 @@ data ActorEntity getOutboxActorEntity obid = do mp <- getBy $ UniquePersonOutbox obid - mj <- getBy $ UniqueProjectOutbox obid + ma <- getBy $ UniqueActorOutbox obid mr <- getBy $ UniqueRepoOutbox obid - case (mp, mj, mr) of + case (mp, ma, mr) of (Nothing, Nothing, Nothing) -> error "obid not in use" (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 _ -> error "obid used by multiple actors" diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 8f579ba..bb8b62f 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2022 by fr33domlover . - - ♡ 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 Network.FedURI -import Web.ActivityPub hiding (Follow, Ticket, Project, Repo) +import Web.ActivityPub hiding (Follow, Ticket, Project (..), Repo, Actor (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -428,8 +428,8 @@ undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee = msid <- lift $ getKeyBy $ UniqueSharer shrFollowee fromMaybeE msid "No such local sharer" mj <- lift $ getValBy $ UniqueProject prjFollowee sidFollowee - projectFollowers <$> - fromMaybeE mj "Unfollow target no such local project" + j <- fromMaybeE mj "Unfollow target no such local project" + lift $ actorFollowers <$> getJust (projectActor j) undoFollowTicket :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index e9b66ad..5c7bd23 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -197,11 +197,14 @@ handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalProject jid getBy404 $ UniquePersonIdent sid mobi <- lift $ get obiid obi <- fromMaybeE mobi "Local activity: No such ID in DB" - mjidOutbox <- - lift $ getKeyBy $ UniqueProjectOutbox $ outboxItemOutbox obi - jidOutbox <- - fromMaybeE mjidOutbox "Local activity not in a project outbox" - j <- lift $ getJust jidOutbox + maidOutbox <- + lift $ getKeyBy $ UniqueActorOutbox $ outboxItemOutbox obi + aidOutbox <- + fromMaybeE maidOutbox "Local activity not in an actor outbox" + mejOutbox <- + lift $ getBy $ UniqueProjectActor aidOutbox + Entity jidOutbox j <- + fromMaybeE mejOutbox "Local activity not in a project outbox" s <- lift $ getJust $ projectSharer j unless (sharerIdent s == shrActivity) $ throwE "Local activity: ID invalid, hashid and author shr mismatch" diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 51199bd..55c1af7 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -53,7 +53,7 @@ import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub +import Web.ActivityPub hiding (Project (..), Actor (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -434,7 +434,8 @@ projectCreateNoteF now shrRecip prjRecip author body mfwd luCreate note = do getProjectRecip404 = do sid <- getKeyBy404 $ UniqueSharer shrRecip Entity jid j <- getBy404 $ UniqueProject prjRecip sid - return (jid, projectInbox j) + a <- getJust $ projectActor j + return (jid, actorInbox a) repoCreateNoteF :: UTCTime diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 0c16137..2be3b3c 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2022 by fr33domlover . - - ♡ 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 Network.FedURI -import Web.ActivityPub hiding (Ticket (..), Follow) +import Web.ActivityPub hiding (Ticket (..), Follow, Project (..), Actor (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -466,8 +466,8 @@ projectFollowF shr prj = objRoute (ProjectR shr prj) getRecip - (projectInbox . fst) - (projectOutbox . fst) + (actorInbox . fst) + (actorOutbox . fst) followers (ProjectOutboxItemR shr prj) where @@ -480,17 +480,18 @@ projectFollowF shr prj = getRecip mltkhid = do sid <- getKeyBy404 $ UniqueSharer shr j <- getValBy404 $ UniqueProject prj sid + a <- getJust $ projectActor j mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do ltid <- decodeKeyHashidM ltkhid (_, _, _, Entity _ lt, _, _, _, _) <- MaybeT $ getProjectTicket shr prj ltid return lt return $ case mmt of - Nothing -> Just (j, Nothing) + Nothing -> Just (a, 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 repoFollowF @@ -715,10 +716,11 @@ projectUndoF projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do object <- parseActivity uObj mmmhttp <- runDBExcept $ do - Entity jid j <- lift $ do + (Entity jid j, a) <- lift $ do sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniqueProject prjRecip sid - mractid <- lift $ insertToInbox now author body (projectInbox j) luUndo False + ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid + (ej,) <$> getJust (projectActor j) + mractid <- lift $ insertToInbox now author body (actorInbox a) luUndo False for mractid $ \ ractid -> do mobject' <- getActivity object lift $ for mobject' $ \ object' -> do @@ -728,7 +730,7 @@ projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do for mobject'' $ \ object'' -> do (result, mfwdColl, macceptAuds) <- 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 mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do let sieve = makeRecipientSet [] colls @@ -739,14 +741,14 @@ projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do sieve False False localRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do - obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now + obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- insertAcceptOnUndo (LocalActorProject shrRecip prjRecip) author luUndo obiidAccept acceptAuds knownRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) - (projectInbox j) + (actorInbox a) obiidAccept localRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index a0b1825..d5de572 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -78,7 +78,7 @@ import qualified Data.Text.Lazy as TL import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Patch, Ticket (..), Repo (..)) +import Web.ActivityPub hiding (Patch, Ticket (..), Repo (..), Project (..), Actor (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -325,7 +325,8 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge Entity jid j <- do sid <- getKeyBy404 $ UniqueSharer shrRecip 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 mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do let sieve = @@ -341,7 +342,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge sieve False False localRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips (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 (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- insertAccept shrRecip prjRecip author luOffer ltid obiidAccept @@ -349,7 +350,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge deliverLocal' False (LocalActorProject shrRecip prjRecip) - (projectInbox j) + (actorInbox a) obiidAccept localRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> @@ -946,9 +947,10 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa Entity jid j <- do sid <- getKeyBy404 $ UniqueSharer shrRecip 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 - obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now + obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now let makeTPL tclid = TicketProjectLocal tclid jid result <- insertRemoteTicket makeTPL author (AP.ticketId tlocal) published title desc src ractid obiidAccept unless (isRight result) $ delete obiidAccept @@ -972,7 +974,7 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa deliverLocal' False (LocalActorProject shrRecip prjRecip) - (projectInbox j) + (actorInbox a) obiidAccept localRecipsAccept (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> @@ -2191,9 +2193,10 @@ projectOfferDepF -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do (parent, child) <- checkDepAndTarget dep uTarget - Entity jidRecip projectRecip <- lift $ runDB $ do + (Entity jidRecip projectRecip, actorRecip) <- lift $ runDB $ do 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 relevantParent <- 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 return (parentLtid, parentAuthor, childDetail) 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 insertDepOffer ibiid parent child 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 (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips 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 (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- insertAccept luOffer obiidAccept tdid parentLtid parentAuthor childDetail @@ -2231,7 +2234,7 @@ projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do deliverLocal' False (LocalActorProject shrRecip prjRecip) - (projectInbox projectRecip) + (actorInbox actorRecip) obiidAccept localRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept @@ -2679,9 +2682,10 @@ projectResolveF projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObject) = do object <- parseWorkItem "Resolve object" uObject mmmmhttp <- runDBExcept $ do - Entity jidRecip projectRecip <- lift $ do + (Entity jidRecip projectRecip, actorRecip) <- lift $ do sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniqueProject prjRecip sid + ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid + (ej,) <$> getJust (projectActor j) mltid <- case relevantObject object of Nothing -> do @@ -2690,7 +2694,7 @@ projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObjec Right _ -> return () return Nothing 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 mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do ltkhid <- encodeKeyHashid ltid @@ -2707,7 +2711,7 @@ projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObjec localRecipSieve' sieve False False localRecips (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 case mmtrrid of Just (Just _) -> update tid [TicketStatus =. TSClosed] @@ -2719,7 +2723,7 @@ projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObjec deliverLocal' False (LocalActorProject shrRecip prjRecip) - (projectInbox projectRecip) + (actorInbox actorRecip) obiidAccept localRecipsAccept (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index 3ab7264..74ccf92 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -113,7 +113,8 @@ newProjectCollabForm sid jid = renderDivs $ newProjectCollabAForm sid jid editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project editProjectAForm sid (Entity jid project) = Project - <$> pure (projectIdent project) + <$> pure (projectActor project) + <*> pure (projectIdent project) <*> pure (projectSharer project) <*> aopt textField "Name" (Just $ projectName project) <*> aopt textField "Description" (Just $ projectDesc project) @@ -122,9 +123,6 @@ editProjectAForm sid (Entity jid project) = Project <*> aopt selectWiki "Wiki" (Just $ projectWiki project) <*> aopt selectRole "User role" (Just $ projectCollabUser project) <*> aopt selectRole "Guest role" (Just $ projectCollabAnon project) - <*> pure (projectInbox project) - <*> pure (projectOutbox project) - <*> pure (projectFollowers project) where selectWiki = selectField $ diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 12fee61..02d2cf3 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2022 by fr33domlover . - - ♡ 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 Network.FedURI -import Web.ActivityPub +import Web.ActivityPub hiding (Project (..), Actor (..)) import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI @@ -257,7 +257,8 @@ getProjectInboxR shr prj = getInbox here getInboxId getInboxId = do sid <- getKeyBy404 $ UniqueSharer shr j <- getValBy404 $ UniqueProject prj sid - return $ projectInbox j + a <- getJust $ projectActor j + return $ actorInbox a getRepoInboxR :: ShrIdent -> RpIdent -> Handler TypedContent getRepoInboxR shr rp = getInbox here getInboxId @@ -430,7 +431,8 @@ getProjectOutboxR shr prj = getOutbox here getObid getObid = do sid <- getKeyBy404 $ UniqueSharer shr j <- getValBy404 $ UniqueProject prj sid - return $ projectOutbox j + a <- getJust $ projectActor j + return $ actorOutbox a getProjectOutboxItemR :: ShrIdent -> PrjIdent -> KeyHashid OutboxItem -> Handler TypedContent @@ -440,7 +442,8 @@ getProjectOutboxItemR shr prj obikhid = getOutboxItem here getObid obikhid getObid = do sid <- getKeyBy404 $ UniqueSharer shr j <- getValBy404 $ UniqueProject prj sid - return $ projectOutbox j + a <- getJust $ projectActor j + return $ actorOutbox a getRepoOutboxR :: ShrIdent -> RpIdent -> Handler TypedContent getRepoOutboxR shr rp = getOutbox here getObid diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 2aefb56..a0b7d03 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019 by fr33domlover . + - Written in 2016, 2018, 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -42,7 +42,7 @@ import Yesod.Hashids import Vervis.ActorKey import Vervis.Foundation -import Vervis.Model +import Vervis.Model hiding (Actor (..)) import Vervis.Model.Ident import Vervis.Secure import Vervis.Settings diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 2517aae..a0c244b 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -51,7 +51,7 @@ import qualified Database.Esqueleto as E import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Project (..), Repo (..)) +import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.MonadSite @@ -97,8 +97,17 @@ postProjectsR shr = do ibid <- insert Inbox obid <- insert Outbox 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 - { projectIdent = npIdent np + { projectActor = aid + , projectIdent = npIdent np , projectSharer = sid , projectName = npName np , projectDesc = npDesc np @@ -107,9 +116,6 @@ postProjectsR shr = do , projectWiki = Nothing , projectCollabAnon = Nothing , projectCollabUser = Nothing - , projectInbox = ibid - , projectOutbox = obid - , projectFollowers = fsid } jid <- insert project @@ -141,7 +147,7 @@ getProjectNewR shr = do getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent getProjectR shar proj = do - (project, workflow, wsharer, repos) <- runDB $ do + (actor, project, workflow, wsharer, repos) <- runDB $ do Entity sid s <- getBy404 $ UniqueSharer shar Entity pid p <- getBy404 $ UniqueProject proj sid w <- get404 $ projectWorkflow p @@ -150,29 +156,30 @@ getProjectR shar proj = do then return s else get404 $ workflowSharer w rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] - return (p, w, sw, rs) + a <- getJust $ projectActor p + return (a, 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 = + { AP.projectActor = AP.Actor + { AP.actorId = route2local $ ProjectR shar proj + , AP.actorType = ActorTypeProject + , AP.actorUsername = Nothing + , AP.actorName = Just $ fromMaybe (prj2text proj) $ projectName project - , actorSummary = projectDesc project - , actorInbox = route2local $ ProjectInboxR shar proj - , actorOutbox = + , AP.actorSummary = projectDesc project + , AP.actorInbox = route2local $ ProjectInboxR shar proj + , AP.actorOutbox = Just $ route2local $ ProjectOutboxR shar proj - , actorFollowers = + , AP.actorFollowers = Just $ route2local $ ProjectFollowersR shar proj - , actorFollowing = Nothing - , actorPublicKeys = + , AP.actorFollowing = Nothing + , AP.actorPublicKeys = [ Left $ route2local ActorKey1R , Left $ route2local ActorKey2R ] - , actorSshKeys = [] + , AP.actorSshKeys = [] } , AP.projectTeam = route2local $ ProjectTeamR shar proj } @@ -180,7 +187,7 @@ getProjectR shar proj = do followW (ProjectFollowR shar proj) (ProjectUnfollowR shar proj) - (return $ projectFollowers project) + (return $ actorFollowers actor) provideHtmlAndAP projectAP $(widgetFile "project/one") putProjectR :: ShrIdent -> PrjIdent -> Handler Html @@ -240,7 +247,8 @@ postProjectDevsR shr rp = do (sid, jid, obid) <- runDB $ do Entity sid _ <- getBy404 $ UniqueSharer shr 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 case result of FormSuccess nc -> do @@ -390,4 +398,5 @@ getProjectFollowersR shr prj = getFollowersCollection here getFsid getFsid = do sid <- getKeyBy404 $ UniqueSharer shr j <- getValBy404 $ UniqueProject prj sid - return $ projectFollowers j + a <- getJust $ projectActor j + return $ actorFollowers a diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 126bc60..390e838 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -117,7 +117,7 @@ import Vervis.Foundation import Vervis.Handler.Repo.Darcs import Vervis.Handler.Repo.Git import Vervis.Path -import Vervis.Model +import Vervis.Model hiding (Actor (..)) import Vervis.Model.Ident import Development.PatchMediaType import Vervis.Paginate diff --git a/src/Vervis/Handler/Sharer.hs b/src/Vervis/Handler/Sharer.hs index d380e2d..ac636cf 100644 --- a/src/Vervis/Handler/Sharer.hs +++ b/src/Vervis/Handler/Sharer.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2020 by fr33domlover . + - Written in 2016, 2019, 2020, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -137,13 +137,13 @@ getSharerFollowingR shr = do selectList [PersonFollowers <-. fsids] [] map (SharerR . sharerIdent . entityVal) <$> selectList [SharerId <-. sids] [] - getProjects fsids = do - jids <- selectKeysList [ProjectFollowers <-. fsids] [] - pairs <- E.select $ E.from $ \ (j `E.InnerJoin` s) -> do + getProjects fsids = + fmap (map $ \ (E.Value shr, E.Value prj) -> ProjectR shr prj) $ + E.select $ E.from $ \ (a `E.InnerJoin` j `E.InnerJoin` s) -> do 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 $ map (\ (E.Value shr, E.Value prj) -> ProjectR shr prj) pairs getTickets fsids = do ltids <- selectKeysList [LocalTicketFollowers <-. fsids] [] triples <- diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index aaa7e88..2778e9a 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1829,6 +1829,50 @@ changes hLocal ctx = , removeEntity "RepoCollab" -- 287 , 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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index cf77838..e2dd322 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -259,6 +259,13 @@ module Vervis.Migration.Model , Repo285Generic (..) , RepoCollab285 , RepoCollab285Generic (..) + , model_2022_07_17 + , Project289 + , Inbox289Generic (..) + , Outbox289Generic (..) + , FollowerSet289Generic (..) + , Actor289Generic (..) + , Project289Generic (..) ) where @@ -501,3 +508,9 @@ model_2022_06_14 = $(schema "2022_06_14_collab") makeEntitiesMigration "285" $(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") diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index 36ff9d2..6114d6d 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/src/Vervis/RemoteActorStore.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -65,7 +65,7 @@ import Web.ActivityPub import Yesod.MonadSite import Vervis.FedURI -import Vervis.Model +import Vervis.Model hiding (Actor (..)) newtype InstanceMutex = InstanceMutex (TVar (HashMap Host (MVar ())))