From 2e72684fd593b76701820bfde5b52490ac9d6b28 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 15 Aug 2022 13:57:42 +0000 Subject: [PATCH] Switch to new actor layout This is such a huge patch, it's probably impossible to tell what it does by looking at the code. One thing is clear: It changes *everything* :P so here's an overview: - There are now 5 types of actors, each having its own top-level route - So projects, repos, etc. are no longer "under" sharers - Actor routes are now based on their KeyHashid, there are no "idents" anymore, i.e. URLs look random and don't contain user or repo names - No sharers anymore; people and groups are distinct entities not sharing a common namespace or anything like that - Project has been renamed to Deck and it simply means a ticket tracker; repos are no longer "under" projects - In addition to Person, Group, Repo and Deck, there's a new actor type Loom, which is a patch tracker; i.e. Repo actors don't manage MRs anymore - All C2S and S2S is temporarily disabled, because huge changes to the whole code are required and I'll do them gradually in the next patches - Since form-based actions are implemented using C2S, they're disabled as well, so Vervis is now essentially read-only - Some views have been temporarily removed, e.g. repo history and commit view - A huge set of DB migrations has been added to adapt the DB to these changes; I haven't tested them yet on a read DB so there may be errors there; I'll fix them in the next patches if I find any (probably going to test on the main instance where Vervis itself is hosted...) - Some modules got tech upgrades, e.g. LocalActor became a higher-kinded type and a similar pattern is probably relevant for several other types - There's an 'Actor' entity in the DB schema now, and all 5 actor types use it for common things like inbox and outbox - Although inbox and outbox are used only by Actor, so essentially could be removed, I haven't removed them; that's because I wonder if at some point users can have a tree of inboxes much like in email; I don't have an excuse for Outbox, but anyway, leaving them as is for now - Workflows, roles and collaborators are partially removed/unused until I figure out a sane federated way to provide these features - Since repo routes don't contain a "sharer" anymore, SSH URIs are now simpler, they already look like user@host/repo regardless of who "controls" that repo --- migrations/303_2022-08-04_username.model | 33 + migrations/308_2022-08-04_remove_tcr.model | 130 ++ .../310_2022-08-04_move_ticket_discuss.model | 23 + ...312_2022-08-04_move_ticket_followers.model | 26 + .../316_2022-08-04_move_ticket_accept.model | 32 + migrations/318_2022-08-04_tal_ticket.model | 46 + migrations/323_2022-08-04_tar_ticket.model | 46 + migrations/328_2022-08-04_tjl_ticket.model | 43 + migrations/332_2022-08-04_trl_ticket.model | 44 + migrations/338_2022-08-04_rtd_child.model | 48 + migrations/342_2022-08-04_ltd_parent.model | 45 + migrations/345_2022-08-04_tdcl_child.model | 45 + migrations/348_2022-08-04_tr_ticket.model | 45 + migrations/356_2022-08-04_person_actor.model | 41 + migrations/365_2022-08-04_group_actor.model | 30 + migrations/367_2022-08-04_repo_actor.model | 40 + migrations/384_2022-08-04_loom.model | 9 + migrations/386_2022-08-04_assignee.model | 5 + migrations/388_2022-08-04_ticket_loom.model | 129 ++ migrations/396_2022-08-04_repo_dir.model | 36 + migrations/399_2022-08-04_fwder.model | 17 + migrations/408_2022-08-04_collab_loom.model | 5 + migrations/409_2022-08-05_repo_create.model | 52 + .../414_2022-08-05_followremote_actor.model | 52 + migrations/418_2022-08-06_follow_actor.model | 49 + src/Darcs/Local/Repository.hs | 22 +- src/Data/Git/Local.hs | 28 +- src/Database/Persist/Local.hs | 17 +- src/Vervis/API.hs | 1599 +++++------------ src/Vervis/Access.hs | 78 +- src/Vervis/ActivityPub.hs | 1134 +----------- src/Vervis/ActivityPub/Recipient.hs | 654 ------- src/Vervis/Actor.hs | 399 ++++ src/Vervis/Application.hs | 84 +- src/Vervis/ChangeFeed.hs | 31 +- src/Vervis/Client.hs | 180 +- src/Vervis/Cloth.hs | 133 ++ src/Vervis/Darcs.hs | 37 +- src/Vervis/Delivery.hs | 807 +++++++++ src/Vervis/Discussion.hs | 113 +- src/Vervis/Federation.hs | 336 ++-- src/Vervis/Federation/Auth.hs | 76 +- src/Vervis/Federation/Discussion.hs | 37 +- src/Vervis/Federation/Offer.hs | 98 +- src/Vervis/Federation/Push.hs | 11 +- src/Vervis/Federation/Ticket.hs | 1004 ++--------- src/Vervis/Foundation.hs | 174 +- src/Vervis/Git.hs | 27 +- src/Vervis/Handler/Client.hs | 555 +++--- src/Vervis/Handler/{Patch.hs => Cloth.hs} | 553 ++++-- src/Vervis/Handler/{Project.hs => Deck.hs} | 364 ++-- src/Vervis/Handler/Discussion.hs | 91 +- src/Vervis/Handler/Git.hs | 72 +- src/Vervis/Handler/Group.hs | 111 +- src/Vervis/Handler/Home.hs | 70 - src/Vervis/Handler/Inbox.hs | 247 +-- src/Vervis/Handler/Key.hs | 30 +- src/Vervis/Handler/Loom.hs | 200 +++ src/Vervis/Handler/Person.hs | 357 ++-- src/Vervis/Handler/Repo.hs | 736 +++++--- src/Vervis/Handler/Repo/Darcs.hs | 16 - src/Vervis/Handler/Repo/Git.hs | 5 - src/Vervis/Handler/Sharer.hs | 98 - src/Vervis/Handler/Ticket.hs | 644 +++---- src/Vervis/Hook.hs | 25 +- src/Vervis/Migration.hs | 1059 +++++++---- src/Vervis/Migration/Model.hs | 89 +- src/Vervis/Model/Ident.hs | 18 +- src/Vervis/Patch.hs | 232 --- src/Vervis/Path.hs | 27 +- src/Vervis/Recipient.hs | 905 ++++++++++ src/Vervis/Ssh.hs | 114 +- src/Vervis/Ticket.hs | 493 ++--- src/Vervis/Widget/Discussion.hs | 9 +- src/Vervis/Widget/{Sharer.hs => Person.hs} | 49 +- src/Vervis/Widget/Repo.hs | 11 +- src/Vervis/WorkItem.hs | 48 +- src/Web/ActivityPub.hs | 24 +- src/Yesod/Hashids.hs | 17 +- templates/{homepage.hamlet => browse.hamlet} | 84 +- templates/default-layout.hamlet | 14 +- templates/discussion/widget/message.hamlet | 6 +- templates/person.hamlet | 6 +- templates/person/notifications.hamlet | 6 +- templates/person/widget/nav.hamlet | 23 +- templates/personal-overview.hamlet | 31 +- templates/project/one.hamlet | 15 +- templates/repo/patch.hamlet | 2 +- templates/repo/widget/changes.hamlet | 8 +- templates/repo/widget/ref-select.hamlet | 6 +- templates/widget/actor-link.hamlet | 11 +- th/models | 401 +++-- th/routes | 373 ++-- vervis.cabal | 90 +- 94 files changed, 8767 insertions(+), 7728 deletions(-) create mode 100644 migrations/303_2022-08-04_username.model create mode 100644 migrations/308_2022-08-04_remove_tcr.model create mode 100644 migrations/310_2022-08-04_move_ticket_discuss.model create mode 100644 migrations/312_2022-08-04_move_ticket_followers.model create mode 100644 migrations/316_2022-08-04_move_ticket_accept.model create mode 100644 migrations/318_2022-08-04_tal_ticket.model create mode 100644 migrations/323_2022-08-04_tar_ticket.model create mode 100644 migrations/328_2022-08-04_tjl_ticket.model create mode 100644 migrations/332_2022-08-04_trl_ticket.model create mode 100644 migrations/338_2022-08-04_rtd_child.model create mode 100644 migrations/342_2022-08-04_ltd_parent.model create mode 100644 migrations/345_2022-08-04_tdcl_child.model create mode 100644 migrations/348_2022-08-04_tr_ticket.model create mode 100644 migrations/356_2022-08-04_person_actor.model create mode 100644 migrations/365_2022-08-04_group_actor.model create mode 100644 migrations/367_2022-08-04_repo_actor.model create mode 100644 migrations/384_2022-08-04_loom.model create mode 100644 migrations/386_2022-08-04_assignee.model create mode 100644 migrations/388_2022-08-04_ticket_loom.model create mode 100644 migrations/396_2022-08-04_repo_dir.model create mode 100644 migrations/399_2022-08-04_fwder.model create mode 100644 migrations/408_2022-08-04_collab_loom.model create mode 100644 migrations/409_2022-08-05_repo_create.model create mode 100644 migrations/414_2022-08-05_followremote_actor.model create mode 100644 migrations/418_2022-08-06_follow_actor.model delete mode 100644 src/Vervis/ActivityPub/Recipient.hs create mode 100644 src/Vervis/Actor.hs create mode 100644 src/Vervis/Cloth.hs create mode 100644 src/Vervis/Delivery.hs rename src/Vervis/Handler/{Patch.hs => Cloth.hs} (65%) rename src/Vervis/Handler/{Project.hs => Deck.hs} (62%) delete mode 100644 src/Vervis/Handler/Home.hs create mode 100644 src/Vervis/Handler/Loom.hs delete mode 100644 src/Vervis/Patch.hs create mode 100644 src/Vervis/Recipient.hs rename src/Vervis/Widget/{Sharer.hs => Person.hs} (55%) rename templates/{homepage.hamlet => browse.hamlet} (67%) diff --git a/migrations/303_2022-08-04_username.model b/migrations/303_2022-08-04_username.model new file mode 100644 index 0000000..1bb2fad --- /dev/null +++ b/migrations/303_2022-08-04_username.model @@ -0,0 +1,33 @@ +Inbox +Outbox +FollowerSet + +Sharer + ident Text + name Text Maybe + created UTCTime + + UniqueSharer ident + +Person + ident SharerId + username Text + login Text + passphraseHash ByteString + email EmailAddress + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + about Text + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniquePersonIdent ident + UniquePersonLogin login + UniquePersonEmail email + UniquePersonInbox inbox + UniquePersonOutbox outbox + UniquePersonFollowers followers diff --git a/migrations/308_2022-08-04_remove_tcr.model b/migrations/308_2022-08-04_remove_tcr.model new file mode 100644 index 0000000..4e4b89d --- /dev/null +++ b/migrations/308_2022-08-04_remove_tcr.model @@ -0,0 +1,130 @@ +Ticket +FollowerSet +RemoteActor +RemoteObject +Person +OutboxItem +RemoteActivity +Project +Repo + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers + +TicketProjectRemote + ticket TicketAuthorLocalId + tracker RemoteActorId + project RemoteObjectId Maybe -- specify if not same as tracker + -- For MRs it may be either a remote repo or + -- a branch of it + + UniqueTicketProjectRemote ticket + +TicketAuthorLocal + ticket LocalTicketId + author PersonId + open OutboxItemId + + UniqueTicketAuthorLocal ticket + UniqueTicketAuthorLocalOpen open + +Message + created UTCTime + source Text -- Pandoc Markdown + content Text -- HTML + parent MessageId Maybe + root DiscussionId + +LocalMessage + author PersonId + rest MessageId + create OutboxItemId + unlinkedParent FedURI Maybe + + UniqueLocalMessage rest + UniqueLocalMessageCreate create + +RemoteMessage + author RemoteActorId + ident RemoteObjectId + rest MessageId + create RemoteActivityId + lostParent FedURI Maybe + + UniqueRemoteMessageIdent ident + UniqueRemoteMessage rest + UniqueRemoteMessageCreate create + +Follow + person PersonId + target FollowerSetId + public Bool + follow OutboxItemId + accept OutboxItemId + + UniqueFollow person target + UniqueFollowFollow follow + UniqueFollowAccept accept + +RemoteFollow + actor RemoteActorId + target FollowerSetId + public Bool + follow RemoteActivityId + accept OutboxItemId + + UniqueRemoteFollow actor target + UniqueRemoteFollowFollow follow + UniqueRemoteFollowAccept accept + +RemoteTicket + ticket TicketAuthorRemoteId + ident RemoteObjectId + discuss RemoteDiscussionId + + UniqueRemoteTicket ticket + UniqueRemoteTicketIdent ident + UniqueRemoteTicketDiscuss discuss + +Discussion + +RemoteDiscussion + ident RemoteObjectId + discuss DiscussionId + + UniqueRemoteDiscussionIdent ident + UniqueRemoteDiscussion discuss + +TicketAuthorRemote + ticket TicketContextLocalId + author RemoteActorId + open RemoteActivityId + + UniqueTicketAuthorRemote ticket + UniqueTicketAuthorRemoteOpen open + +TicketContextLocal + ticket TicketId + accept OutboxItemId + + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept + +TicketProjectLocal + context TicketContextLocalId + project ProjectId + + UniqueTicketProjectLocal context + +TicketRepoLocal + context TicketContextLocalId + repo RepoId + branch Text Maybe + + UniqueTicketRepoLocal context diff --git a/migrations/310_2022-08-04_move_ticket_discuss.model b/migrations/310_2022-08-04_move_ticket_discuss.model new file mode 100644 index 0000000..fbd6d50 --- /dev/null +++ b/migrations/310_2022-08-04_move_ticket_discuss.model @@ -0,0 +1,23 @@ +Person +FollowerSet + +Discussion + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers diff --git a/migrations/312_2022-08-04_move_ticket_followers.model b/migrations/312_2022-08-04_move_ticket_followers.model new file mode 100644 index 0000000..d52a5a1 --- /dev/null +++ b/migrations/312_2022-08-04_move_ticket_followers.model @@ -0,0 +1,26 @@ +Person +Discussion + +FollowerSet + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + + UniqueTicketDiscuss discuss + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers diff --git a/migrations/316_2022-08-04_move_ticket_accept.model b/migrations/316_2022-08-04_move_ticket_accept.model new file mode 100644 index 0000000..5587adb --- /dev/null +++ b/migrations/316_2022-08-04_move_ticket_accept.model @@ -0,0 +1,32 @@ +Person +Discussion +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +TicketContextLocal + ticket TicketId + accept OutboxItemId + + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers diff --git a/migrations/318_2022-08-04_tal_ticket.model b/migrations/318_2022-08-04_tal_ticket.model new file mode 100644 index 0000000..5449a28 --- /dev/null +++ b/migrations/318_2022-08-04_tal_ticket.model @@ -0,0 +1,46 @@ +Person + +Discussion + +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +TicketAuthorLocal + ticket LocalTicketId + ticketNew TicketId + author PersonId + open OutboxItemId + + UniqueTicketAuthorLocal ticket + UniqueTicketAuthorLocalOpen open + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers diff --git a/migrations/323_2022-08-04_tar_ticket.model b/migrations/323_2022-08-04_tar_ticket.model new file mode 100644 index 0000000..8e4140f --- /dev/null +++ b/migrations/323_2022-08-04_tar_ticket.model @@ -0,0 +1,46 @@ +Person +RemoteActor +RemoteActivity + +Discussion + +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +TicketAuthorRemote + ticket TicketContextLocalId + ticketNew TicketId + author RemoteActorId + open RemoteActivityId + + UniqueTicketAuthorRemote ticket + UniqueTicketAuthorRemoteOpen open + +TicketContextLocal + ticket TicketId + accept OutboxItemId + + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept diff --git a/migrations/328_2022-08-04_tjl_ticket.model b/migrations/328_2022-08-04_tjl_ticket.model new file mode 100644 index 0000000..c2c112f --- /dev/null +++ b/migrations/328_2022-08-04_tjl_ticket.model @@ -0,0 +1,43 @@ +Person +Project + +Discussion + +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +TicketProjectLocal + ticket TicketId + context TicketContextLocalId + project ProjectId + + UniqueTicketProjectLocal context + +TicketContextLocal + ticket TicketId + accept OutboxItemId + + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept diff --git a/migrations/332_2022-08-04_trl_ticket.model b/migrations/332_2022-08-04_trl_ticket.model new file mode 100644 index 0000000..2603c04 --- /dev/null +++ b/migrations/332_2022-08-04_trl_ticket.model @@ -0,0 +1,44 @@ +Person +Repo + +Discussion + +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +TicketRepoLocal + ticket TicketId + context TicketContextLocalId + repo RepoId + branch Text Maybe + + UniqueTicketRepoLocal context + +TicketContextLocal + ticket TicketId + accept OutboxItemId + + UniqueTicketContextLocal ticket + UniqueTicketContextLocalAccept accept diff --git a/migrations/338_2022-08-04_rtd_child.model b/migrations/338_2022-08-04_rtd_child.model new file mode 100644 index 0000000..d83df24 --- /dev/null +++ b/migrations/338_2022-08-04_rtd_child.model @@ -0,0 +1,48 @@ +Person +RemoteObject +RemoteActivity + +Discussion + +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +RemoteTicketDependency + ident RemoteObjectId + child LocalTicketId + childNew TicketId + accept RemoteActivityId + + UniqueRemoteTicketDependency ident + UniqueRemoteTicketDependencyAccept accept + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers diff --git a/migrations/342_2022-08-04_ltd_parent.model b/migrations/342_2022-08-04_ltd_parent.model new file mode 100644 index 0000000..51fdc31 --- /dev/null +++ b/migrations/342_2022-08-04_ltd_parent.model @@ -0,0 +1,45 @@ +Person + +Discussion + +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +LocalTicketDependency + parent LocalTicketId + parentNew TicketId + created UTCTime + accept OutboxItemId + + UniqueLocalTicketDependencyAccept accept + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers diff --git a/migrations/345_2022-08-04_tdcl_child.model b/migrations/345_2022-08-04_tdcl_child.model new file mode 100644 index 0000000..2fee639 --- /dev/null +++ b/migrations/345_2022-08-04_tdcl_child.model @@ -0,0 +1,45 @@ +Person +LocalTicketDependency + +Discussion + +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +TicketDependencyChildLocal + dep LocalTicketDependencyId + child LocalTicketId + childNew TicketId + + UniqueTicketDependencyChildLocal dep + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers diff --git a/migrations/348_2022-08-04_tr_ticket.model b/migrations/348_2022-08-04_tr_ticket.model new file mode 100644 index 0000000..46e601b --- /dev/null +++ b/migrations/348_2022-08-04_tr_ticket.model @@ -0,0 +1,45 @@ +Person + +Discussion + +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + assignee PersonId Maybe + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +TicketResolve + ticket LocalTicketId + ticketNew TicketId + accept OutboxItemId + + UniqueTicketResolve ticket + UniqueTicketResolveAccept accept + +LocalTicket + ticket TicketId + discuss DiscussionId + followers FollowerSetId + + UniqueLocalTicket ticket + UniqueLocalTicketDiscussion discuss + UniqueLocalTicketFollowers followers diff --git a/migrations/356_2022-08-04_person_actor.model b/migrations/356_2022-08-04_person_actor.model new file mode 100644 index 0000000..2766706 --- /dev/null +++ b/migrations/356_2022-08-04_person_actor.model @@ -0,0 +1,41 @@ +Outbox + +Inbox + +FollowerSet + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +Person + username Username + login Text + passphraseHash ByteString + email EmailAddress + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + about Text + actor ActorId + inbox InboxId + outbox OutboxId + followers FollowerSetId +-- reviewFollow Bool + + UniquePersonUsername username + UniquePersonLogin login + UniquePersonEmail email + UniquePersonInbox inbox + UniquePersonOutbox outbox + UniquePersonFollowers followers diff --git a/migrations/365_2022-08-04_group_actor.model b/migrations/365_2022-08-04_group_actor.model new file mode 100644 index 0000000..f64cc30 --- /dev/null +++ b/migrations/365_2022-08-04_group_actor.model @@ -0,0 +1,30 @@ +Inbox + +Outbox + +FollowerSet + +Group + ident SharerId + actor ActorId + + UniqueGroup ident + +Sharer + ident ShrIdent + name Text Maybe + created UTCTime + + UniqueSharer ident + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers diff --git a/migrations/367_2022-08-04_repo_actor.model b/migrations/367_2022-08-04_repo_actor.model new file mode 100644 index 0000000..590ac87 --- /dev/null +++ b/migrations/367_2022-08-04_repo_actor.model @@ -0,0 +1,40 @@ +Deck +Role +Sharer + +Inbox + +Outbox + +FollowerSet + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +Repo + vcs VersionControlSystem + project DeckId Maybe + mainBranch Text + collabUser RoleId Maybe + collabAnon RoleId Maybe + actor ActorId + desc Text Maybe + ident RpIdent + inbox InboxId + outbox OutboxId + followers FollowerSetId + sharer SharerId + + UniqueRepo ident sharer + UniqueRepoInbox inbox + UniqueRepoOutbox outbox + UniqueRepoFollowers followers diff --git a/migrations/384_2022-08-04_loom.model b/migrations/384_2022-08-04_loom.model new file mode 100644 index 0000000..8e63e5c --- /dev/null +++ b/migrations/384_2022-08-04_loom.model @@ -0,0 +1,9 @@ +Loom + nextTicket Int + actor ActorId + repo RepoId + create OutboxItemId + + UniqueLoomActor actor + UniqueLoomRepo repo + UniqueLoomCreate create diff --git a/migrations/386_2022-08-04_assignee.model b/migrations/386_2022-08-04_assignee.model new file mode 100644 index 0000000..a2f2d18 --- /dev/null +++ b/migrations/386_2022-08-04_assignee.model @@ -0,0 +1,5 @@ +TicketAssignee + ticket TicketId + person PersonId + + UniqueTicketAssignee ticket person diff --git a/migrations/388_2022-08-04_ticket_loom.model b/migrations/388_2022-08-04_ticket_loom.model new file mode 100644 index 0000000..d0b9bda --- /dev/null +++ b/migrations/388_2022-08-04_ticket_loom.model @@ -0,0 +1,129 @@ +Repo +OutboxItem +Person +RemoteActor +RemoteObject +RemoteActivity + +TicketRepoLocal + ticket TicketId + repo RepoId + branch Text Maybe + + UniqueTicketRepoLocal ticket + +Ticket + number Int Maybe + created UTCTime + title Text -- HTML + source Text -- Pandoc Markdown + description Text -- HTML + status TicketStatus + discuss DiscussionId + followers FollowerSetId + accept OutboxItemId + + -- UniqueTicket project number + UniqueTicketDiscuss discuss + UniqueTicketFollowers followers + UniqueTicketAccept accept + +Message + created UTCTime + source Text -- Pandoc Markdown + content Text -- HTML + parent MessageId Maybe + root DiscussionId + +LocalMessage + author PersonId + rest MessageId + create OutboxItemId + unlinkedParent FedURI Maybe + + UniqueLocalMessage rest + UniqueLocalMessageCreate create + +RemoteMessage + author RemoteActorId + ident RemoteObjectId + rest MessageId + create RemoteActivityId + lostParent FedURI Maybe + + UniqueRemoteMessageIdent ident + UniqueRemoteMessage rest + UniqueRemoteMessageCreate create + +Bundle + ticket TicketId + +Patch + bundle BundleId + created UTCTime + type PatchMediaType + content Text + +TicketResolve + ticket TicketId + accept OutboxItemId + + UniqueTicketResolve ticket + UniqueTicketResolveAccept accept + +TicketResolveLocal + ticket TicketResolveId + activity OutboxItemId + + UniqueTicketResolveLocal ticket + UniqueTicketResolveLocalActivity activity + +TicketResolveRemote + ticket TicketResolveId + activity RemoteActivityId + actor RemoteActorId + + UniqueTicketResolveRemote ticket + UniqueTicketResolveRemoteActivity activity + +Discussion + +FollowerSet + +Follow + person PersonId + target FollowerSetId + public Bool + follow OutboxItemId + accept OutboxItemId + + UniqueFollow person target + UniqueFollowFollow follow + UniqueFollowAccept accept + +RemoteFollow + actor RemoteActorId + target FollowerSetId + public Bool + follow RemoteActivityId + accept OutboxItemId + + UniqueRemoteFollow actor target + UniqueRemoteFollowFollow follow + UniqueRemoteFollowAccept accept + +TicketAuthorLocal + ticket TicketId + author PersonId + open OutboxItemId + + UniqueTicketAuthorLocal ticket + UniqueTicketAuthorLocalOpen open + +TicketAuthorRemote + ticket TicketId + author RemoteActorId + open RemoteActivityId + + UniqueTicketAuthorRemote ticket + UniqueTicketAuthorRemoteOpen open diff --git a/migrations/396_2022-08-04_repo_dir.model b/migrations/396_2022-08-04_repo_dir.model new file mode 100644 index 0000000..9f56cf2 --- /dev/null +++ b/migrations/396_2022-08-04_repo_dir.model @@ -0,0 +1,36 @@ +Deck +Role +OutboxItem +Outbox +Inbox +FollowerSet + +Repo + vcs VersionControlSystem + project DeckId Maybe + mainBranch Text + collabUser RoleId Maybe + collabAnon RoleId Maybe + actor ActorId + sharer SharerId + + UniqueRepoActor actor + +Sharer + ident ShrIdent + name Text Maybe + created UTCTime + + UniqueSharer ident + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers diff --git a/migrations/399_2022-08-04_fwder.model b/migrations/399_2022-08-04_fwder.model new file mode 100644 index 0000000..d362947 --- /dev/null +++ b/migrations/399_2022-08-04_fwder.model @@ -0,0 +1,17 @@ +ForwarderPerson + task ForwardingId + sender PersonId + + UniqueForwarderPerson task + +ForwarderGroup + task ForwardingId + sender GroupId + + UniqueForwarderGroup task + +ForwarderLoom + task ForwardingId + sender LoomId + + UniqueForwarderLoom task diff --git a/migrations/408_2022-08-04_collab_loom.model b/migrations/408_2022-08-04_collab_loom.model new file mode 100644 index 0000000..a90a8d8 --- /dev/null +++ b/migrations/408_2022-08-04_collab_loom.model @@ -0,0 +1,5 @@ +CollabTopicLocalLoom + collab CollabId + loom LoomId + + UniqueCollabTopicLocalLoom collab diff --git a/migrations/409_2022-08-05_repo_create.model b/migrations/409_2022-08-05_repo_create.model new file mode 100644 index 0000000..6c58f7e --- /dev/null +++ b/migrations/409_2022-08-05_repo_create.model @@ -0,0 +1,52 @@ +Deck +Role +Inbox +FollowerSet + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Repo + vcs VersionControlSystem + project DeckId Maybe + mainBranch Text + collabUser RoleId Maybe + collabAnon RoleId Maybe + actor ActorId + create OutboxItemId + + UniqueRepoActor actor + +Person + username Username + login Text + passphraseHash ByteString + email EmailAddress + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + actor ActorId +-- reviewFollow Bool + + UniquePersonUsername username + UniquePersonLogin login + UniquePersonEmail email + UniquePersonActor actor diff --git a/migrations/414_2022-08-05_followremote_actor.model b/migrations/414_2022-08-05_followremote_actor.model new file mode 100644 index 0000000..2d7e5a1 --- /dev/null +++ b/migrations/414_2022-08-05_followremote_actor.model @@ -0,0 +1,52 @@ +RemoteActor +OutboxItem +RemoteActivity + +Inbox + +Outbox + +FollowerSet + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +FollowRemote + person PersonId + actor ActorId + recip RemoteActorId -- actor managing the followed object + target FedURI -- the followed object + public Bool + follow OutboxItemId + accept RemoteActivityId + + UniqueFollowRemote person target + UniqueFollowRemoteFollow follow + UniqueFollowRemoteAccept accept + +Person + username Username + login Text + passphraseHash ByteString + email EmailAddress + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + actor ActorId +-- reviewFollow Bool + + UniquePersonUsername username + UniquePersonLogin login + UniquePersonEmail email + UniquePersonActor actor diff --git a/migrations/418_2022-08-06_follow_actor.model b/migrations/418_2022-08-06_follow_actor.model new file mode 100644 index 0000000..1ceb638 --- /dev/null +++ b/migrations/418_2022-08-06_follow_actor.model @@ -0,0 +1,49 @@ +OutboxItem + +Inbox + +Outbox + +FollowerSet + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +Follow + person PersonId + actor ActorId -- TODO CONTINUE write a migration adding this field + target FollowerSetId + public Bool + follow OutboxItemId + accept OutboxItemId + + UniqueFollow person target + UniqueFollowFollow follow + UniqueFollowAccept accept + +Person + username Username + login Text + passphraseHash ByteString + email EmailAddress + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + actor ActorId +-- reviewFollow Bool + + UniquePersonUsername username + UniquePersonLogin login + UniquePersonEmail email + UniquePersonActor actor diff --git a/src/Darcs/Local/Repository.hs b/src/Darcs/Local/Repository.hs index 36e89a8..0e54d61 100644 --- a/src/Darcs/Local/Repository.hs +++ b/src/Darcs/Local/Repository.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2022 by fr33domlover . - - β™‘ Copying is an act of love. Please copy, reuse and share. - @@ -34,17 +34,17 @@ import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.IO as TIO -writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> Text -> IO () -writeDefaultsFile path cmd authority sharer repo = do +writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> IO () +writeDefaultsFile path cmd authority repo = do let file = path "_darcs" "prefs" "defaults" - TIO.writeFile file $ defaultsContent cmd authority sharer repo + TIO.writeFile file $ defaultsContent cmd authority repo setFileMode file $ ownerReadMode .|. ownerWriteMode where - defaultsContent :: FilePath -> Text -> Text -> Text -> Text - defaultsContent hook authority sharer repo = + defaultsContent :: FilePath -> Text -> Text -> Text + defaultsContent hook authority repo = T.concat [ "apply posthook " - , T.pack hook, " ", authority, " ", sharer, " ", repo + , T.pack hook, " ", authority, " ", repo ] {- @@ -80,18 +80,16 @@ createRepo -> Text -- ^ Instance HTTP authority -> Text - -- ^ Repo sharer textual ID - -> Text - -- ^ Repo textual ID + -- ^ Repo key hashid -> IO () -createRepo parent name cmd authority sharer repo = do +createRepo parent name cmd authority repo = do let path = parent name createDirectory path let settings = proc "darcs" ["init", "--no-working-dir", "--repodir", path] (_, _, _, ph) <- createProcess settings ec <- waitForProcess ph case ec of - ExitSuccess -> writeDefaultsFile path cmd authority sharer repo + ExitSuccess -> writeDefaultsFile path cmd authority repo ExitFailure n -> error $ "darcs init failed with exit code " ++ show n readPristineRoot :: FilePath -> IO (Maybe Int, Hash) diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index 0afe4be..f16e22a 100644 --- a/src/Data/Git/Local.hs +++ b/src/Data/Git/Local.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. - @@ -54,21 +54,21 @@ instance SpecToEventTime GitTime where specToEventTime = specToEventTime . gitTimeUTC specsToEventTimes = specsToEventTimes . fmap gitTimeUTC -hookContent :: FilePath -> Text -> Text -> Text -> Text -hookContent hook authority sharer repo = +hookContent :: FilePath -> Text -> Text -> Text +hookContent hook authority repo = T.concat [ "#!/bin/sh\nexec ", T.pack hook - , " ", authority, " ", sharer, " ", repo + , " ", authority, " ", repo ] -writeHookFile :: FilePath -> FilePath -> Text -> Text -> Text -> IO () -writeHookFile path cmd authority sharer repo = do +writeHookFile :: FilePath -> FilePath -> Text -> Text -> IO () +writeHookFile path cmd authority repo = do let file = path "hooks" "post-receive" - TIO.writeFile file $ hookContent cmd authority sharer repo + TIO.writeFile file $ hookContent cmd authority repo setFileMode file ownerModes -initialRepoTree :: FilePath -> Text -> Text -> Text -> FileName -> DirTree Text -initialRepoTree hook authority sharer repo dir = +initialRepoTree :: FilePath -> Text -> Text -> FileName -> DirTree Text +initialRepoTree hook authority repo dir = Dir dir [ Dir "branches" [] , File "config" @@ -80,7 +80,7 @@ initialRepoTree hook authority sharer repo dir = "Unnamed repository; edit this file to name the repository." , File "HEAD" "ref: refs/heads/master" , Dir "hooks" - [ File "post-receive" $ hookContent hook authority sharer repo + [ File "post-receive" $ hookContent hook authority repo ] , Dir "info" [ File "exclude" "" @@ -110,12 +110,10 @@ createRepo -> Text -- ^ Instance HTTP authority -> Text - -- ^ Repo sharer textual ID - -> Text - -- ^ Repo textual ID + -- ^ Repo hashid -> IO () -createRepo path name cmd authority sharer repo = do - let tree = path :/ initialRepoTree cmd authority sharer repo name +createRepo path name cmd authority repo = do + let tree = path :/ initialRepoTree cmd authority repo name result <- writeDirectoryWith TIO.writeFile tree let errs = failures $ dirTree result when (not . null $ errs) $ diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index d44402f..73bce67 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.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. - @@ -21,6 +21,7 @@ module Database.Persist.Local , insertUnique_ , insertBy' , insertByEntity' + , getE ) where @@ -28,6 +29,8 @@ import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Bifunctor @@ -95,3 +98,15 @@ insertByEntity' ) => record -> ReaderT backend m (Either (Entity record) (Entity record)) insertByEntity' val = second (flip Entity val) <$> insertBy' val + +getE + :: ( PersistStoreRead backend + , MonadIO m + , PersistRecordBackend record backend + ) + => Key record -> e -> ExceptT e (ReaderT backend m) record +getE key msg = do + mval <- lift $ get key + case mval of + Nothing -> throwE msg + Just val -> return val diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 5256da5..b7d9d49 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -18,7 +18,6 @@ module Vervis.API , applyC , noteC , createNoteC - , createTicketC , createTicketTrackerC , followC , offerTicketC @@ -26,7 +25,6 @@ module Vervis.API , resolveC , undoC , pushCommitsC - , getFollowersCollection ) where @@ -86,6 +84,7 @@ import Yesod.HttpSignature import Crypto.PublicVerifKey import Database.Persist.JSON +import Development.PatchMediaType import Network.FedURI import Network.HTTP.Digest import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..)) @@ -108,9 +107,11 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub -import Vervis.ActivityPub.Recipient import Vervis.ActorKey +import Vervis.Cloth import Vervis.Darcs +import Vervis.Delivery +import Vervis.Discussion import Vervis.FedURI import Vervis.Foundation import Vervis.Git @@ -118,37 +119,34 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Role import Vervis.Model.Workflow -import Development.PatchMediaType import Vervis.Model.Ticket +import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings -import Vervis.Patch import Vervis.Query import Vervis.Ticket import Vervis.WorkItem addBundleC :: Entity Person - -> Sharer -> Maybe TextHtml -> Audience URIMode -> NonEmpty (AP.Patch URIMode) -> FedURI -> ExceptT Text Handler OutboxItemId -addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarget = do - let shrUser = sharerIdent sharerUser +addBundleC (Entity pidUser personUser) summary audience patches uTarget = do + error "addBundleC temporarily disabled" + + +{- + ticket <- do t <- parseWorkItem "Target" uTarget bitraverse (\ wi -> case wi of - WorkItemSharerTicket shr talid patch -> do - unless patch $ throwE "Target is a non-MR sharer-ticket" - return $ Left (shr, talid) - WorkItemProjectTicket _ _ _ -> - throwE "Target is a project-ticket" - WorkItemRepoProposal shr rp ltid -> - return $ Right (shr, rp, ltid) + WorkItemTicket _ _ -> throwE "Target is a deck ticket" + WorkItemCloth loom cloth -> return (loom, cloth) ) pure t @@ -156,12 +154,13 @@ addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarg ((typ, diff) :| rest) <- for patches $ \ (AP.Patch mlocal attrib mpub typ content) -> do verifyNothingE mlocal "Patch with 'id'" - shrAttrib <- do + attribHash <- do route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route" case route of - SharerR shr -> return shr - _ -> throwE "Patch attrib not a sharer route" - unless (shrAttrib == shrUser) $ + PersonR person -> return person + _ -> throwE "Patch attrib not a person route" + userHash <- encodeKeyHashid pidUser + unless (attribHash == userHash) $ throwE "Add and Patch attrib mismatch" verifyNothingE mpub "Patch has 'published'" return (typ, content) @@ -174,27 +173,24 @@ addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarg federation <- asksSite $ appFederation . appSettings unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients specified" - let ticketWI = first toWorkItem ticket - verifyHosterRecip localRecips "Ticket" ticketWI + verifyHosterRecip localRecips "Ticket" ticket now <- liftIO getCurrentTime - ticketDetail <- runWorkerExcept $ getWorkItemDetail "Ticket" ticketWI + authorHash <- encodeKeyHashid pidUser + (obiidAdd, docAdd, remotesHttpAdd, maybeAccept) <- runDBExcept $ do - (obiid, doc, luAdd) <- lift $ insertAddToOutbox shrUser now (personOutbox personUser) blinded + (obiid, doc, luAdd) <- lift $ insertAddToOutbox now blinded remotesHttpAdd <- do - wiFollowers <- askWorkItemFollowers - let sieve = - let (ticketA, ticketC) = - workItemRecipSieve wiFollowers ticketDetail - in makeRecipientSet - ticketA - (LocalPersonCollectionSharerFollowers shrUser : - ticketC - ) + sieve <- do + (clothA, clothS) <- clothRecipSieve ticket + return $ + makeRecipientSet + clothA + (LocalStagePersonFollowers authorHash : clothS) moreRemoteRecips <- lift $ deliverLocal' True - (LocalActorSharer shrUser) + (LocalActorPerson authorHash) (personInbox personUser) obiid (localRecipSieve sieve False localRecips) @@ -202,42 +198,37 @@ addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarg throwE "Federation disabled, but recipient collection remote members found" lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips maccept <- - case widIdent ticketDetail of + case ticket of Right _ -> return Nothing - Left (wi, ltid) -> Just <$> do - let local = - case ticket of - Left l -> l - Right _ -> error "Impossible wi" - mhoster <- - case local of - Left (shr, _) -> lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - p <- MaybeT (getValBy $ UniquePersonIdent sid) - return (personOutbox p, personInbox p) - Right (shr, rp, _) -> runMaybeT $ do - sid <- MaybeT $ lift $ getKeyBy $ UniqueSharer shr - r <- MaybeT (lift $ getValBy $ UniqueRepo rp sid) - unless (repoVcs r == patchMediaTypeVCS typ) $ - lift $ throwE "Patch type and repo VCS mismatch" - return (repoOutbox r, repoInbox r) - (obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB" - obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now - tid <- lift $ localTicketTicket <$> getJust ltid - bnid <- lift $ insert $ Bundle tid + Left (loomID, clothID) -> Just <$> do + loom <- do + maybeLoom <- lift $ get loomID + fromMaybeE maybeLoom "No such loom" + _ <- do + maybeCloth <- lift $ get clothID + fromMaybeE maybeCloth "No such cloth" + + repo <- lift $ getJust $ loomRepo loom + unless (repoVcs repo == patchMediaTypeVCS typ) $ + lift $ throwE "Patch type and repo VCS mismatch" + actorLoom <- lift $ getJust $ loomActor loom + acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actorLoom) now + + bundleID <- lift $ insert $ Bundle clothID lift $ insertMany_ $ NE.toList $ NE.map (Patch bnid now typ) diffs + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ insertAccept shrUser local ticketDetail obiid obiidAccept bnid + lift $ insertAccept loomID (actorOutbox actorLoom) clothID obiid acceptID bundleID knownRemoteRecipsAccept <- lift $ deliverLocal' False - (workItemActor wi) - ibidHoster - obiidAccept + (LocalActorLoom loomHash) + (actorInbox actorLoom) + acceptID localRecipsAccept - lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + lift $ (acceptID,docAccept,fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept acceptID remoteRecipsAccept knownRemoteRecipsAccept return (obiid, doc, remotesHttpAdd, maccept) lift $ do forkWorker "addBundleC: async HTTP Offer delivery" $ @@ -247,18 +238,27 @@ addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarg deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept return obiidAdd where - toWorkItem (Left (shr, talid)) = WorkItemSharerTicket shr talid True - toWorkItem (Right (shr, rp, ltid)) = WorkItemRepoProposal shr rp ltid + verifyHosterRecip _ _ (Right _) = return () + verifyHosterRecip localRecips name (Left (loom, cloth)) = do + loomHash <- encodeKeyHashid loom + clothHash <- encodeKeyHashid cloth + let verify = do + loomRecips <- lookup loomHash $ recipLooms localRecips + guard $ leafLoom $ familyLoom $ loomRecips + fromMaybeE verify $ + name <> " ticket hoster actor isn't listed as a recipient" - insertAddToOutbox shrUser now obid blinded = do + insertAddToOutbox now blinded = do + let obid = personOutbox personUser hLocal <- asksSite siteInstanceHost obiid <- insertEmptyOutboxItem obid now encodeRouteLocal <- getEncodeRouteLocal obikhid <- encodeKeyHashid obiid - let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid + authorHash <- encodeKeyHashid pidUser + let luAct = encodeRouteLocal $ PersonOutboxItemR authorHash obikhid doc = Doc hLocal Activity { activityId = Just luAct - , activityActor = encodeRouteLocal $ SharerR shrUser + , activityActor = encodeRouteLocal $ PersonR authorHash , activityCapability = Nothing , activitySummary = summary , activityAudience = blinded @@ -268,77 +268,76 @@ addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarg update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc, luAct) - workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr - workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj - workItemActor (WorkItemRepoProposal shr rp _) = LocalActorRepo shr rp + clothRecipSieve (Left (loomID, clothID)) = do + loomHash <- encodeKeyHashid loomID + clothHash <- encodeKeyHashid clothID + return + ( [LocalActorLoom loomHash] + , [ LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash clothHash + ] + ) + clothRecipSieve (Right _) = return ([], []) - insertAccept shrUser local (WorkItemDetail _ ctx ticketAuthor) obiidAdd obiidAccept bnid = do - let wi = toWorkItem local + insertAccept loomID outboxID clothID addID acceptID bundleID = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - wiFollowers <- askWorkItemFollowers - wiBundleRoute <- getWiBundleRoute hLocal <- asksSite siteInstanceHost - obikhidAdd <- encodeKeyHashid obiidAdd - obikhidAccept <- encodeKeyHashid obiidAccept - bnkhid <- encodeKeyHashid bnid + loomHash <- encodeKeyHashid loomID + outboxHash <- encodeKeyHashid outboxID + clothHash <- encodeKeyHashid clothID + addHash <- encodeKeyHashid addID + acceptHash <- encodeKeyHashid acceptID + bundleHash <- encodeKeyHashid bundleID - let audAuthor = - AudLocal - [LocalActorSharer shrUser] - [LocalPersonCollectionSharerFollowers shrUser] - audTicketContext = contextAudience ctx - audTicketAuthor = authorAudience ticketAuthor - audTicketFollowers = AudLocal [] [wiFollowers wi] + let actors = + [ LocalActorPerson authorHash + , LocalActorLoom loomHash + ] + stages = + [ LocalStagePersonFollowers authorHash + , LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash clothHash + ] (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience $ - audAuthor : - audTicketAuthor : - audTicketFollowers : - audTicketContext + collectAudience [AudLocal actors stages] - actor = workItemActor wi recips = map encodeRouteHome audLocal ++ audRemote doc = Doc hLocal Activity { activityId = Just $ encodeRouteLocal $ - actorOutboxItem actor obikhidAccept - , activityActor = encodeRouteLocal $ renderLocalActor actor + LoomOutboxItemR loomHash outboxHash acceptHash + , activityActor = encodeRouteLocal $ LoomR loomHash , activityCapability = Nothing , activitySummary = Nothing , activityAudience = Audience recips [] [] [] [] [] , activitySpecific = AcceptActivity Accept { acceptObject = - encodeRouteHome $ SharerOutboxItemR shrUser obikhidAdd + encodeRouteHome $ PersonOutboxItemR authorHash addHash , acceptResult = - Just $ encodeRouteLocal $ wiBundleRoute local bnkhid + Just $ encodeRouteLocal $ + BundleR loomHash clothHash bundleHash } } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) - where - getWiBundleRoute = do - hashLTID <- getEncodeKeyHashid - hashTALID <- getEncodeKeyHashid - return $ \ wi -> - case wi of - Left (shr, talid) -> - SharerProposalBundleR shr $ hashTALID talid - Right (shr, rp, ltid) -> - RepoProposalBundleR shr rp $ hashLTID ltid +-} applyC :: Entity Person - -> Sharer -> Maybe TextHtml -> Audience URIMode -> Maybe (ObjURI URIMode) -> Apply URIMode -> ExceptT Text Handler OutboxItemId -applyC (Entity pidUser personUser) sharerUser summary audience muCap (Apply uObject uTarget) = do +applyC (Entity pidUser personUser) summary audience muCap (Apply uObject uTarget) = do + error "[August 2022] applyC temporarily disabled" + +{- + -- Verify the patch bundle URI is one of: -- * A local sharer-hosted bundle -- * A local repo-hosted bundle @@ -748,50 +747,56 @@ applyC (Entity pidUser personUser) sharerUser summary audience muCap (Apply uObj update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) -parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId) +-} + +parseComment :: LocalURI -> ExceptT Text Handler (PersonId, LocalMessageId) parseComment luParent = do route <- case decodeRouteLocal luParent of Nothing -> throwE "Not a local route" Just r -> return r case route of - MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid" - _ -> throwE "Not a local message route" + PersonMessageR personHash messageHash -> + (,) <$> decodeKeyHashidE personHash "Invalid person hashid" + <*> decodeKeyHashidE messageHash "Invalid local message hashid" + _ -> throwE "Not a local message route" noteC :: Entity Person - -> Sharer -> Note URIMode -> ExceptT Text Handler OutboxItemId -noteC person sharer note = do - let shrUser = sharerIdent sharer +noteC eperson@(Entity personID person) note = do + personHash <- encodeKeyHashid personID + let username = personUsername person summary <- TextHtml . TL.toStrict . renderHtml <$> withUrlRenderer [hamlet|

- #{shr2text shrUser} + ~#{username2text username} $maybe uContext <- noteContext note \ commented under a # topic. $nothing \ commented. |] - createNoteC person sharer (Just summary) (noteAudience note) note Nothing + createNoteC eperson (Just summary) (noteAudience note) note Nothing -- | Handle a Note submitted by a local user to their outbox. It can be either -- a comment on a local ticket, or a comment on some remote context. Return an -- error message if the Note is rejected, otherwise the new 'LocalMessageId'. createNoteC :: Entity Person - -> Sharer -> Maybe TextHtml -> Audience URIMode -> Note URIMode -> Maybe FedURI -> ExceptT Text Handler OutboxItemId -createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarget = do - let shrUser = sharerIdent sharerUser - noteData@(muParent, mparent, uContext, context, source, content) <- checkNote shrUser note +createNoteC (Entity pidUser personUser) summary audience note muTarget = do + error "Temporarily disabled" + + {- + senderHash <- encodeKeyHashid pidUser + noteData@(muParent, mparent, uContext, context, source, content) <- checkNote senderHash note verifyNothingE muTarget "Create Note has 'target'" ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience @@ -799,73 +804,52 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge checkFederation remoteRecips verifyContextRecip context localRecips remoteRecips now <- liftIO getCurrentTime - (_lmid, obiid, doc, remotesHttp) <- runDBExcept $ do + (obiid, doc, remotesHttp) <- runDBExcept $ do obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now - (mproject, did, meparent) <- getTopicAndParent context mparent - lmid <- lift $ insertMessage now content source obiidCreate did meparent - docCreate <- lift $ insertCreateToOutbox now shrUser blinded noteData obiidCreate lmid + (discussionID, meparent) <- getTopicAndParent context mparent + lmid <- lift $ insertMessage now content source obiidCreate discussionID meparent + docCreate <- lift $ insertCreateToOutbox now senderHash blinded noteData obiidCreate lmid remoteRecipsHttpCreate <- do - hashLT <- getEncodeKeyHashid - hashTAL <- getEncodeKeyHashid - let sieve = - let actors = - case mproject of - Nothing -> [] - Just (Left (shr, prj)) -> [LocalActorProject shr prj] - Just (Right (shr, rp)) -> [LocalActorRepo shr rp] - collections = - let project = - case mproject of - Nothing -> [] - Just (Left (shr, prj)) -> - [ LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj + sieve <- do + hashDeck <- getEncodeHashid + hashTicket <- getEncodeHashid + hashLoom <- getEncodeHashid + hashCloth <- getEncodeHashid + let actors = + case context of + Right _ -> [] + Left (NoteTopicTicket did _) -> [LocalActorDeck $ hashDeck did] + Left (NoteTopicCloth lid _) -> [LocalActorLoom $ hashLoom lid] + stages = + let topic = + case context of + Right _ -> [] + Left (NoteTopicTicket did tdid) -> + let deckHash = hashDeck did + in [ LocalStageDeckFollowers deckHash + , LocalStageTicketFollowers deckHash (hashTicket tdid) ] - Just (Right (shr, rp)) -> - [ LocalPersonCollectionRepoTeam shr rp - , LocalPersonCollectionRepoFollowers shr rp + Left (NoteTopicCloth lid dlid) -> + let loomHash = hashDeck lid + in [ LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash (hashCloth tlid) ] - ticket = - case context of - Left nc -> - case nc of - NoteContextSharerTicket shr talid False -> - let talkhid = hashTAL talid - in [ -- LocalPersonCollectionSharerTicketTeam shr talkhid - LocalPersonCollectionSharerTicketFollowers shr talkhid - ] - NoteContextSharerTicket shr talid True -> - let talkhid = hashTAL talid - in [ -- LocalPersonCollectionSharerProposalTeam shr talkhid - LocalPersonCollectionSharerProposalFollowers shr talkhid - ] - NoteContextProjectTicket shr prj ltid -> - let ltkhid = hashLT ltid - in [ -- LocalPersonCollectionProjectTicketTeam shr prj ltkhid - LocalPersonCollectionProjectTicketFollowers shr prj ltkhid - ] - NoteContextRepoProposal shr rp ltid -> - let ltkhid = hashLT ltid - in [ -- LocalPersonCollectionRepoProposalTeam shr rp ltkhid - LocalPersonCollectionRepoProposalFollowers shr rp ltkhid - ] - Right _ -> [] - commenter = [LocalPersonCollectionSharerFollowers shrUser] - in project ++ ticket ++ commenter - in makeRecipientSet actors collections + commenter = [LocalStagePersonFollowers senderHash] + in topic ++ commenter + return $ makeRecipientSet actors stages moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ + lift $ deliverLocal' True (LocalActorPerson senderHash) (personInbox personUser) obiidCreate $ localRecipSieve' sieve True False localRecips checkFederation moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips - return (lmid, obiidCreate, docCreate, remoteRecipsHttpCreate) + return (obiidCreate, docCreate, remoteRecipsHttpCreate) lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp return obiid where - checkNote shrUser (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do + checkNote authorHash (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do verifyNothingE mluNote "Note specifies an id" encodeRouteLocal <- getEncodeRouteLocal - unless (encodeRouteLocal (SharerR shrUser) == luAttrib) $ + unless (encodeRouteLocal (PersonR authorHash) == luAttrib) $ throwE "Note attributed to someone else" verifyNothingE mpublished "Note specifies published" uContext <- fromMaybeE muContext "Note without context" @@ -873,144 +857,63 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge mparent <- checkParent context =<< traverse parseParent muParent return (muParent, mparent, uContext, context, source, content) where - parseTopic name route = - case route of - SharerTicketR shr talkhid -> - flip (NoteContextSharerTicket shr) False <$> - decodeKeyHashidE - talkhid - (name <> " sharer ticket invalid talkhid") - SharerProposalR shr talkhid -> - flip (NoteContextSharerTicket shr) True <$> - decodeKeyHashidE - talkhid - (name <> " sharer patch invalid talkhid") - ProjectTicketR shr prj ltkhid -> - NoteContextProjectTicket shr prj <$> - decodeKeyHashidE - ltkhid - (name <> " project ticket invalid ltkhid") - RepoProposalR shr rp ltkhid -> - NoteContextRepoProposal shr rp <$> - decodeKeyHashidE - ltkhid - (name <> " repo patch invalid ltkhid") - _ -> throwE $ name <> " isn't a discussion topic route" - parseNoteContext u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "Note context local but not a valid route" - parseTopic "Note context" route - else return $ Right u - parseParent u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "Note parent local but not a valid route" - Left <$> parseTopic "Note parent" route <|> - Right <$> parseComment route - else return $ Right u - where - parseComment (MessageR shr lmkhid) = - (shr,) <$> decodeKeyHashidE lmkhid "Note parent invalid lmkhid" - parseComment _ = throwE "Note parent not a comment route" - checkParent _ Nothing = return Nothing - checkParent (Left topic) (Just (Left (Left topic'))) = + checkParent _ Nothing = return Nothing + checkParent (Left topic) (Just (Left (NoteParentTopic topic'))) = if topic == topic' then return Nothing else throwE "Note context and parent are different local topics" - checkParent _ (Just (Left (Right msg))) = return $ Just $ Left msg - checkParent (Left _) (Just (Right u)) = return $ Just $ Right u - checkParent (Right u) (Just (Right u')) = + checkParent _ (Just (Left (NoteParentMessage person message))) = return $ Just $ Left (person, message) + checkParent (Left _) (Just (Right u)) = return $ Just $ Right u + checkParent (Right u) (Just (Right u')) = return $ if u == u' then Nothing else Just $ Right u' checkParent _ _ = error "A situation I missed in pattern matching, fix it?" + checkFederation remoteRecips = do federation <- asksSite $ appFederation . appSettings unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients found" + verifyContextRecip (Right (ObjURI h _)) _ remoteRecips = unless (any ((== h) . fst) remoteRecips) $ throwE "Context is remote but no recipients of that host are listed" - verifyContextRecip (Left (NoteContextSharerTicket shr _ _)) localRecips _ = - fromMaybeE - verify - "Local context ticket's hosting sharer isn't listed as a recipient" - where - verify = do - sharerSet <- lookup shr localRecips - guard $ localRecipSharer $ localRecipSharerDirect sharerSet - verifyContextRecip (Left (NoteContextProjectTicket shr prj _)) localRecips _ = + verifyContextRecip (Left (NoteTopicTicket deckID _)) localRecips _ = do + deckHash <- encodeKeyHashid deckID + let verify = do + deckFamily <- lookup deckHash $ recipDecks localRecips + guard $ leafDeck $ familyDeck deckFamily fromMaybeE verify "Local context ticket's hosting project isn't listed as a recipient" - where - verify = do - sharerSet <- lookup shr localRecips - projectSet <- lookup prj $ localRecipProjectRelated sharerSet - guard $ localRecipProject $ localRecipProjectDirect projectSet - verifyContextRecip (Left (NoteContextRepoProposal shr rp _)) localRecips _ = + verifyContextRecip (Left (NoteTopicCloth loomID _)) localRecips _ = do + loomHash <- encodeKeyHashid loomID + let verify = do + loomFamily <- lookup loomHash $ recipLooms localRecips + guard $ leafLoom $ familyLoom loomFamily fromMaybeE verify - "Local context patch's hosting repo isn't listed as a recipient" - where - verify = do - sharerSet <- lookup shr localRecips - repoSet <- lookup rp $ localRecipRepoRelated sharerSet - guard $ localRecipRepo $ localRecipRepoDirect repoSet - getProject tpl = do - j <- getJust $ ticketProjectLocalProject tpl - s <- getJust $ projectSharer j - return (sharerIdent s, projectIdent j) - getRepo trl = do - r <- getJust $ ticketRepoLocalRepo trl - s <- getJust $ repoSharer r - return (sharerIdent s, repoIdent r) + "Local context patch's hosting loom isn't listed as a recipient" + getTopicAndParent (Left context) mparent = do - (mproject, did) <- + discussionID <- case context of - NoteContextSharerTicket shr talid False -> do - (_, Entity _ lt, _, project, _) <- do - mticket <- lift $ getSharerTicket shr talid - fromMaybeE mticket "Note context no such local sharer-hosted ticket" - mproj <- - case project of - Left (_, Entity _ tpl) -> lift $ Just . Left <$> getProject tpl - Right _ -> return Nothing - return (mproj, localTicketDiscuss lt) - NoteContextSharerTicket shr talid True -> do - (_, Entity _ lt, _, repo, _, _) <- do - mticket <- lift $ getSharerProposal shr talid - fromMaybeE mticket "Note context no such local sharer-hosted patch" - mproj <- - case repo of - Left (_, Entity _ trl) -> lift $ Just . Right <$> getRepo trl - Right _ -> return Nothing - return (mproj, localTicketDiscuss lt) - NoteContextProjectTicket shr prj ltid -> do - (_, _, _, Entity _ lt, _, _, _, _) <- do - mticket <- lift $ getProjectTicket shr prj ltid - fromMaybeE mticket "Note context no such local project-hosted ticket" - return (Just $ Left (shr, prj), localTicketDiscuss lt) - NoteContextRepoProposal shr rp ltid -> do - (_, _, _, Entity _ lt, _, _, _, _, _) <- do - mticket <- lift $ getRepoProposal shr rp ltid - fromMaybeE mticket "Note context no such local project-hosted ticket" - return (Just $ Right (shr, rp), localTicketDiscuss lt) + NoteTopicTicket deckID ticketID -> do + (_, _, Entity _ t, _, _) <- do + mticket <- lift $ getTicket deckID ticketID + fromMaybeE mticket "Note context no such local deck-hosted ticket" + return $ ticketDiscuss t + NoteTopicCloth loomID clothID -> do + (_, _, Entity _ t, _, _, _) <- do + mcloth <- lift $ getCloth loomID clothID + fromMaybeE mcloth "Note context no such local loom-hosted ticket" + return $ ticketDiscuss t mmidParent <- for mparent $ \ parent -> case parent of - Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent + Left (personID, messageID) -> getLocalParentMessageId discussionID personID messageID Right (ObjURI hParent luParent) -> do mrm <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hParent @@ -1019,41 +922,29 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge rm <- fromMaybeE mrm "Remote parent unknown locally" let mid = remoteMessageRest rm m <- lift $ getJust mid - unless (messageRoot m == did) $ + unless (messageRoot m == discussionID) $ throwE "Remote parent belongs to a different discussion" return mid - return (mproject, did, Left <$> mmidParent) + return (discussionID, Left <$> mmidParent) + getTopicAndParent (Right u@(ObjURI h lu)) mparent = do - (mproject, rd, rdnew) <- lift $ do + (rd, rdnew) <- lift $ do iid <- either entityKey id <$> insertBy' (Instance h) roid <- either entityKey id <$> insertBy' (RemoteObject iid lu) - merd <- getBy $ UniqueRemoteDiscussionIdent roid - case merd of - Just (Entity rdid rd) -> do - mproj <- runMaybeT $ do - rt <- MaybeT $ getValBy $ UniqueRemoteTicketDiscuss rdid - tar <- lift $ getJust $ remoteTicketTicket rt - let tclid = ticketAuthorRemoteTicket tar - txl <- - lift $ - requireEitherAlt - (getValBy $ UniqueTicketProjectLocal tclid) - (getValBy $ UniqueTicketRepoLocal tclid) - "No specific TCL" - "Both TPL and TRL" - lift $ bitraverse getProject getRepo txl - return (mproj, rd, False) + mrd <- getValBy $ UniqueRemoteDiscussionIdent roid + case mrd of + Just rd -> return (rd, False) Nothing -> do did <- insert Discussion (rd, rdnew) <- valAndNew <$> insertByEntity' (RemoteDiscussion roid did) unless rdnew $ delete did - return (Nothing, rd, rdnew) - let did = remoteDiscussionDiscuss rd + return (rd, rdnew) + let discussionID = remoteDiscussionDiscuss rd meparent <- for mparent $ \ parent -> case parent of - Left (shrParent, lmidParent) -> do + Left (personID, messageID) -> do when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new" - Left <$> getLocalParentMessageId did shrParent lmidParent + Left <$> getLocalParentMessageId discussionID personID messageID Right uParent@(ObjURI hParent luParent) -> do mrm <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hParent @@ -1064,10 +955,11 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge Just rm -> Left <$> do let mid = remoteMessageRest rm m <- lift $ getJust mid - unless (messageRoot m == did) $ + unless (messageRoot m == discussionID) $ throwE "Remote parent belongs to a different discussion" return mid - return (mproject, did, meparent) + return (discussionID, meparent) + insertMessage now content source obiidCreate did meparent = do mid <- insert Message { messageCreated = now @@ -1088,21 +980,22 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge Just (Right uParent) -> Just uParent _ -> Nothing } - insertCreateToOutbox now shrUser blinded (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do + + insertCreateToOutbox now senderHash blinded (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do encodeRouteLocal <- getEncodeRouteLocal hLocal <- asksSite siteInstanceHost obikhid <- encodeKeyHashid obiidCreate lmkhid <- encodeKeyHashid lmid - let luAttrib = encodeRouteLocal $ SharerR shrUser + let luAttrib = encodeRouteLocal $ PersonR senderHash create = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid + { activityId = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid , activityActor = luAttrib , activityCapability = Nothing , activitySummary = summary , activityAudience = blinded , activitySpecific = CreateActivity Create { createObject = CreateNote hLocal Note - { noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid + { noteId = Just $ encodeRouteLocal $ MessageR senderHash lmkhid , noteAttrib = luAttrib , noteAudience = emptyAudience , noteReplyTo = Just $ fromMaybe uContext muParent @@ -1116,12 +1009,14 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge } update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] return create +-} checkFederation remoteRecips = do federation <- asksSite $ appFederation . appSettings unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients found" +{- verifyProjectRecip (Right _) _ = return () verifyProjectRecip (Left (WITProject shr prj)) localRecips = fromMaybeE verify "Local context project isn't listed as a recipient" @@ -1137,613 +1032,22 @@ verifyProjectRecip (Left (WITRepo shr rp _ _ _)) localRecips = sharerSet <- lookup shr localRecips repoSet <- lookup rp $ localRecipRepoRelated sharerSet guard $ localRecipRepo $ localRecipRepoDirect repoSet - --- | Handle a Ticket submitted by a local user to their outbox. The ticket's --- context project may be local or remote. Return an error message if the --- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'. -createTicketC - :: Entity Person - -> Sharer - -> Maybe TextHtml - -> Audience URIMode - -> AP.Ticket URIMode - -> Maybe FedURI - -> ExceptT Text Handler OutboxItemId -createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = do - let shrUser = sharerIdent sharerUser - (context, title, desc, source) <- checkCreateTicket shrUser ticket muTarget - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Create Ticket with no recipients" - checkFederation remoteRecips - verifyProjectRecip context localRecips - tracker <- bitraverse pure fetchTracker context - now <- liftIO getCurrentTime - (_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do - obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now - project <- prepareProject now tracker - (talid, mbn) <- lift $ insertTicket now pidUser title desc source obiidCreate project - docCreate <- lift $ insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mbn - remoteRecipsHttpCreate <- do - let sieve = - case context of - Left (WITProject shr prj) -> - makeRecipientSet - [ LocalActorProject shr prj - ] - [ LocalPersonCollectionSharerFollowers shrUser - , LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj - ] - Left (WITRepo shr rp _ _ _) -> - makeRecipientSet - [ LocalActorRepo shr rp - ] - [ LocalPersonCollectionSharerFollowers shrUser - , LocalPersonCollectionRepoTeam shr rp - , LocalPersonCollectionRepoFollowers shr rp - ] - Right _ -> - makeRecipientSet - [] - [LocalPersonCollectionSharerFollowers shrUser] - moreRemoteRecips <- - lift $ - deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ - localRecipSieve sieve False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips - maccept <- - case project of - Left proj@(shr, ent, obiidAccept) -> Just <$> do - let recipsA = - [ LocalActorSharer shrUser - ] - (recipsC, ibid, actor) = - case ent of - Left (Entity _ j, a) -> - let prj = projectIdent j - in ( [ LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj - , LocalPersonCollectionSharerFollowers shrUser - ] - , actorInbox a - , LocalActorProject shr prj - ) - Right (Entity _ r, _, _, _) -> - let rp = repoIdent r - in ( [ LocalPersonCollectionRepoTeam shr rp - , LocalPersonCollectionRepoFollowers shr rp - , LocalPersonCollectionSharerFollowers shrUser - ] - , repoInbox r - , LocalActorRepo shr rp - ) - doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC - recips <- - lift $ - deliverLocal' True actor ibid obiidAccept $ - makeRecipientSet recipsA recipsC - checkFederation recips - lift $ (obiidAccept,doc,) <$> deliverRemoteDB'' [] obiidAccept [] recips - Right _ -> return Nothing - return (talid, obiidCreate, docCreate, remoteRecipsHttpCreate, maccept) - lift $ do - forkWorker "createTicketC: async HTTP Create delivery" $ deliverRemoteHttp' fwdHosts obiidCreate docCreate remotesHttpCreate - for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) -> - forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept - return obiidCreate - where - checkCreateTicket - :: ShrIdent - -> AP.Ticket URIMode - -> Maybe FedURI - -> ExceptT Text Handler - ( Either - WorkItemTarget - ( Host - , LocalURI - , LocalURI - , Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text) - ) - , TextHtml - , TextHtml - , TextPandocMarkdown - ) - checkCreateTicket shr ticket muTarget = do - uTarget <- fromMaybeE muTarget "Create Ticket without 'target'" - target <- checkTracker "Create target" uTarget - (context, summary, content, source) <- checkTicket ticket - item <- checkTargetAndContext target context - return (item, summary, content, source) - where - checkTracker - :: Text - -> FedURI - -> ExceptT Text Handler - (Either - (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) - FedURI - ) - checkTracker name u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - (name <> " is local but isn't a valid route") - case route of - ProjectR shr prj -> return $ Left (shr, prj) - RepoR shr rp -> return $ Right (shr, rp) - _ -> - throwE $ - name <> - " is a valid local route, but isn't a \ - \project/repo route" - else return $ Right u - checkTicket - :: AP.Ticket URIMode - -> ExceptT Text Handler - ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text)) - , TextHtml - , TextHtml - , TextPandocMarkdown - ) - checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary - content source muAssigned mresolved mmr) = do - verifyNothingE mlocal "Ticket with 'id'" - encodeRouteLocal <- getEncodeRouteLocal - unless (encodeRouteLocal (SharerR shr) == attrib) $ - throwE "Ticket attributed to someone else" - verifyNothingE mpublished "Ticket with 'published'" - verifyNothingE mupdated "Ticket with 'updated'" - uContext <- fromMaybeE muContext "Ticket without 'context'" - context <- checkTracker "Ticket context" uContext - verifyNothingE muAssigned "Ticket with 'assignedTo'" - when (isJust mresolved) $ throwE "Ticket resolved" - mmr' <- traverse (uncurry checkMR) mmr - context' <- matchContextAndMR context mmr' - return (context', summary, content, source) - where - checkMR - :: Host - -> MergeRequest URIMode - -> ExceptT Text Handler - ( Either (ShrIdent, RpIdent, Maybe Text) FedURI - , PatchMediaType - , NonEmpty Text - ) - checkMR h (MergeRequest muOrigin luTarget ebundle) = do - verifyNothingE muOrigin "MR with 'origin'" - branch <- checkBranch h luTarget - (typ, diffs) <- - case ebundle of - Left _ -> throwE "MR bundle specified as a URI" - Right (hBundle, bundle) -> checkBundle hBundle bundle - case (typ, diffs) of - (PatchMediaTypeDarcs, _ :| _ : _) -> - throwE "More than one Darcs patch bundle provided" - _ -> return () - return (branch, typ, diffs) - where - checkBranch - :: Host - -> LocalURI - -> ExceptT Text Handler - (Either (ShrIdent, RpIdent, Maybe Text) FedURI) - checkBranch h lu = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "MR target is local but isn't a valid route" - case route of - RepoR shr rp -> return (shr, rp, Nothing) - RepoBranchR shr rp b -> return (shr, rp, Just b) - _ -> - throwE - "MR target is a valid local route, but isn't a \ - \repo or branch route" - else return $ Right $ ObjURI h lu - checkBundle _ (AP.BundleHosted _ _) = - throwE "Patches specified as URIs" - checkBundle h (AP.BundleOffer mlocal patches) = do - verifyNothingE mlocal "Bundle has 'id'" - (typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches - unless (all (== typ) typs) $ throwE "Different patch types" - return (typ, diffs) - where - checkPatch - :: Host - -> AP.Patch URIMode - -> ExceptT Text Handler - ( PatchMediaType - , Text - ) - checkPatch h (AP.Patch mlocal attrib mpub typ content) = do - encodeRouteLocal <- getEncodeRouteLocal - verifyHostLocal h "Patch attributed to remote user" - verifyNothingE mlocal "Patch with 'id'" - unless (encodeRouteLocal (SharerR shr) == attrib) $ - throwE "Ticket and Patch attrib mismatch" - verifyNothingE mpub "Patch has 'published'" - return (typ, content) - matchContextAndMR - :: Either - (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) - FedURI - -> Maybe - ( Either (ShrIdent, RpIdent, Maybe Text) FedURI - , PatchMediaType - , NonEmpty Text - ) - -> ExceptT Text Handler - (Either - WorkItemTarget - ( Host - , LocalURI - , Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text) - ) - ) - matchContextAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj - matchContextAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" - matchContextAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" - matchContextAndMR (Left (Right (shr, rp))) (Just (branch, typ, diffs)) = do - branch' <- - case branch of - Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb - _ -> throwE "MR target repo/branch and Ticket context repo mismatch" - case patchMediaTypeVCS typ of - VCSDarcs -> - unless (isNothing branch') $ - throwE "Darcs MR specifies a branch" - VCSGit -> - unless (isJust branch') $ - throwE "Git MR doesn't specify the branch" - return $ Left $ WITRepo shr rp branch' typ diffs - matchContextAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) - matchContextAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = do - luBranch <- - case branch of - Right (ObjURI h' lu') | h == h' -> return lu - _ -> throwE "MR target repo/branch and Ticket context repo mismatch" - let bundle = - ( if lu == luBranch then Nothing else Just luBranch - , typ - , diffs - ) - return $ Right (h, lu, Just bundle) - checkTargetAndContext - :: Either - (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) - FedURI - -> Either - WorkItemTarget - (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text)) - -> ExceptT Text Handler - (Either - WorkItemTarget - ( Host - , LocalURI - , LocalURI - , Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text) - ) - ) - checkTargetAndContext (Left _) (Right _) = - throwE "Create target is local but ticket context is remote" - checkTargetAndContext (Right _) (Left _) = - throwE "Create target is remote but ticket context is local" - checkTargetAndContext (Right (ObjURI hTarget luTarget)) (Right (hContext, luContext, mbundle)) = - if hTarget == hContext - then return $ Right (hContext, luTarget, luContext, mbundle) - else throwE "Create target and ticket context on different \ - \remote hosts" - checkTargetAndContext (Left proj) (Left wit) = - case (proj, wit) of - (Left (shr, prj), WITProject shr' prj') - | shr == shr' && prj == prj' -> return $ Left wit - (Right (shr, rp), WITRepo shr' rp' _ _ _) - | shr == shr' && rp == rp' -> return $ Left wit - _ -> throwE "Create target and ticket context are different \ - \local projects" - - fetchTracker (h, luTarget, luContext, mbundle) = do - (iid, era) <- do - iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h) - result <- lift $ fetchRemoteActor iid h luTarget - case result of - Left e -> throwE $ T.pack $ displayException e - Right (Left e) -> throwE $ T.pack $ show e - Right (Right mera) -> do - era <- fromMaybeE mera "target found to be a collection, not an actor" - return (iid, era) - return (iid, era, if luTarget == luContext then Nothing else Just luContext, mbundle) - - prepareProject now (Left (WITProject shr prj)) = Left <$> do - mej <- lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - MaybeT $ getBy $ UniqueProject prj sid - ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project" - 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 - MaybeT $ getBy $ UniqueRepo rp sid - er@(Entity _ r) <- fromMaybeE mer "Local context: no such repo" - unless (repoVcs r == patchMediaTypeVCS typ) $ - throwE "Repo VCS and patch VCS mismatch" - obiidAccept <- lift $ insertEmptyOutboxItem (repoOutbox r) now - return (shr, Right (er, mb, typ, diff), obiidAccept) - prepareProject _ (Right (iid, era, mlu, mpatch)) = lift $ Right <$> do - let mlu' = - case mpatch of - Just (Just luBranch, _, _) -> Just luBranch - _ -> mlu - mroid <- for mlu' $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu) - let removeBranch (mb, typ, diff) = (typ, diff) - return (era, mroid, removeBranch <$> mpatch) - - insertTicket now pidUser title desc source obiidCreate project = do - did <- insert Discussion - fsid <- insert FollowerSet - tid <- insert Ticket - { ticketNumber = Nothing - , ticketCreated = now - , ticketTitle = unTextHtml title - , ticketSource = unTextPandocMarkdown source - , ticketDescription = unTextHtml desc - , ticketAssignee = Nothing - , ticketStatus = TSNew - } - ltid <- insert LocalTicket - { localTicketTicket = tid - , localTicketDiscuss = did - , localTicketFollowers = fsid - } - talid <- insert TicketAuthorLocal - { ticketAuthorLocalTicket = ltid - , ticketAuthorLocalAuthor = pidUser - , ticketAuthorLocalOpen = obiidCreate - } - mbn <- - case project of - Left (_shr, ent, obiidAccept) -> do - tclid <- insert TicketContextLocal - { ticketContextLocalTicket = tid - , ticketContextLocalAccept = obiidAccept - } - case ent of - Left (Entity jid _, _) -> do - insert_ TicketProjectLocal - { ticketProjectLocalContext = tclid - , ticketProjectLocalProject = jid - } - return Nothing - Right (Entity rid _, mb, typ, diffs) -> Just <$> do - insert_ TicketRepoLocal - { ticketRepoLocalContext = tclid - , ticketRepoLocalRepo = rid - , ticketRepoLocalBranch = mb - } - bnid <- insert $ Bundle tid - (bnid,) . toNE <$> - insertMany - (NE.toList $ NE.map (Patch bnid now typ) diffs) - Right (Entity raid _, mroid, mbundle) -> do - insert_ TicketProjectRemote - { ticketProjectRemoteTicket = talid - , ticketProjectRemoteTracker = raid - , ticketProjectRemoteProject = mroid - } - for mbundle $ \ (typ, diffs) -> do - bnid <- insert $ Bundle tid - (bnid,) . toNE <$> - insertMany - (NE.toList $ NE.map (Patch bnid now typ) diffs) - return (talid, mbn) - where - toNE = fromMaybe (error "No Patch IDs returned from DB") . NE.nonEmpty - - insertCreateToOutbox shrUser blinded context title desc source now obiidCreate talid mbn = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - talkhid <- encodeKeyHashid talid - mkh <- for mbn $ \ (bnid, ptids) -> - (,) <$> encodeKeyHashid bnid - <*> traverse encodeKeyHashid ptids - obikhid <- encodeKeyHashid obiidCreate - let luTicket = encodeRouteLocal $ SharerTicketR shrUser talkhid - luAttrib = encodeRouteLocal $ SharerR shrUser - (uTarget, uContext, mmr) = - case context of - Left (WITProject shr prj) -> - let uProject = encodeRouteHome $ ProjectR shr prj - in (uProject, uProject, Nothing) - Left (WITRepo shr rp mb typ diffs) -> - let uRepo = encodeRouteHome $ RepoR shr rp - (bnkhid, ptkhids) = - case mkh of - Nothing -> error "mkh is Nothing" - Just v -> v - luBundle = - encodeRouteLocal $ - SharerProposalBundleR shrUser talkhid bnkhid - mr = MergeRequest - { mrOrigin = Nothing - , mrTarget = - encodeRouteLocal $ - case mb of - Nothing -> RepoR shr rp - Just b -> RepoBranchR shr rp b - , mrBundle = Right - ( hLocal - , AP.BundleOffer - (Just - ( hLocal - , BundleLocal - { bundleId = luBundle - , bundleContext = luTicket - , bundlePrevVersions = [] - , bundleCurrentVersion = Nothing - } - ) - ) - (NE.map - (\ (ptkhid, diff) -> AP.Patch - { AP.patchLocal = Just - ( hLocal - , PatchLocal - { patchId = - encodeRouteLocal $ - SharerProposalBundlePatchR shrUser talkhid bnkhid ptkhid - , patchContext = luBundle - } - ) - , AP.patchAttributedTo = luAttrib - , AP.patchPublished = Just now - , AP.patchType = typ - , AP.patchContent = diff - } - ) - (NE.zip ptkhids diffs) - ) - ) - } - in (uRepo, uRepo, Just (hLocal, mr)) - Right (hContext, luTarget, luContext, mbundle) -> - let mr (mluBranch, typ, diffs) = - let (bnkhid, ptkhids) = - case mkh of - Nothing -> error "mkh is Nothing" - Just v -> v - luBundle = - encodeRouteLocal $ - SharerProposalBundleR shrUser talkhid bnkhid - in MergeRequest - { mrOrigin = Nothing - , mrTarget = fromMaybe luContext mluBranch - , mrBundle = Right - ( hLocal - , AP.BundleOffer - (Just - ( hLocal - , BundleLocal - { bundleId = luBundle - , bundleContext = luTicket - , bundlePrevVersions = [] - , bundleCurrentVersion = Nothing - } - ) - ) - (NE.map - (\ (ptkhid, diff) -> AP.Patch - { AP.patchLocal = Just - ( hLocal - , PatchLocal - { patchId = - encodeRouteLocal $ - SharerProposalBundlePatchR shrUser talkhid bnkhid ptkhid - , patchContext = luBundle - } - ) - , AP.patchAttributedTo = luAttrib - , AP.patchPublished = Just now - , AP.patchType = typ - , AP.patchContent = diff - } - ) - (NE.zip ptkhids diffs) - ) - ) - } - in ( ObjURI hContext luTarget - , ObjURI hContext luContext - , (hContext,) . mr <$> mbundle - ) - tlocal = TicketLocal - { ticketId = luTicket - , ticketReplies = encodeRouteLocal $ SharerTicketDiscussionR shrUser talkhid - , ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shrUser talkhid - , ticketTeam = Nothing -- Just $ encodeRouteLocal $ SharerTicketTeamR shrUser talkhid - , ticketEvents = encodeRouteLocal $ SharerTicketEventsR shrUser talkhid - , ticketDeps = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid - , ticketReverseDeps = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid - } - create = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid - , activityActor = luAttrib - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activitySpecific = CreateActivity Create - { createObject = CreateTicket hLocal AP.Ticket - { AP.ticketLocal = Just (hLocal, tlocal) - , AP.ticketAttributedTo = luAttrib - , AP.ticketPublished = Just now - , AP.ticketUpdated = Nothing - , AP.ticketContext = Just uContext - , AP.ticketSummary = title - , AP.ticketContent = desc - , AP.ticketSource = source - , AP.ticketAssignedTo = Nothing - , AP.ticketResolved = Nothing - , AP.ticketAttachment = mmr - } - , createTarget = Just uTarget - } - } - update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] - return create - - insertAcceptToOutbox (shrJ, ent, obiidAccept) shrU obiidCreate talid actors colls = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - obikhidAccept <- encodeKeyHashid obiidAccept - obikhidCreate <- encodeKeyHashid obiidCreate - talkhid <- encodeKeyHashid talid - let (outboxItemRoute, actorRoute) = - case ent of - Left (Entity _ j, _) -> - let prj = projectIdent j - in (ProjectOutboxItemR shrJ prj, ProjectR shrJ prj) - Right (Entity _ r, _, _, _) -> - let rp = repoIdent r - in (RepoOutboxItemR shrJ rp, RepoR shrJ rp) - recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls - accept = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept - , activityActor = encodeRouteLocal actorRoute - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = encodeRouteHome $ SharerOutboxItemR shrU obikhidCreate - , acceptResult = Nothing - } - } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept] - return accept +-} createTicketTrackerC :: Entity Person - -> Sharer -> Maybe TextHtml -> Audience URIMode -> AP.ActorDetail -> Maybe FedURI -> ExceptT Text Handler OutboxItemId -createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tracker muTarget = do +createTicketTrackerC (Entity pidUser personUser) summary audience tracker muTarget = do + error "Temporarily disabled" +{- -- Check input (name, msummary) <- parseTracker tracker - let shrUser = sharerIdent sharerUser + senderHash <- encodeKeyHashid pidUser now <- liftIO getCurrentTime verifyNothingE muTarget "'target' not supported in Create TicketTracker" ParsedAudience localRecips remoteRecips blinded fwdHosts <- do @@ -1755,19 +1059,19 @@ createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tra -- Insert new project to DB obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now wid <- findWorkflow $ personIdent personUser - (jid, prj, obidDeck, ibidDeck) <- lift $ insertDeck now name msummary obiidCreate wid + (jid, obidDeck, ibidDeck) <- lift $ insertDeck now name msummary obiidCreate wid -- Insert the Create activity to author's outbox - docCreate <- lift $ insertCreateToOutbox shrUser now blinded name msummary obiidCreate prj + deckHash <- encodeKeyHashid jid + docCreate <- lift $ insertCreateToOutbox shrUser now blinded name msummary obiidCreate deckHash -- Deliver the Create activity to local recipients, and schedule -- delivery for unavailable remote recipients remoteRecipsHttpCreate <- do - let sieve = makeRecipientSet - [] - [LocalPersonCollectionSharerFollowers shrUser] + let sieve = + makeRecipientSet [] [LocalStagePersonFollowers senderHash] moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ + lift $ deliverLocal' True (LocalActorPerson senderHash) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips checkFederation moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips @@ -1777,17 +1081,17 @@ createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tra lift $ insertCollab jid obiidGrant -- Insert a Grant activity to project's outbox - let grantRecipActors = [LocalActorSharer shrUser] - grantRecipCollections = [LocalPersonCollectionSharerFollowers shrUser] + let grantRecipActors = [LocalActorPerson senderHash] + grantRecipStages = [LocalStagePersonFollowers senderHash] docGrant <- - lift $ insertGrantToOutbox shrUser prj obiidCreate obiidGrant grantRecipActors grantRecipCollections + lift $ insertGrantToOutbox senderHash deckHash obiidCreate obiidGrant grantRecipActors grantRecipStages -- Deliver the Grant activity to local recipients, and schedule -- delivery for unavailable remote recipients remoteRecipsHttpGrant <- do remoteRecips <- - lift $ deliverLocal' True (LocalActorProject shrUser prj) ibidDeck obiidGrant $ - makeRecipientSet grantRecipActors grantRecipCollections + lift $ deliverLocal' True (LocalActorDeck shrUser deckHash) ibidDeck obiidGrant $ + makeRecipientSet grantRecipActors grantRecipStages checkFederation remoteRecips lift $ deliverRemoteDB'' [] obiidGrant [] remoteRecips @@ -1812,13 +1116,9 @@ createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tra name <- fromMaybeE mname "TicketTracker doesn't specify name" return (name, msummary) - findWorkflow sid = do - mw <- - lift $ - selectFirst - ([WorkflowSharer ==. sid] ||. [WorkflowScope !=. WSSharer]) - [Asc WorkflowId] - entityKey <$> fromMaybeE mw "Can't find a suitable workflow" + findWorkflow = do + mw <- lift $ selectFirst ([] :: Filter Workflow) [] + entityKey <$> fromMaybeE mw "Can't find a workflow" insertDeck now name msummary obiidCreate wid = do ibid <- insert Inbox @@ -1832,23 +1132,18 @@ createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tra , actorOutbox = obid , actorFollowers = fsid } - let ident = text2prj $ "actor_id_" <> T.pack (show $ fromSqlKey aid) - jid <- insert Project - { projectActor = aid - , projectIdent = ident - , projectSharer = personIdent personUser - , projectName = Just name - , projectDesc = msummary - , projectWorkflow = wid - , projectNextTicket = 1 - , projectWiki = Nothing - , projectCollabAnon = Nothing - , projectCollabUser = Nothing - , projectCreate = obiidCreate + did <- insert Deck + { deckActor = aid + , deckWorkflow = wid + , deckNextTicket = 1 + , deckWiki = Nothing + , deckCollabAnon = Nothing + , deckCollabUser = Nothing + , deckCreate = obiidCreate } - return (jid, ident, obid, ibid) + return (did, obid, ibid) - insertCreateToOutbox shrUser now blinded name msummary obiidCreate prj = do + insertCreateToOutbox senderHash now blinded name msummary obiidCreate deckHash = do encodeRouteLocal <- getEncodeRouteLocal hLocal <- asksSite siteInstanceHost obikhid <- encodeKeyHashid obiidCreate @@ -1859,8 +1154,8 @@ createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tra , AP.actorSummary = msummary } ttlocal = AP.ActorLocal - { AP.actorId = encodeRouteLocal $ ProjectR shrUser prj - , AP.actorInbox = encodeRouteLocal $ ProjectInboxR shrUser prj + { AP.actorId = encodeRouteLocal $ DeckR deckHash + , AP.actorInbox = encodeRouteLocal $ DeckInboxR deckHash , AP.actorOutbox = Nothing , AP.actorFollowers = Nothing , AP.actorFollowing = Nothing @@ -1868,8 +1163,8 @@ createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tra , AP.actorSshKeys = [] } create = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid - , activityActor = encodeRouteLocal $ SharerR shrUser + { activityId = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid + , activityActor = encodeRouteLocal $ PersonR senderHash , activityCapability = Nothing , activitySummary = summary , activityAudience = blinded @@ -1888,7 +1183,7 @@ createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tra insert_ $ CollabRecipLocal cid pidUser insert_ $ CollabFulfillsLocalTopicCreation cid - insertGrantToOutbox shrUser prj obiidCreate obiidGrant actors collections = do + insertGrantToOutbox adminHash deckHash obiidCreate obiidGrant actors stages = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost @@ -1897,206 +1192,166 @@ createTicketTrackerC (Entity pidUser personUser) sharerUser summary audience tra let recips = map encodeRouteHome $ map renderLocalActor actors ++ - map renderLocalPersonCollection collections + map renderLocalStage stages grant = Doc hLocal Activity { activityId = Just $ encodeRouteLocal $ - ProjectOutboxItemR shrUser prj obikhidGrant - , activityActor = encodeRouteLocal $ ProjectR shrUser prj + DeckOutboxItemR deckHash obikhidGrant + , activityActor = encodeRouteLocal $ DeckR deckHash , activityCapability = Nothing , activitySummary = Nothing , activityAudience = Audience recips [] [] [] [] [] , activitySpecific = GrantActivity Grant { grantObject = Left RoleAdmin - , grantContext = encodeRouteHome $ ProjectR shrUser prj - , grantTarget = encodeRouteHome $ SharerR shrUser - , grantFulfills = Just $ encodeRouteHome $ SharerOutboxItemR shrUser obikhidCreate + , grantContext = encodeRouteHome $ DeckR deckHash + , grantTarget = encodeRouteHome $ PersonR adminHash + , grantFulfills = Just $ encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate } } update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant] return grant +-} data Followee - = FolloweeSharer ShrIdent - | FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal) - | FolloweeSharerProposal ShrIdent (KeyHashid TicketAuthorLocal) - | FolloweeProject ShrIdent PrjIdent - | FolloweeProjectTicket ShrIdent PrjIdent (KeyHashid LocalTicket) - | FolloweeRepo ShrIdent RpIdent - | FolloweeRepoProposal ShrIdent RpIdent (KeyHashid LocalTicket) + = FolloweePerson (KeyHashid Person) + | FolloweeRepo (KeyHashid Repo) + | FolloweeDeck (KeyHashid Deck) + | FolloweeLoom (KeyHashid Loom) + | FolloweeTicket (KeyHashid Deck) (KeyHashid TicketDeck) + | FolloweeCloth (KeyHashid Loom) (KeyHashid TicketLoom) followC - :: ShrIdent + :: Entity Person -> Maybe TextHtml -> Audience URIMode -> AP.Follow URIMode -> ExceptT Text Handler OutboxItemId -followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do +followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObject muContext hide) = do ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience fromMaybeE mrecips "Follow with no recipients" federation <- asksSite $ appFederation . appSettings unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients specified" + senderHash <- encodeKeyHashid pidSender mfollowee <- do let ObjURI h luObject = uObject local <- hostIsLocal h if local then Just <$> do - route <- - fromMaybeE - (decodeRouteLocal luObject) - "Follow object isn't a valid route" - followee <- - fromMaybeE - (parseFollowee route) - "Follow object isn't a followee route" - let actor = followeeActor followee - unless (actorRecips actor == localRecips) $ - throwE "Follow object isn't the recipient" - case followee of - FolloweeSharer shr | shr == shrUser -> - throwE "User trying to follow themselves" - _ -> return () - return (followee, actor) + route <- + fromMaybeE + (decodeRouteLocal luObject) + "Follow object isn't a valid route" + followee <- + fromMaybeE + (parseFollowee route) + "Follow object isn't a followee route" + let actor = followeeActor followee + unless (actorRecips actor == localRecips) $ + throwE "Follow object isn't the recipient" + case followee of + FolloweePerson p | p == senderHash -> + throwE "User trying to follow themselves" + _ -> return () + return (followee, actor) else do - unless (null localRecips) $ + unless (localRecips == RecipientRoutes [] [] [] [] []) $ throwE "Follow object is remote but local recips listed" return Nothing (obiidFollow, doc, remotesHttp) <- runDBExcept $ do - Entity pidAuthor personAuthor <- lift $ getAuthor shrUser - let ibidAuthor = personInbox personAuthor - obidAuthor = personOutbox personAuthor - (obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor blinded + let actorSenderID = personActor personSender + actorSender <- lift $ getJust actorSenderID + let ibidSender = actorInbox actorSender + obidSender = actorOutbox actorSender + (obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox senderHash obidSender blinded case mfollowee of - Nothing -> lift $ insert_ $ FollowRemoteRequest pidAuthor uObject muContext (not hide) obiidFollow + Nothing -> lift $ insert_ $ FollowRemoteRequest pidSender uObject muContext (not hide) obiidFollow Just (followee, actorRecip) -> do - (fsid, ibidRecip, unread, obidRecip) <- getFollowee followee - obiidAccept <- lift $ insertAcceptToOutbox luFollow actorRecip obidRecip - deliverFollowLocal pidAuthor fsid unread obiidFollow obiidAccept ibidRecip - lift $ deliverAcceptLocal obiidAccept ibidAuthor + (actorRecipID, mfsid, unread) <- getFollowee followee + actorRecipDB <- lift $ getJust actorRecipID + let obidRecip = actorOutbox actorRecipDB + obiidAccept <- lift $ insertAcceptToOutbox senderHash luFollow actorRecip obidRecip + let ibidRecip = actorInbox actorRecipDB + fsid = fromMaybe (actorFollowers actorRecipDB) mfsid + deliverFollowLocal actorSenderID fsid unread obiidFollow obiidAccept ibidRecip + lift $ deliverAcceptLocal obiidAccept ibidSender remotesHttp <- lift $ deliverRemoteDB'' fwdHosts obiidFollow remoteRecips [] return (obiidFollow, doc, remotesHttp) lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidFollow doc remotesHttp return obiidFollow where - parseFollowee (SharerR shr) = Just $ FolloweeSharer shr - parseFollowee (SharerTicketR shr khid) = Just $ FolloweeSharerTicket shr khid - parseFollowee (SharerProposalR shr khid) = Just $ FolloweeSharerProposal shr khid - parseFollowee (ProjectR shr prj) = Just $ FolloweeProject shr prj - parseFollowee (ProjectTicketR shr prj num) = Just $ FolloweeProjectTicket shr prj num - parseFollowee (RepoR shr rp) = Just $ FolloweeRepo shr rp - parseFollowee (RepoProposalR shr rp khid) = Just $ FolloweeRepoProposal shr rp khid - parseFollowee _ = Nothing + parseFollowee (PersonR p) = Just $ FolloweePerson p + parseFollowee (RepoR r) = Just $ FolloweeRepo r + parseFollowee (DeckR d) = Just $ FolloweeDeck d + parseFollowee (LoomR l) = Just $ FolloweeLoom l + parseFollowee (TicketR d t) = Just $ FolloweeTicket d t + parseFollowee (ClothR l c) = Just $ FolloweeCloth l c + parseFollowee _ = Nothing - followeeActor (FolloweeSharer shr) = LocalActorSharer shr - followeeActor (FolloweeSharerTicket shr _) = LocalActorSharer shr - followeeActor (FolloweeSharerProposal shr _) = LocalActorSharer shr - followeeActor (FolloweeProject shr prj) = LocalActorProject shr prj - followeeActor (FolloweeProjectTicket shr prj _) = LocalActorProject shr prj - followeeActor (FolloweeRepo shr rp) = LocalActorRepo shr rp - followeeActor (FolloweeRepoProposal shr rp _) = LocalActorRepo shr rp + followeeActor (FolloweePerson p) = LocalActorPerson p + followeeActor (FolloweeRepo r) = LocalActorRepo r + followeeActor (FolloweeDeck d) = LocalActorDeck d + followeeActor (FolloweeLoom l) = LocalActorLoom l + followeeActor (FolloweeTicket d _) = LocalActorDeck d + followeeActor (FolloweeCloth l _) = LocalActorLoom l - getAuthor shr = do - sid <- getKeyBy404 $ UniqueSharer shr - getBy404 $ UniquePersonIdent sid + getFollowee (FolloweePerson personHash) = do + personID <- decodeKeyHashidE personHash "Follow object: No such person hash" + (,Nothing,True) . personActor <$> getE personID "Follow object: No such person in DB" + getFollowee (FolloweeRepo repoHash) = do + repoID <- decodeKeyHashidE repoHash "Follow object: No such repo hash" + (,Nothing,False) . repoActor <$> getE repoID "Follow object: No such repo in DB" + getFollowee (FolloweeDeck deckHash) = do + deckID <- decodeKeyHashidE deckHash "Follow object: No such deck hash" + (,Nothing,False) . deckActor <$> getE deckID "Follow object: No such deck in DB" + getFollowee (FolloweeLoom loomHash) = do + loomID <- decodeKeyHashidE loomHash "Follow object: No such loom hash" + (,Nothing,False) . loomActor <$> getE loomID "Follow object: No such loom in DB" + getFollowee (FolloweeTicket deckHash ticketHash) = do + deckID <- decodeKeyHashidE deckHash "Follow object: No such deck hash" + actor <- deckActor <$> getE deckID "Follow object: No such deck in DB" + ticketID <- decodeKeyHashidE ticketHash "Follow object: No such ticket hash" + (_, _, Entity _ ticket, _, _) <- do + mticket <- lift $ getTicket deckID ticketID + fromMaybeE mticket "Follow object: No such ticket in DB" + return (actor, Just $ ticketFollowers ticket, False) + getFollowee (FolloweeCloth loomHash clothHash) = do + loomID <- decodeKeyHashidE loomHash "Follow object: No such loom hash" + actor <- loomActor <$> getE loomID "Follow object: No such loom in DB" + clothID <- decodeKeyHashidE clothHash "Follow object: No such cloth hash" + (_, _, Entity _ ticket, _, _, _) <- do + mticket <- lift $ getCloth loomID clothID + fromMaybeE mticket "Follow object: No such cloth in DB" + return (actor, Just $ ticketFollowers ticket, False) - getFollowee (FolloweeSharer shr) = do - msid <- lift $ getKeyBy $ UniqueSharer shr - sid <- fromMaybeE msid "Follow object: No such sharer in DB" - mval <- runMaybeT - $ Left <$> MaybeT (lift $ getValBy $ UniquePersonIdent sid) - <|> Right <$> MaybeT (lift $ getValBy $ UniqueGroup sid) - val <- - fromMaybeE mval $ - "Found non-person non-group sharer: " <> shr2text shr - case val of - Left person -> return (personFollowers person, personInbox person, True, personOutbox person) - Right _group -> throwE "Follow object is a group" - getFollowee (FolloweeSharerTicket shr talkhid) = do - (Entity _ tal, Entity _ lt, _, _, _) <- do - mticket <- lift $ runMaybeT $ do - talid <- decodeKeyHashidM talkhid - MaybeT $ getSharerTicket shr talid - fromMaybeE mticket "Follow object: No such sharer-ticket in DB" - p <- lift $ getJust $ ticketAuthorLocalAuthor tal - return (localTicketFollowers lt, personInbox p, True, personOutbox p) - getFollowee (FolloweeSharerProposal shr talkhid) = do - (Entity _ tal, Entity _ lt, _, _, _, _) <- do - mticket <- lift $ runMaybeT $ do - talid <- decodeKeyHashidM talkhid - MaybeT $ getSharerProposal shr talid - fromMaybeE mticket "Follow object: No such sharer-patch in DB" - p <- lift $ getJust $ ticketAuthorLocalAuthor tal - return (localTicketFollowers lt, personInbox p, True, personOutbox p) - getFollowee (FolloweeProject shr prj) = do - mproject <- lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - MaybeT $ getValBy $ UniqueProject prj sid - project <- fromMaybeE mproject "Follow object: No such project in DB" - 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" - 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 - MaybeT $ getValBy $ UniqueRepo rp sid - repo <- fromMaybeE mrepo "Follow object: No such repo in DB" - return (repoFollowers repo, repoInbox repo, False, repoOutbox repo) - getFollowee (FolloweeRepoProposal shr rp ltkhid) = do - (_, Entity _ r, _, Entity _ lt, _, _, _, _, _) <- do - mticket <- lift $ runMaybeT $ do - ltid <- decodeKeyHashidM ltkhid - MaybeT $ getRepoProposal shr rp ltid - fromMaybeE mticket "Follow object: No such repo-patch in DB" - return (localTicketFollowers lt, repoInbox r, False, repoOutbox r) - - insertFollowToOutbox obid blinded = do - hLocal <- asksSite siteInstanceHost + insertFollowToOutbox senderHash obid blinded = do encodeRouteLocal <- getEncodeRouteLocal - let activity mluAct = Doc hLocal Activity - { activityId = mluAct - , activityActor = encodeRouteLocal $ SharerR shrUser + hLocal <- asksSite siteInstanceHost + now <- liftIO getCurrentTime + obiid <- insertEmptyOutboxItem obid now + obikhid <- encodeKeyHashid obiid + let luFollow = encodeRouteLocal $ PersonOutboxItemR senderHash obikhid + doc = Doc hLocal Activity + { activityId = Just luFollow + , activityActor = encodeRouteLocal $ PersonR senderHash , activityCapability = Nothing , activitySummary = summary , activityAudience = blinded , activitySpecific = FollowActivity follow } - now <- liftIO getCurrentTime - obiid <- insert OutboxItem - { outboxItemOutbox = obid - , outboxItemActivity = - persistJSONObjectFromDoc $ activity Nothing - , outboxItemPublished = now - } - obikhid <- encodeKeyHashid obiid - let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid - doc = activity $ Just luAct update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (obiid, doc, luAct) + return (obiid, doc, luFollow) - deliverFollowLocal pidAuthor fsid unread obiidF obiidA ibidRecip = do - mfid <- lift $ insertUnique $ Follow pidAuthor fsid (not hide) obiidF obiidA - _ <- fromMaybeE mfid "Already following this object" - ibiid <- lift $ insert $ InboxItem unread - lift $ insert_ $ InboxItemLocal ibidRecip obiidF ibiid - - insertAcceptToOutbox luFollow actorRecip obidRecip = do + insertAcceptToOutbox senderHash luFollow actorRecip obidRecip = do now <- liftIO getCurrentTime summary <- TextHtml . TL.toStrict . renderHtml <$> withUrlRenderer [hamlet|

- - #{shr2text shrUser} + + #{username2text $ personUsername personSender} 's follow request accepted by # #{localUriPath $ objUriLocal uObject} @@ -2104,7 +1359,7 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do hLocal <- asksSite siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - let recips = [encodeRouteHome $ SharerR shrUser] + let recips = [encodeRouteHome $ PersonR senderHash] accept mluAct = Doc hLocal Activity { activityId = mluAct , activityActor = objUriLocal uObject @@ -2127,10 +1382,12 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do doc = accept $ Just luAct update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return obiid - where - actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr - actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj - actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp + + deliverFollowLocal aidSender fsid unread obiidF obiidA ibidRecip = do + mfid <- lift $ insertUnique $ Follow aidSender fsid (not hide) obiidF obiidA + _ <- fromMaybeE mfid "Already following this object" + ibiid <- lift $ insert $ InboxItem unread + lift $ insert_ $ InboxItemLocal ibidRecip obiidF ibiid deliverAcceptLocal obiidAccept ibidAuthor = do ibiid <- insert $ InboxItem True @@ -2138,14 +1395,23 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do offerTicketC :: Entity Person - -> Sharer -> Maybe TextHtml -> Audience URIMode -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler OutboxItemId -offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do - let shrUser = sharerIdent sharerUser +offerTicketC (Entity pidUser personUser) summary audience ticket uTarget = do + error "offerTicketC temporarily disabled" + + +{- + senderHash <- encodeKeyHashid pidUser + + + + + + (target, title, desc, source) <- checkOfferTicket shrUser ticket uTarget ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience @@ -2249,6 +1515,17 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept return obiidOffer where + + + + + + + + + + + checkOfferTicket :: ShrIdent -> AP.Ticket URIMode @@ -2259,7 +1536,22 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar , TextHtml , TextPandocMarkdown ) - checkOfferTicket shrUser ticket uTarget = do + checkOfferTicket shrUser??? ticket uTarget = do + + + + + + + + + + + + + + + target <- parseTarget uTarget (muContext, summary, content, source, mmr) <- checkTicket shrUser ticket for_ muContext $ @@ -2273,10 +1565,19 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar then Left <$> do route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route" case route of - ProjectR shr prj -> return $ Left (shr, prj) - RepoR shr rp -> return $ Right (shr, rp) - _ -> throwE "Offer target is local but isn't a project/repo route" + DeckR d t -> return $ Left (d, t) + LoomR l c -> return $ Right (l, c) + _ -> throwE "Offer target is local but isn't a deck/loom route" else return $ Right u + + + + + + + + + checkTicket shrUser (AP.Ticket mlocal attrib mpublished mupdated muContext summary @@ -2376,6 +1677,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar , diffs ) return $ Right (h, lu, Just bundle) + insertOfferToOutbox shrUser now obid blinded = do hLocal <- asksSite siteInstanceHost obiid <- insertEmptyOutboxItem obid now @@ -2473,7 +1775,9 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, makeRecipientSet actors collections) +-} +{- verifyHosterRecip _ _ (Right _) = return () verifyHosterRecip localRecips name (Left wi) = fromMaybeE (verify wi) $ @@ -2490,7 +1794,9 @@ verifyHosterRecip localRecips name (Left wi) = sharerSet <- lookup shr localRecips repoSet <- lookup rp $ localRecipRepoRelated sharerSet guard $ localRecipRepo $ localRecipRepoDirect repoSet +-} +{- workItemRecipSieve wiFollowers (WorkItemDetail ident context author) = let authorC = case author of @@ -2518,24 +1824,32 @@ workItemRecipSieve wiFollowers (WorkItemDetail ident context author) = ) Right _ -> ([], []) in (contextA, authorC ++ ticketC ++ contextC) +-} +{- workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj workItemActor (WorkItemRepoProposal shr rp _) = LocalActorRepo shr rp +-} -actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr -actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj -actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp +actorOutboxItem (LocalActorPerson p) = PersonOutboxItemR p +actorOutboxItem (LocalActorGroup _) = error "No outbox for Group yet" +actorOutboxItem (LocalActorRepo r) = RepoOutboxItemR r +actorOutboxItem (LocalActorDeck d) = DeckOutboxItemR d +actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l offerDepC :: Entity Person - -> Sharer -> Maybe TextHtml -> Audience URIMode -> TicketDependency URIMode -> FedURI -> ExceptT Text Handler OutboxItemId -offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = do +offerDepC (Entity pidUser personUser) summary audience dep uTarget = do + error "offerDepC temporarily disabled" + +{- + let shrUser = sharerIdent sharerUser (parent, child) <- checkDepAndTarget dep uTarget ParsedAudience localRecips remoteRecips blinded fwdHosts <- do @@ -2738,7 +2052,9 @@ offerDepC (Entity pidUser personUser) sharerUser summary audience dep uTarget = update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) +-} +{- insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve obiidAccept = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome @@ -2782,15 +2098,20 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) +-} resolveC :: Entity Person - -> Sharer -> Maybe TextHtml -> Audience URIMode -> Resolve URIMode -> ExceptT Text Handler OutboxItemId -resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObject) = do +resolveC (Entity pidUser personUser) summary audience (Resolve uObject) = do + error "resolveC temporarily disabled" + +{- + + let shrUser = sharerIdent sharerUser object <- parseWorkItem "Resolve object" uObject ParsedAudience localRecips remoteRecips blinded fwdHosts <- do @@ -2895,15 +2216,20 @@ resolveC (Entity pidUser personUser) sharerUser summary audience (Resolve uObjec } tid <- localTicketTicket <$> getJust ltid update tid [TicketStatus =. TSClosed] +-} undoC :: Entity Person - -> Sharer -> Maybe TextHtml -> Audience URIMode -> Undo URIMode -> ExceptT Text Handler OutboxItemId -undoC (Entity _pidUser personUser) sharerUser summary audience undo@(Undo uObject) = do +undoC (Entity _pidUser personUser) summary audience undo@(Undo uObject) = do + error "undoC temporarily disabled" + +{- + + let shrUser = sharerIdent sharerUser object <- parseActivity uObject ParsedAudience localRecips remoteRecips blinded fwdHosts <- do @@ -3048,15 +2374,21 @@ undoC (Entity _pidUser personUser) sharerUser summary audience undo@(Undo uObjec tid <- localTicketTicket <$> getJust ltid update tid [TicketStatus =. TSTodo] return $ Just ltid +-} pushCommitsC - :: (Entity Person, Sharer) + :: Entity Person -> Html -> Push URIMode -> ShrIdent -> RpIdent -> ExceptT Text Handler OutboxItemId -pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = do +pushCommitsC eperson summary push shrRepo rpRepo = do + error "pushCommitsC temporarily disabled" + +{- + + let dont = Authority "dont-do.any-forwarding" Nothing (obiid, doc, remotesHttp) <- runDBExcept $ do (obiid, doc) <- lift $ insertToOutbox @@ -3131,47 +2463,4 @@ pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = do ibiid <- insert $ InboxItem True insert_ $ InboxItemLocal ibid obiid ibiid return remotes - -getFollowersCollection - :: Route App -> AppDB FollowerSetId -> Handler TypedContent -getFollowersCollection here getFsid = do - (locals, remotes, l, r) <- runDB $ do - fsid <- getFsid - (,,,) <$> do pids <- - map (followPerson . entityVal) <$> - selectList - [FollowTarget ==. fsid, FollowPublic ==. True] - [] - sids <- - map (personIdent . entityVal) <$> - selectList [PersonId <-. pids] [] - map (sharerIdent . entityVal) <$> - selectList [SharerId <-. sids] [] - <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do - E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId - E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId - E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId - E.where_ - $ rf E.^. RemoteFollowTarget E.==. E.val fsid - E.&&. rf E.^. RemoteFollowPublic E.==. E.val True - return - ( i E.^. InstanceHost - , ro E.^. RemoteObjectIdent - ) - <*> count [FollowTarget ==. fsid] - <*> count [RemoteFollowTarget ==. fsid] - - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - let followersAP = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ l + r - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = - map (encodeRouteHome . SharerR) locals ++ - map (uncurry ObjURI . bimap E.unValue E.unValue) remotes - } - provideHtmlAndAP followersAP $ redirectToPrettyJSON here +-} diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index bbfa30b..67ede84 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -54,6 +54,7 @@ -- operations. module Vervis.Access ( ObjectAccessStatus (..) + , checkRepoAccess' , checkRepoAccess , checkProjectAccess ) @@ -64,12 +65,15 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Maybe -import Database.Persist.Class (getBy) +import Database.Persist.Class import Database.Persist.Sql (SqlBackend) import Database.Persist.Types (Entity (..)) import qualified Database.Esqueleto as E +import Yesod.Hashids +import Yesod.MonadSite + import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Role @@ -114,17 +118,53 @@ status :: Bool -> ObjectAccessStatus status True = ObjectAccessAllowed status False = ObjectAccessDenied -checkRepoAccess +checkRepoAccess' :: MonadIO m => Maybe PersonId -> ProjectOperation - -> ShrIdent - -> RpIdent + -> RepoId -> ReaderT SqlBackend m ObjectAccessStatus -checkRepoAccess mpid op shr rp = do +checkRepoAccess' mpid op repoID = do mer <- runMaybeT $ do - Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr - MaybeT $ getBy $ UniqueRepo rp sid + repo <- MaybeT $ get repoID + return $ Entity repoID repo + case mer of + Nothing -> return NoSuchObject + Just (Entity rid repo) -> do + role <- do + case mpid of + Just pid -> + fromMaybe User . (<|> asUser repo) <$> asCollab rid pid + Nothing -> pure $ fromMaybe Guest $ asAnon repo + status <$> roleHasAccess role op + where + asCollab rid pid = do + fmap (maybe Developer RoleID . E.unValue . snd) . listToMaybe <$> do + E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.LeftOuterJoin` role) -> do + E.on $ E.just (topic E.^. CollabTopicLocalRepoCollab) E.==. role E.?. CollabRoleLocalCollab + E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&. + recip E.^. CollabRecipLocalPerson E.==. E.val pid + E.limit 1 + return + ( topic E.^. CollabTopicLocalRepoCollab + , role E.?. CollabRoleLocalRole + ) + asUser = fmap RoleID . repoCollabUser + asAnon = fmap RoleID . repoCollabAnon + +checkRepoAccess + :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m)) + => Maybe PersonId + -> ProjectOperation + -> KeyHashid Repo + -> ReaderT SqlBackend m ObjectAccessStatus +checkRepoAccess mpid op repoHash = do + mer <- runMaybeT $ do + repoID <- decodeKeyHashidM repoHash + repo <- MaybeT $ get repoID + return $ Entity repoID repo case mer of Nothing -> return NoSuchObject Just (Entity rid repo) -> do @@ -152,16 +192,16 @@ checkRepoAccess mpid op shr rp = do asAnon = fmap RoleID . repoCollabAnon checkProjectAccess - :: MonadIO m + :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m)) => Maybe PersonId -> ProjectOperation - -> ShrIdent - -> PrjIdent + -> KeyHashid Deck -> ReaderT SqlBackend m ObjectAccessStatus -checkProjectAccess mpid op shr prj = do +checkProjectAccess mpid op deckHash = do mej <- runMaybeT $ do - Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr - MaybeT $ getBy $ UniqueProject prj sid + deckID <- decodeKeyHashidM deckHash + deck <- MaybeT $ get deckID + return $ Entity deckID deck case mej of Nothing -> return NoSuchObject Just (Entity jid project) -> do @@ -176,15 +216,15 @@ checkProjectAccess mpid op shr prj = do asCollab jid pid = do fmap (maybe Developer RoleID . E.unValue . snd) . listToMaybe <$> do E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.LeftOuterJoin` role) -> do - E.on $ E.just (topic E.^. CollabTopicLocalProjectCollab) E.==. role E.?. CollabRoleLocalCollab - E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab + E.on $ E.just (topic E.^. CollabTopicLocalDeckCollab) E.==. role E.?. CollabRoleLocalCollab + E.on $ topic E.^. CollabTopicLocalDeckCollab E.==. recip E.^. CollabRecipLocalCollab E.where_ $ - topic E.^. CollabTopicLocalProjectProject E.==. E.val jid E.&&. + topic E.^. CollabTopicLocalDeckDeck E.==. E.val jid E.&&. recip E.^. CollabRecipLocalPerson E.==. E.val pid E.limit 1 return - ( topic E.^. CollabTopicLocalProjectCollab + ( topic E.^. CollabTopicLocalDeckCollab , role E.?. CollabRoleLocalRole ) - asUser = fmap RoleID . projectCollabUser - asAnon = fmap RoleID . projectCollabAnon + asUser = fmap RoleID . deckCollabUser + asAnon = fmap RoleID . deckCollabAnon diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index aba4289..06990b9 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -14,40 +14,16 @@ -} module Vervis.ActivityPub - ( NoteContext (..) - , parseContext - , parseParent - , getLocalParentMessageId - , getPersonOrGroupId - , getTicketTeam - , getProjectTeam - , getRepoTeam - , getFollowers + ( RemoteRecipient (..) + --, getFollowers , unionRemotes , insertMany' , isInstanceErrorP , isInstanceErrorG - , deliverHttp - , deliverHttpBL - , deliverRemoteDB_J - , deliverRemoteDB_S - , deliverRemoteDB_R - , deliverRemoteHTTP_J - , deliverRemoteHTTP_S - , deliverRemoteHTTP_R - , checkForward - , parseTarget + --, checkDep --, getProjectAndDeps - , deliverRemoteDB' - , deliverRemoteDB'' - , deliverRemoteHttp - , deliverRemoteHttp' - , serveCommit - , deliverLocal - , RemoteRecipient (..) - , deliverLocal' - , insertRemoteActivityToLocalInboxes + , provideEmptyCollection , insertEmptyOutboxItem , verifyContentTypeAP @@ -55,9 +31,10 @@ module Vervis.ActivityPub , parseActivity , parseActivityURI , getActivity - , ActorEntity (..) - , getOutboxActorEntity - , actorEntityPath + --, ActorEntity (..) + , getLocalActor + --, getOutboxActorEntity + --, actorEntityPath , outboxItemRoute ) where @@ -110,7 +87,6 @@ import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub hiding (Author (..), Ticket, Project (..), Repo, ActorLocal (..)) import Yesod.ActivityPub import Yesod.MonadSite import Yesod.FedURI @@ -127,106 +103,22 @@ import Database.Persist.Local import qualified Data.Patch.Local as P -import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Foundation import Vervis.Model -import Vervis.Model.Ident +import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings import Vervis.Time -import Vervis.Widget.Repo -import Vervis.Widget.Sharer -data NoteContext - = NoteContextSharerTicket ShrIdent TicketAuthorLocalId Bool - | NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId - | NoteContextRepoProposal ShrIdent RpIdent LocalTicketId - deriving Eq - -parseContext - :: (MonadSite m, SiteEnv m ~ App) - => FedURI - -> ExceptT Text m (Either NoteContext FedURI) -parseContext uContext = do - let ObjURI hContext luContext = uContext - local <- hostIsLocal hContext - if local - then Left <$> do - route <- case decodeRouteLocal luContext of - Nothing -> throwE "Local context isn't a valid route" - Just r -> return r - case route of - SharerTicketR shr talkhid -> - flip (NoteContextSharerTicket shr) False <$> - decodeKeyHashidE talkhid "Note context invalid talkhid" - SharerProposalR shr talkhid -> - flip (NoteContextSharerTicket shr) True <$> - decodeKeyHashidE talkhid "Note context invalid talkhid" - ProjectTicketR shr prj ltkhid -> - NoteContextProjectTicket shr prj <$> - decodeKeyHashidE ltkhid "Note context invalid ltkhid" - RepoProposalR shr rp ltkhid -> - NoteContextRepoProposal shr rp <$> - decodeKeyHashidE ltkhid "Note context invalid ltkhid" - _ -> throwE "Local context isn't a ticket/patch route" - else return $ Right uContext - -parseParent - :: (MonadSite m, SiteEnv m ~ App) - => FedURI - -> ExceptT Text m (Either (ShrIdent, LocalMessageId) FedURI) -parseParent uParent = do - let ObjURI hParent luParent = uParent - local <- hostIsLocal hParent - if local - then Left <$> do - route <- case decodeRouteLocal luParent of - Nothing -> throwE "Local parent isn't a valid route" - Just r -> return r - case route of - MessageR shr lmkhid -> - (shr,) <$> - decodeKeyHashidE lmkhid - "Local parent has non-existent message \ - \hashid" - _ -> throwE "Local parent isn't a message route" - else return $ Right uParent - -getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId -getLocalParentMessageId did shr lmid = do - mlm <- lift $ get lmid - lm <- fromMaybeE mlm "Local parent: no such lmid" - p <- lift $ getJust $ localMessageAuthor lm - s <- lift $ getJust $ personIdent p - unless (shr == sharerIdent s) $ throwE "Local parent: No such message, lmid mismatches sharer" - let mid = localMessageRest lm - m <- lift $ getJust mid - unless (messageRoot m == did) $ - throwE "Local parent belongs to a different discussion" - return mid - -getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId) -getPersonOrGroupId sid = do - mpid <- getKeyBy $ UniquePersonIdent sid - mgid <- getKeyBy $ UniqueGroup sid - requireEitherM mpid mgid - "Found sharer that is neither person nor group" - "Found sharer that is both person and group" - -getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)]) -getTicketTeam sid = do - id_ <- getPersonOrGroupId sid - (,[]) <$> case id_ of - Left pid -> return [pid] - Right gid -> - map (groupMemberPerson . entityVal) <$> - selectList [GroupMemberGroup ==. gid] [Asc GroupMemberPerson] - -getProjectTeam = getTicketTeam - -getRepoTeam = getTicketTeam +data RemoteRecipient = RemoteRecipient + { remoteRecipientActor :: RemoteActorId + , remoteRecipientId :: LocalURI + , remoteRecipientInbox :: LocalURI + , remoteRecipientErrorSince :: Maybe UTCTime + } +{- getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)]) getFollowers fsid = do local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson] @@ -257,6 +149,7 @@ getFollowers fsid = do groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples where toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), RemoteRecipient raid luA luI ms) +-} unionRemotes :: [((InstanceId, Host), NonEmpty RemoteRecipient)] @@ -282,217 +175,15 @@ isInstanceErrorHttp (HttpExceptionRequest _ hec) = _ -> False _ -> False -isInstanceErrorP (APPostErrorSig _) = False -isInstanceErrorP (APPostErrorHTTP he) = isInstanceErrorHttp he +isInstanceErrorP (AP.APPostErrorSig _) = False +isInstanceErrorP (AP.APPostErrorHTTP he) = isInstanceErrorHttp he isInstanceErrorG Nothing = False isInstanceErrorG (Just e) = case e of - APGetErrorHTTP he -> isInstanceErrorHttp he - APGetErrorJSON _ -> False - APGetErrorContentType _ -> False - -deliverHttp - :: (MonadSite m, SiteEnv m ~ App) - => Doc Activity URIMode - -> Maybe LocalURI - -> Host - -> LocalURI - -> m (Either APPostError (Response ())) -deliverHttp doc mfwd h luInbox = - deliverActivity (ObjURI h luInbox) (ObjURI h <$> mfwd) doc - -deliverHttpBL - :: (MonadSite m, SiteEnv m ~ App) - => BL.ByteString - -> Maybe LocalURI - -> Host - -> LocalURI - -> m (Either APPostError (Response ())) -deliverHttpBL body mfwd h luInbox = - deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body - -deliverRemoteDB_ - :: (MonadIO m, PersistRecordBackend fwder SqlBackend) - => (ForwardingId -> Key sender -> fwder) - -> BL.ByteString - -> RemoteActivityId - -> Key sender - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] -deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do - let body' = BL.toStrict body - makeFwd (RemoteRecipient raid _ _ msince) = - Forwarding raid ractid body' sig (isNothing msince) - fetchedDeliv <- for recips $ bitraverse pure $ \ rs -> do - fwds <- insertMany' makeFwd rs - insertMany' (flip makeFwder senderKey . snd) fwds - return $ takeNoError5 fetchedDeliv - where - takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs) - takeNoError5 = takeNoError noError - where - noError ((RemoteRecipient ak luA luI Nothing , fwid), fwrid) = Just (ak, luA, luI, fwid, fwrid) - noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing - -deliverRemoteDB_J - :: MonadIO m - => BL.ByteString - -> RemoteActivityId - -> ProjectId - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))] -deliverRemoteDB_J = deliverRemoteDB_ ForwarderProject - -deliverRemoteDB_S - :: MonadIO m - => BL.ByteString - -> RemoteActivityId - -> SharerId - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))] -deliverRemoteDB_S = deliverRemoteDB_ ForwarderSharer - -deliverRemoteDB_R - :: MonadIO m - => BL.ByteString - -> RemoteActivityId - -> RepoId - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))] -deliverRemoteDB_R = deliverRemoteDB_ ForwarderRepo - -deliverRemoteHTTP' - :: (MonadSite m, SiteEnv m ~ App, PersistRecordBackend fwder SqlBackend) - => UTCTime - -> LocalActor - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] - -> m () -deliverRemoteHTTP' now sender body sig fetched = do - let deliver h inbox = - forwardActivity (ObjURI h inbox) sig (renderLocalActor sender) body - traverse_ (fork . deliverFetched deliver now) fetched - where - fork = forkWorker "Inbox forwarding to remote members of local collections: delivery failed" - deliverFetched deliver now ((_, h), recips@(r :| rs)) = do - let (raid, _luActor, luInbox, fwid, forwarderKey) = r - e <- deliver h luInbox - let e' = case e of - Left err -> - if isInstanceErrorP err - then Nothing - else Just False - Right _resp -> Just True - case e' of - Nothing -> runSiteDB $ do - let recips' = NE.toList recips - updateWhere [RemoteActorId <-. map fst5 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - updateWhere [ForwardingId <-. map fourth5 recips'] [ForwardingRunning =. False] - Just success -> do - runSiteDB $ - if success - then do - delete forwarderKey - delete fwid - else do - updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - update fwid [ForwardingRunning =. False] - for_ rs $ \ (raid, _luActor, luInbox, fwid, forwarderKey) -> - fork $ do - e <- deliver h luInbox - runSiteDB $ - case e of - Left _err -> do - updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - update fwid [ForwardingRunning =. False] - Right _resp -> do - delete forwarderKey - delete fwid - -deliverRemoteHTTP_J - :: (MonadSite m, SiteEnv m ~ App) - => UTCTime - -> ShrIdent - -> PrjIdent - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))] - -> m () -deliverRemoteHTTP_J now shr prj = - deliverRemoteHTTP' now $ LocalActorProject shr prj - -deliverRemoteHTTP_S - :: (MonadSite m, SiteEnv m ~ App) - => UTCTime - -> ShrIdent - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))] - -> m () -deliverRemoteHTTP_S now shr = deliverRemoteHTTP' now $ LocalActorSharer shr - -deliverRemoteHTTP_R - :: (MonadSite m, SiteEnv m ~ App) - => UTCTime - -> ShrIdent - -> RpIdent - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))] - -> m () -deliverRemoteHTTP_R now shr rp = - deliverRemoteHTTP' now $ LocalActorRepo shr rp - -checkForward recip = join <$> do - let hSig = hForwardingSignature - msig <- maybeHeader hSig - for msig $ \ sig -> do - _proof <- withExceptT (T.pack . displayException) $ ExceptT $ - let requires = [hDigest, hActivityPubForwarder] - in prepareToVerifyHttpSigWith hSig False requires [] Nothing - forwarder <- requireHeader hActivityPubForwarder - renderUrl <- getUrlRender - return $ - if forwarder == encodeUtf8 (renderUrl $ renderLocalActor recip) - then Just sig - else Nothing - where - maybeHeader n = do - let n' = decodeUtf8 $ CI.original n - hs <- lookupHeaders n - case hs of - [] -> return Nothing - [h] -> return $ Just h - _ -> throwE $ n' <> " multiple headers found" - requireHeader n = do - let n' = decodeUtf8 $ CI.original n - mh <- maybeHeader n - case mh of - Nothing -> throwE $ n' <> " header not found" - Just h -> return h - -parseTarget u = do - let ObjURI h lu = u - (shr, prj) <- parseProject lu - return (h, shr, prj) - where - parseProject lu = do - route <- case decodeRouteLocal lu of - Nothing -> throwE "Expected project route, got invalid route" - Just r -> return r - case route of - ProjectR shr prj -> return (shr, prj) - _ -> throwE "Expected project route, got non-project route" + AP.APGetErrorHTTP he -> isInstanceErrorHttp he + AP.APGetErrorJSON _ -> False + AP.APGetErrorContentType _ -> False {- checkDep hProject shrProject prjProject u = do @@ -529,674 +220,17 @@ getProjectAndDeps shr prj {-deps-} = do return (sid, jid, projectInbox j, projectFollowers j{-, tids-}) -} -data Recip - = RecipRA (Entity RemoteActor) - | RecipURA (Entity UnfetchedRemoteActor) - | RecipRC (Entity RemoteCollection) - -deliverRemoteDB' - :: Host - -> OutboxItemId - -> [(Host, NonEmpty LocalURI)] - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> AppDB - ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - ) -deliverRemoteDB' hContext = deliverRemoteDB'' [hContext] - -deliverRemoteDB'' - :: MonadIO m - => [Host] - -> OutboxItemId - -> [(Host, NonEmpty LocalURI)] - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - ) -deliverRemoteDB'' hContexts obid recips known = do - recips' <- for recips $ \ (h, lus) -> do - let lus' = NE.nub lus - (iid, inew) <- idAndNew <$> insertBy' (Instance h) - if inew - then return ((iid, h), (Nothing, Nothing, Just lus')) - else do - es <- for lus' $ \ lu -> do - ma <- runMaybeT $ do - Entity roid ro <- MaybeT $ getBy $ UniqueRemoteObject iid lu - recip <- RecipRA <$> MaybeT (getBy $ UniqueRemoteActor roid) - <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor roid) - <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection roid) - return (ro, recip) - return $ - case ma of - Nothing -> Just $ Left lu - Just (ro, r) -> - case r of - RecipRA (Entity raid ra) -> Just $ Right $ Left $ RemoteRecipient raid (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra) - RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura) - RecipRC _ -> Nothing - let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es - (fetched, unfetched) = partitionEithers newKnown - return ((iid, h), (nonEmpty fetched, nonEmpty unfetched, nonEmpty unknown)) - let moreKnown = mapMaybe (\ (i, (f, _, _)) -> (i,) <$> f) recips' - unfetched = mapMaybe (\ (i, (_, uf, _)) -> (i,) <$> uf) recips' - stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips' - allFetched = unionRemotes known moreKnown - fetchedDeliv <- for allFetched $ \ (i, rs) -> - let fwd = snd i `elem` hContexts - in (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs - unfetchedDeliv <- for unfetched $ \ (i, rs) -> - let fwd = snd i `elem` hContexts - in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs - unknownDeliv <- for stillUnknown $ \ (i, lus) -> do - -- TODO maybe for URA insertion we should do insertUnique? - ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus - rs <- insertMany' (\ (_lu, roid) -> UnfetchedRemoteActor roid Nothing) ros - let fwd = snd i `elem` hContexts - (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs - return - ( takeNoError4 fetchedDeliv - , takeNoError3 unfetchedDeliv - , map - (second $ NE.map $ \ (((lu, _roid), ak), dlk) -> (ak, lu, dlk)) - unknownDeliv - ) - where - takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs) - takeNoError3 = takeNoError noError - where - noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk) - noError ((_ , _ , Just _ ), _ ) = Nothing - takeNoError4 = takeNoError noError - where - noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk) - noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing - -deliverRemoteHttp - :: Host - -> OutboxItemId - -> Doc Activity URIMode - -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - ) - -> Worker () -deliverRemoteHttp hContext = deliverRemoteHttp' [hContext] - -deliverRemoteHttp' - :: [Host] - -> OutboxItemId - -> Doc Activity URIMode - -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - ) - -> Worker () -deliverRemoteHttp' hContexts obid doc (fetched, unfetched, unknown) = do - logDebug' "Starting" - let deliver fwd h inbox = do - let fwd' = if h `elem` hContexts then Just fwd else Nothing - (isJust fwd',) <$> deliverHttp doc fwd' h inbox - now <- liftIO getCurrentTime - logDebug' $ - "Launching fetched " <> showHosts fetched - traverse_ (fork . deliverFetched deliver now) fetched - logDebug' $ - "Launching unfetched " <> showHosts unfetched - traverse_ (fork . deliverUnfetched deliver now) unfetched - logDebug' $ - "Launching unknown " <> showHosts unknown - traverse_ (fork . deliverUnfetched deliver now) unknown - logDebug' "Done (async delivery may still be running)" - where - showHosts = T.pack . show . map (renderAuthority . snd . fst) - logDebug' t = logDebug $ prefix <> t - where - prefix = - T.concat - [ "Outbox POST handler: deliverRemoteHttp obid#" - , T.pack $ show $ fromSqlKey obid - , ": " - ] - fork = forkWorker "Outbox POST handler: HTTP delivery" - deliverFetched deliver now ((_, h), recips@(r :| rs)) = do - logDebug'' "Starting" - let (raid, luActor, luInbox, dlid) = r - (_, e) <- deliver luActor h luInbox - e' <- case e of - Left err -> do - logError $ T.concat - [ "Outbox DL delivery #", T.pack $ show dlid - , " error for <", renderObjURI $ ObjURI h luActor - , ">: ", T.pack $ displayException err - ] - return $ - if isInstanceErrorP err - then Nothing - else Just False - Right _resp -> return $ Just True - case e' of - Nothing -> runSiteDB $ do - let recips' = NE.toList recips - updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False] - Just success -> do - runSiteDB $ - if success - then delete dlid - else do - updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - update dlid [DeliveryRunning =. False] - for_ rs $ \ (raid, luActor, luInbox, dlid) -> - fork $ do - (_, e) <- deliver luActor h luInbox - runSiteDB $ - case e of - Left err -> do - logError $ T.concat - [ "Outbox DL delivery #", T.pack $ show dlid - , " error for <", renderObjURI $ ObjURI h luActor - , ">: ", T.pack $ displayException err - ] - updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - update dlid [DeliveryRunning =. False] - Right _resp -> delete dlid - where - logDebug'' t = logDebug' $ T.concat ["deliverFetched ", renderAuthority h, t] - deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do - logDebug'' "Starting" - let (uraid, luActor, udlid) = r - e <- fetchRemoteActor iid h luActor - let e' = case e of - Left err -> Just Nothing - Right (Left err) -> - if isInstanceErrorG err - then Nothing - else Just Nothing - Right (Right mera) -> Just $ Just mera - case e' of - Nothing -> runSiteDB $ do - let recips' = NE.toList recips - updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] - updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False] - Just mmera -> do - for_ rs $ \ (uraid, luActor, udlid) -> - fork $ do - e <- fetchRemoteActor iid h luActor - case e of - Right (Right mera) -> - case mera of - Nothing -> runSiteDB $ delete udlid - Just (Entity raid ra) -> do - (fwd, e') <- deliver luActor h $ remoteActorInbox ra - runSiteDB $ - case e' of - Left _ -> do - updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - delete udlid - insert_ $ Delivery raid obid fwd False - Right _ -> delete udlid - _ -> runSiteDB $ do - updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] - update udlid [UnlinkedDeliveryRunning =. False] - case mmera of - Nothing -> runSiteDB $ do - updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] - update udlid [UnlinkedDeliveryRunning =. False] - Just mera -> - case mera of - Nothing -> runSiteDB $ delete udlid - Just (Entity raid ra) -> do - (fwd, e'') <- deliver luActor h $ remoteActorInbox ra - runSiteDB $ - case e'' of - Left _ -> do - updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - delete udlid - insert_ $ Delivery raid obid fwd False - Right _ -> delete udlid - where - logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", renderAuthority h, t] - -serveCommit - :: ShrIdent - -> RpIdent - -> Text - -> P.Patch - -> [Text] - -> Handler TypedContent -serveCommit shr rp ref patch parents = do - (msharerWritten, msharerCommitted) <- runDB $ (,) - <$> getSharer (patchWritten patch) - <*> maybe (pure Nothing) getSharer (patchCommitted patch) - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - let (author, written) = patchWritten patch - mcommitter = patchCommitted patch - patchAP = AP.Commit - { commitId = encodeRouteLocal $ RepoCommitR shr rp ref - , commitRepository = encodeRouteLocal $ RepoR shr rp - , commitAuthor = - makeAuthor encodeRouteHome msharerWritten author - , commitCommitter = - makeAuthor encodeRouteHome msharerCommitted . fst <$> - mcommitter - , commitTitle = patchTitle patch - , commitHash = Hash $ encodeUtf8 ref - , commitDescription = - let desc = patchDescription patch - in if T.null desc - then Nothing - else Just desc - , commitWritten = written - , commitCommitted = snd <$> patchCommitted patch - } - provideHtmlAndAP patchAP $ - let number = zip ([1..] :: [Int]) - in $(widgetFile "repo/patch") - where - getSharer (author, _time) = do - mp <- getBy $ UniquePersonEmail $ authorEmail author - for mp $ \ (Entity _ person) -> getJust $ personIdent person - makeAuthor _ Nothing author = Left AP.Author - { AP.authorName = authorName author - , AP.authorEmail = authorEmail author - } - makeAuthor encodeRouteHome (Just sharer) _ = - Right $ encodeRouteHome $ SharerR $ sharerIdent sharer - --- | Given a list of local recipients, which may include actors and --- collections, --- --- * Insert activity to inboxes of actors --- * If the author's follower collection is listed, insert activity to the --- local members and return the remote members --- * Ignore other collections -deliverLocal - :: ShrIdent - -> InboxId - -> FollowerSetId - -> OutboxItemId - -> LocalRecipientSet - -> AppDB - [ ( (InstanceId, Host) - , NonEmpty RemoteRecipient - ) - ] -deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = deliverLocal' True (LocalActorSharer shrAuthor) ibidAuthor obiid . localRecipSieve sieve True - where - sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [] [] [])] - -data RemoteRecipient = RemoteRecipient - { remoteRecipientActor :: RemoteActorId - , remoteRecipientId :: LocalURI - , remoteRecipientInbox :: LocalURI - , remoteRecipientErrorSince :: Maybe UTCTime - } - --- | Given a list of local recipients, which may include actors and --- collections, --- --- * Insert activity to inboxes of actors --- * If collections are listed, insert activity to the local members and return --- the remote members -insertActivityToLocalInboxes - :: ( MonadSite m - , YesodHashids (SiteEnv m) - , PersistRecordBackend record SqlBackend - ) - => (InboxId -> InboxItemId -> record) - -- ^ Database record to insert as an new inbox item to each inbox - -> Bool - -- ^ Whether to deliver to collection only if owner actor is addressed - -> Maybe LocalActor - -- ^ An actor whose collections are excluded from requiring an owner, i.e. - -- even if owner is required, this actor's collections will be delivered - -- to, even if this actor isn't addressed. This is meant to be the - -- activity's author. - -> Maybe InboxId - -- ^ A user person's inbox to exclude from delivery, even if this person is - -- listed in the recipient set. This is meant to be the activity's - -- author. - -> LocalRecipientSet - -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] -insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do - ibidsSharer <- deleteAuthor <$> getSharerInboxes recips - ibidsOther <- concat <$> traverse getOtherInboxes recips - - (ibidsFollowers, remotesFollowers) <- do - fsidsSharer <- getSharerFollowerSets recips - fsidsOther <- concat <$> traverse getOtherFollowerSets recips - let fsids = fsidsSharer ++ fsidsOther - (,) <$> getLocalFollowers fsids <*> getRemoteFollowers fsids - - ibidsTeams <- foldl' LO.union [] <$> traverse getTeams recips - - let ibids = deleteAuthor (ibidsFollowers `LO.union` ibidsTeams `LO.union` ibidsSharer) ++ ibidsOther - ibiids <- insertMany $ replicate (length ibids) $ InboxItem True - insertMany_ $ zipWith makeInboxItem ibids ibiids - return remotesFollowers - where - isAuthor :: LocalActor -> Bool - isAuthor = - case mauthor of - Nothing -> const False - Just author -> (== author) - - deleteAuthor :: [InboxId] -> [InboxId] - deleteAuthor = - case mibidAuthor of - Nothing -> id - Just ibidAuthor -> L.delete ibidAuthor - - getSharerInboxes - :: MonadIO m => LocalRecipientSet -> ReaderT SqlBackend m [InboxId] - getSharerInboxes sharers = do - let shrs = - [shr | (shr, s) <- sharers - , localRecipSharer $ localRecipSharerDirect s - ] - sids <- selectKeysList [SharerIdent <-. shrs] [] - map (personInbox . entityVal) <$> selectList [PersonIdent <-. sids] [Asc PersonInbox] - - getOtherInboxes - :: MonadIO m - => (ShrIdent, LocalSharerRelatedSet) -> ReaderT SqlBackend m [InboxId] - getOtherInboxes (shr, LocalSharerRelatedSet _ _ _ projects repos) = do - msid <- getKeyBy $ UniqueSharer shr - case msid of - Nothing -> return [] - Just sid -> - (++) - <$> getProjectInboxes sid projects - <*> getRepoInboxes sid repos - where - getProjectInboxes sid projects = - let prjs = - [prj | (prj, j) <- projects - , localRecipProject $ localRecipProjectDirect j - ] - 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 - , localRecipRepo $ localRecipRepoDirect r - ] - in map (repoInbox . entityVal) <$> - selectList [RepoSharer ==. sid, RepoIdent <-. rps] [] - - getSharerFollowerSets - :: MonadIO m - => LocalRecipientSet -> ReaderT SqlBackend m [FollowerSetId] - getSharerFollowerSets sharers = do - let shrs = - [shr | (shr, s) <- sharers - , let d = localRecipSharerDirect s - in localRecipSharerFollowers d && - (localRecipSharer d || not requireOwner || isAuthor (LocalActorSharer shr)) - ] - sids <- selectKeysList [SharerIdent <-. shrs] [] - map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] [] - - getOtherFollowerSets - :: (MonadSite m, YesodHashids (SiteEnv m)) - => (ShrIdent, LocalSharerRelatedSet) - -> ReaderT SqlBackend m [FollowerSetId] - getOtherFollowerSets (shr, LocalSharerRelatedSet _ tickets patches projects repos) = do - msid <- getKeyBy $ UniqueSharer shr - case msid of - Nothing -> return [] - Just sid -> do - mpid <- getKeyBy $ UniquePersonIdent sid - (\ tp j r -> map E.unValue tp ++ j ++ r) - <$> case mpid of - Nothing -> pure [] - Just pid -> getSharerTicketFollowerSets pid tickets patches - <*> getProjectFollowerSets sid projects - <*> getRepoFollowerSets sid repos - where - getSharerTicketFollowerSets pid tickets patches = do - let talkhids = - [talkhid | (talkhid, t) <- tickets - , localRecipTicketFollowers t - ] - ++ - [talkhid | (talkhid, p) <- patches - , localRecipPatchFollowers p - ] - talids <- catMaybes <$> traverse decodeKeyHashid talkhids - E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup) -> do - E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor - E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId - E.where_ $ - tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. - E.isNothing (tup E.?. TicketUnderProjectId) - return $ lt E.^. LocalTicketFollowers - getProjectFollowerSets sid projects = do - let prjsJ = - [prj | (prj, j) <- projects - , let d = localRecipProjectDirect j - in localRecipProjectFollowers d && - (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj)) - ] - fsidsJ <- - 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 - [ (prj, localRecipProjectTicketRelated j) - | (prj, j) <- projects - , localRecipProject (localRecipProjectDirect j) || isAuthor (LocalActorProject shr prj) - ] - else - map (second localRecipProjectTicketRelated) projects - fsidssT <- for prjsT $ \ (prj, tickets) -> do - mjid <- getKeyBy $ UniqueProject prj sid - case mjid of - Nothing -> return [] - Just jid -> getTicketFollowerSets jid tickets - return $ fsidsJ ++ map E.unValue (concat fsidssT) - where - getTicketFollowerSets jid tickets = do - let ltkhids = - [ltkhid | (ltkhid, t) <- tickets - , localRecipTicketFollowers t - ] - ltids <- catMaybes <$> traverse decodeKeyHashid ltkhids - E.select $ E.from $ \ (lt `E.InnerJoin` t `E.InnerJoin` tcl `E.InnerJoin` tpl `E.LeftOuterJoin` tup `E.LeftOuterJoin` tar) -> do - E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket - E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tup E.?. TicketUnderProjectProject - E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext - E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket - E.on $ lt E.^. LocalTicketTicket E.==. t E.^. TicketId - E.where_ $ - tpl E.^. TicketProjectLocalProject E.==. E.val jid E.&&. - E.not_ - ( E.isNothing (tup E.?. TicketUnderProjectId) E.&&. - E.isNothing (tar E.?. TicketAuthorRemoteId) - ) - return $ lt E.^. LocalTicketFollowers - getRepoFollowerSets sid repos = do - let rpsR = - [rp | (rp, r) <- repos - , let d = localRecipRepoDirect r - in localRecipRepoFollowers d && - (localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp)) - ] - fsidsR <- - map (repoFollowers . entityVal) <$> - selectList [RepoSharer ==. sid, RepoIdent <-. rpsR] [] - let rpsP = - if requireOwner - then - [ (rp, localRecipRepoProposalRelated r) - | (rp, r) <- repos - , localRecipRepo (localRecipRepoDirect r) || isAuthor (LocalActorRepo shr rp) - ] - else - map (second localRecipRepoProposalRelated) repos - fsidssP <- for rpsP $ \ (rp, patches) -> do - mrid <- getKeyBy $ UniqueRepo rp sid - case mrid of - Nothing -> return [] - Just rid -> getPatchFollowerSets rid patches - return $ fsidsR ++ map E.unValue (concat fsidssP) - where - getPatchFollowerSets rid patches = do - let ltkhids = - [ltkhid | (ltkhid, p) <- patches - , localRecipPatchFollowers p - ] - ltids <- catMaybes <$> traverse decodeKeyHashid ltkhids - E.select $ E.from $ \ (lt `E.InnerJoin` t `E.InnerJoin` tcl `E.InnerJoin` trl `E.LeftOuterJoin` tup `E.LeftOuterJoin` tar) -> do - E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket - E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tup E.?. TicketUnderProjectProject - E.on $ tcl E.^. TicketContextLocalId E.==. trl E.^. TicketRepoLocalContext - E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket - E.on $ lt E.^. LocalTicketTicket E.==. t E.^. TicketId - E.where_ $ - trl E.^. TicketRepoLocalRepo E.==. E.val rid E.&&. - E.not_ - ( E.isNothing (tup E.?. TicketUnderProjectId) E.&&. - E.isNothing (tar E.?. TicketAuthorRemoteId) - ) - return $ lt E.^. LocalTicketFollowers - - getLocalFollowers - :: MonadIO m => [FollowerSetId] -> ReaderT SqlBackend m [InboxId] - getLocalFollowers fsids = do - pids <- - map (followPerson . entityVal) <$> - selectList [FollowTarget <-. fsids] [] - map (personInbox . entityVal) <$> - selectList [PersonId <-. pids] [Asc PersonInbox] - - getRemoteFollowers - :: MonadIO m - => [FollowerSetId] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty RemoteRecipient)] - getRemoteFollowers fsids = - fmap groupRemotes $ - E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do - E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId - E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId - E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId - E.where_ $ rf E.^. RemoteFollowTarget `E.in_` E.valList fsids - E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId] - return - ( i E.^. InstanceId - , i E.^. InstanceHost - , ra E.^. RemoteActorId - , ro E.^. RemoteObjectIdent - , ra E.^. RemoteActorInbox - , ra E.^. RemoteActorErrorSince - ) - where - groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples - where - toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms) - - getTeams - :: MonadIO m - => (ShrIdent, LocalSharerRelatedSet) -> ReaderT SqlBackend m [InboxId] - getTeams (shr, LocalSharerRelatedSet _ tickets _ projects repos) = do - msid <- getKeyBy $ UniqueSharer shr - case msid of - Nothing -> return [] - Just sid -> do - mpid <- getKeyBy $ UniquePersonIdent sid - (\ t j r -> t `LO.union` j `LO.union` r) - <$> case mpid of - Nothing -> pure [] - Just pid -> getSharerTicketTeams pid tickets - <*> getProjectTeams sid projects - <*> getRepoTeams sid repos - where - getSharerTicketTeams _pid _tickets = pure [] - getProjectTeams sid projects = do - let prjs = - [prj | (prj, LocalProjectRelatedSet d ts) <- projects - , (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj)) && - (localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts) - ] - jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] - pids <- fmap (map E.unValue) $ E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do - E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab - E.where_ $ topic E.^. CollabTopicLocalProjectProject `E.in_` E.valList jids - return $ recip E.^. CollabRecipLocalPerson - map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] - getRepoTeams sid repos = do - let rps = - [rp | (rp, r) <- repos - , let d = localRecipRepoDirect r - in localRecipRepoTeam d && - (localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp)) - ] - rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] [] - pids <- fmap (map E.unValue) $ E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do - E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab - E.where_ $ topic E.^. CollabTopicLocalRepoRepo `E.in_` E.valList rids - return $ recip E.^. CollabRecipLocalPerson - map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] - --- | Given a list of local recipients, which may include actors and --- collections, --- --- * Insert activity to inboxes of actors --- * If collections are listed, insert activity to the local members and return --- the remote members -deliverLocal' - :: (MonadSite m, YesodHashids (SiteEnv m)) - => Bool -- ^ Whether to deliver to collection only if owner actor is addressed - -> LocalActor - -> InboxId - -> OutboxItemId - -> LocalRecipientSet - -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] -deliverLocal' requireOwner author ibidAuthor obiid = - insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just ibidAuthor) - where - makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid - -insertRemoteActivityToLocalInboxes - :: (MonadSite m, YesodHashids (SiteEnv m)) - => Bool - -> RemoteActivityId - -> LocalRecipientSet - -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] -insertRemoteActivityToLocalInboxes requireOwner ractid = - insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing - where - makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid - -provideEmptyCollection :: CollectionType -> Route App -> Handler TypedContent +provideEmptyCollection :: AP.CollectionType -> Route App -> Handler TypedContent provideEmptyCollection typ here = do encodeRouteLocal <- getEncodeRouteLocal - let coll = Collection - { collectionId = encodeRouteLocal here - , collectionType = typ - , collectionTotalItems = Just 0 - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = [] :: [Text] + let coll = AP.Collection + { AP.collectionId = encodeRouteLocal here + , AP.collectionType = typ + , AP.collectionTotalItems = Just 0 + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = [] :: [Text] } provideHtmlAndAP coll $ redirectToPrettyJSON here @@ -1204,7 +238,8 @@ insertEmptyOutboxItem obid now = do h <- asksSite siteInstanceHost insert OutboxItem { outboxItemOutbox = obid - , outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity + , outboxItemActivity = + persistJSONObjectFromDoc $ AP.Doc h AP.emptyActivity , outboxItemPublished = now } @@ -1245,25 +280,26 @@ parseActivityURI name u@(ObjURI h lu) = do fromMaybeE (decodeRouteLocal lu) (name <> " is local but isn't a valid route") - case route of - SharerOutboxItemR shr obikhid -> - (LocalActorSharer shr,) <$> decodeKH obikhid - ProjectOutboxItemR shr prj obikhid -> - (LocalActorProject shr prj,) <$> decodeKH obikhid - RepoOutboxItemR shr rp obikhid -> - (LocalActorRepo shr rp,) <$> decodeKH obikhid - _ -> - throwE $ - name <> " is a valid local route, but isn't an outbox \ - \item route" + (actor, outboxItemHash) <- + fromMaybeE + (parseOutboxItemRoute route) + (name <> " is a valid local route, but isn't an outbox item route") + outboxItemID <- + decodeKeyHashidE outboxItemHash (name <> ": Invalid obikhid") + return (actor, outboxItemID) else return $ Right u where - decodeKH obikhid = decodeKeyHashidE obikhid (name <> ": Invalid obikhid") + parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i) + parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i) + parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i) + parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i) + parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i) + parseOutboxItemRoute _ = Nothing parseActivity = parseActivityURI "Activity URI" getActivity (Left (actor, obiid)) = Just . Left <$> do - obid <- getActorOutbox actor + obid <- actorOutbox <$> getActor' actor obi <- do mobi <- lift $ get obiid fromMaybeE mobi "No such obiid" @@ -1271,41 +307,58 @@ getActivity (Left (actor, obiid)) = Just . Left <$> do throwE "Actor/obiid mismatch" return (actor, obiid) where - getActorOutbox (LocalActorSharer shr) = do - sid <- do - msid <- lift $ getKeyBy $ UniqueSharer shr - fromMaybeE msid "No such sharer" - p <- do - mp <- lift $ getValBy $ UniquePersonIdent sid - fromMaybeE mp "No such person" - return $ personOutbox p - getActorOutbox (LocalActorProject shr prj) = do - sid <- do - msid <- lift $ getKeyBy $ UniqueSharer shr - fromMaybeE msid "No such sharer" - j <- do - mj <- lift $ getValBy $ UniqueProject prj sid - fromMaybeE mj "No such project" - a <- lift $ getJust $ projectActor j - return $ actorOutbox a - getActorOutbox (LocalActorRepo shr rp) = do - sid <- do - msid <- lift $ getKeyBy $ UniqueSharer shr - fromMaybeE msid "No such sharer" - r <- do - mr <- lift $ getValBy $ UniqueRepo rp sid - fromMaybeE mr "No such repo" - return $ repoOutbox r + getActor grabActor hash = do + key <- decodeKeyHashidE hash "No such hashid" + actorID <- grabActor <$> getE key "No such actor entity in DB" + lift $ getJust actorID + + getActor' (LocalActorPerson hash) = getActor personActor hash + getActor' (LocalActorGroup hash) = getActor groupActor hash + getActor' (LocalActorRepo hash) = getActor repoActor hash + getActor' (LocalActorDeck hash) = getActor deckActor hash + getActor' (LocalActorLoom hash) = getActor loomActor hash + getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do iid <- MaybeT $ getKeyBy $ UniqueInstance h roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu MaybeT $ getKeyBy $ UniqueRemoteActivity roid +{- data ActorEntity = ActorPerson (Entity Person) | ActorProject (Entity Project) | ActorRepo (Entity Repo) +-} +getLocalActor + :: ( BaseBackend b ~ SqlBackend + , PersistUniqueRead b + , MonadSite m + , YesodHashids (SiteEnv m) + ) + => ActorId + -> ReaderT b m LocalActor +getLocalActor actorID = do + mp <- getKeyBy $ UniquePersonActor actorID + mg <- getKeyBy $ UniqueGroupActor actorID + mr <- getKeyBy $ UniqueRepoActor actorID + md <- getKeyBy $ UniqueDeckActor actorID + ml <- getKeyBy $ UniqueLoomActor actorID + case (mp, mg, mr, md, ml) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" + (Just p, Nothing, Nothing, Nothing, Nothing) -> + LocalActorPerson <$> encodeKeyHashid p + (Nothing, Just g, Nothing, Nothing, Nothing) -> + LocalActorGroup <$> encodeKeyHashid g + (Nothing, Nothing, Just r, Nothing, Nothing) -> + LocalActorRepo <$> encodeKeyHashid r + (Nothing, Nothing, Nothing, Just d, Nothing) -> + LocalActorDeck <$> encodeKeyHashid d + (Nothing, Nothing, Nothing, Nothing, Just l) -> + LocalActorLoom <$> encodeKeyHashid l + _ -> error "Multi-usage of an ActorId" + +{- getOutboxActorEntity obid = do mp <- getBy $ UniquePersonOutbox obid ma <- getBy $ UniqueActorOutbox obid @@ -1329,7 +382,10 @@ actorEntityPath (ActorProject (Entity _ j)) = actorEntityPath (ActorRepo (Entity _ r)) = flip LocalActorRepo (repoIdent r) . sharerIdent <$> getJust (repoSharer r) +-} -outboxItemRoute (LocalActorSharer shr) = SharerOutboxItemR shr -outboxItemRoute (LocalActorProject shr prj) = ProjectOutboxItemR shr prj -outboxItemRoute (LocalActorRepo shr rp) = RepoOutboxItemR shr rp +outboxItemRoute (LocalActorPerson p) = PersonOutboxItemR p +outboxItemRoute (LocalActorGroup g) = GroupOutboxItemR g +outboxItemRoute (LocalActorRepo r) = RepoOutboxItemR r +outboxItemRoute (LocalActorDeck d) = DeckOutboxItemR d +outboxItemRoute (LocalActorLoom l) = LoomOutboxItemR l diff --git a/src/Vervis/ActivityPub/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs deleted file mode 100644 index 382006b..0000000 --- a/src/Vervis/ActivityPub/Recipient.hs +++ /dev/null @@ -1,654 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2019, 2020 by fr33domlover . - - - - β™‘ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Vervis.ActivityPub.Recipient - ( LocalActor (..) - , LocalPersonCollection (..) - , LocalTicketDirectSet (..) - , LocalPatchDirectSet (..) - , LocalProjectDirectSet (..) - , LocalProjectRelatedSet (..) - , LocalRepoDirectSet (..) - , LocalRepoRelatedSet (..) - , LocalSharerDirectSet (..) - , LocalSharerRelatedSet (..) - , LocalRecipientSet - , concatRecipients - , parseLocalActor - , renderLocalActor - , renderLocalPersonCollection - , makeRecipientSet - , ParsedAudience (..) - , parseAudience - , actorRecips - , localRecipSieve - , localRecipSieve' - - , Aud (..) - , collectAudience - ) -where - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.Except -import Data.Bifunctor -import Data.Either -import Data.Foldable -import Data.List ((\\)) -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Data.Maybe -import Data.Semigroup -import Data.Text (Text) -import Data.These -import Data.Traversable - -import qualified Data.List.NonEmpty as NE -import qualified Data.List.Ordered as LO -import qualified Data.Text as T - -import Network.FedURI -import Web.ActivityPub hiding (Ticket) -import Yesod.ActivityPub -import Yesod.FedURI -import Yesod.Hashids -import Yesod.MonadSite - -import Data.List.Local -import Data.List.NonEmpty.Local - -import Vervis.FedURI -import Vervis.Foundation -import Vervis.Model -import Vervis.Model.Ident - -concatRecipients :: Audience u -> [ObjURI u] -concatRecipients (Audience to bto cc bcc gen _) = - concat [to, bto, cc, bcc, gen] - -------------------------------------------------------------------------------- --- Actor and collection-of-persons types --- --- These are the 2 kinds of local recipients. This is the starting point for --- grouping and checking recipient lists: First parse recipient URIs into these --- types, then you can do any further parsing and grouping. -------------------------------------------------------------------------------- - -data LocalActor - = LocalActorSharer ShrIdent - | LocalActorProject ShrIdent PrjIdent - | LocalActorRepo ShrIdent RpIdent - deriving (Eq, Ord) - -parseLocalActor :: Route App -> Maybe LocalActor -parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr -parseLocalActor (ProjectR shr prj) = Just $ LocalActorProject shr prj -parseLocalActor (RepoR shr rp) = Just $ LocalActorRepo shr rp -parseLocalActor _ = Nothing - -renderLocalActor :: LocalActor -> Route App -renderLocalActor (LocalActorSharer shr) = SharerR shr -renderLocalActor (LocalActorProject shr prj) = ProjectR shr prj -renderLocalActor (LocalActorRepo shr rp) = RepoR shr rp - -data LocalPersonCollection - = LocalPersonCollectionSharerFollowers ShrIdent - | LocalPersonCollectionSharerTicketTeam ShrIdent (KeyHashid TicketAuthorLocal) - | LocalPersonCollectionSharerTicketFollowers ShrIdent (KeyHashid TicketAuthorLocal) - | LocalPersonCollectionSharerProposalFollowers ShrIdent (KeyHashid TicketAuthorLocal) - - | LocalPersonCollectionProjectTeam ShrIdent PrjIdent - | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent - | LocalPersonCollectionProjectTicketTeam ShrIdent PrjIdent (KeyHashid LocalTicket) - | LocalPersonCollectionProjectTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket) - - | LocalPersonCollectionRepoTeam ShrIdent RpIdent - | LocalPersonCollectionRepoFollowers ShrIdent RpIdent - | LocalPersonCollectionRepoProposalFollowers ShrIdent RpIdent (KeyHashid LocalTicket) - deriving (Eq, Ord) - -parseLocalPersonCollection - :: Route App -> Maybe LocalPersonCollection -parseLocalPersonCollection (SharerFollowersR shr) = - Just $ LocalPersonCollectionSharerFollowers shr -parseLocalPersonCollection (SharerTicketTeamR shr talkhid) = - Just $ LocalPersonCollectionSharerTicketTeam shr talkhid -parseLocalPersonCollection (SharerTicketFollowersR shr talkhid) = - Just $ LocalPersonCollectionSharerTicketFollowers shr talkhid -parseLocalPersonCollection (SharerProposalFollowersR shr talkhid) = - Just $ LocalPersonCollectionSharerProposalFollowers shr talkhid -parseLocalPersonCollection (ProjectTeamR shr prj) = - Just $ LocalPersonCollectionProjectTeam shr prj -parseLocalPersonCollection (ProjectFollowersR shr prj) = - Just $ LocalPersonCollectionProjectFollowers shr prj -parseLocalPersonCollection (ProjectTicketTeamR shr prj num) = - Just $ LocalPersonCollectionProjectTicketTeam shr prj num -parseLocalPersonCollection (ProjectTicketParticipantsR shr prj num) = - Just $ LocalPersonCollectionProjectTicketFollowers shr prj num -parseLocalPersonCollection (RepoTeamR shr rp) = - Just $ LocalPersonCollectionRepoTeam shr rp -parseLocalPersonCollection (RepoFollowersR shr rp) = - Just $ LocalPersonCollectionRepoFollowers shr rp -parseLocalPersonCollection (RepoProposalFollowersR shr rp ltkhid) = - Just $ LocalPersonCollectionRepoProposalFollowers shr rp ltkhid -parseLocalPersonCollection _ = Nothing - -renderLocalPersonCollection :: LocalPersonCollection -> Route App -renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr -renderLocalPersonCollection (LocalPersonCollectionSharerTicketTeam shr talkhid) = SharerTicketTeamR shr talkhid -renderLocalPersonCollection (LocalPersonCollectionSharerTicketFollowers shr talkhid) = SharerTicketFollowersR shr talkhid -renderLocalPersonCollection (LocalPersonCollectionSharerProposalFollowers shr talkhid) = SharerProposalFollowersR shr talkhid -renderLocalPersonCollection (LocalPersonCollectionProjectTeam shr prj) = ProjectTeamR shr prj -renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj) = ProjectFollowersR shr prj -renderLocalPersonCollection (LocalPersonCollectionProjectTicketTeam shr prj ltkhid) = ProjectTicketTeamR shr prj ltkhid -renderLocalPersonCollection (LocalPersonCollectionProjectTicketFollowers shr prj ltkhid) = ProjectTicketParticipantsR shr prj ltkhid -renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp) = RepoTeamR shr rp -renderLocalPersonCollection (LocalPersonCollectionRepoFollowers shr rp) = RepoFollowersR shr rp -renderLocalPersonCollection (LocalPersonCollectionRepoProposalFollowers shr rp ltkhid) = RepoProposalFollowersR shr rp ltkhid - -parseLocalRecipient - :: Route App -> Maybe (Either LocalActor LocalPersonCollection) -parseLocalRecipient r = - Left <$> parseLocalActor r <|> Right <$> parseLocalPersonCollection r - -------------------------------------------------------------------------------- --- Intermediate recipient types --- --- These are here just to help with grouping recipients. From this --- representation it's easy to group recipients into a form that is friendly to --- the code that fetches the actual recipients from the DB. -------------------------------------------------------------------------------- - -data LocalTicketRecipientDirect = LocalTicketTeam | LocalTicketFollowerz - deriving (Eq, Ord) - -data LocalPatchRecipientDirect = LocalPatchFollowers deriving (Eq, Ord) - -data LocalProjectRecipientDirect - = LocalProject - | LocalProjectTeam - | LocalProjectFollowers - deriving (Eq, Ord) - -data LocalProjectRecipient - = LocalProjectDirect LocalProjectRecipientDirect - | LocalProjectTicketRelated (KeyHashid LocalTicket) LocalTicketRecipientDirect - deriving (Eq, Ord) - -data LocalRepoRecipientDirect - = LocalRepo - | LocalRepoTeam - | LocalRepoFollowers - deriving (Eq, Ord) - -data LocalRepoRecipient - = LocalRepoDirect LocalRepoRecipientDirect - | LocalRepoProposalRelated (KeyHashid LocalTicket) LocalPatchRecipientDirect - deriving (Eq, Ord) - -data LocalSharerRecipientDirect - = LocalSharer - | LocalSharerFollowers - deriving (Eq, Ord) - -data LocalSharerRecipient - = LocalSharerDirect LocalSharerRecipientDirect - | LocalSharerTicketRelated (KeyHashid TicketAuthorLocal) LocalTicketRecipientDirect - | LocalSharerProposalRelated (KeyHashid TicketAuthorLocal) LocalPatchRecipientDirect - | LocalProjectRelated PrjIdent LocalProjectRecipient - | LocalRepoRelated RpIdent LocalRepoRecipient - deriving (Eq, Ord) - -data LocalGroupedRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient - deriving (Eq, Ord) - -groupedRecipientFromActor :: LocalActor -> LocalGroupedRecipient -groupedRecipientFromActor (LocalActorSharer shr) = - LocalSharerRelated shr $ LocalSharerDirect LocalSharer -groupedRecipientFromActor (LocalActorProject shr prj) = - LocalSharerRelated shr $ LocalProjectRelated prj $ - LocalProjectDirect LocalProject -groupedRecipientFromActor (LocalActorRepo shr rp) = - LocalSharerRelated shr $ LocalRepoRelated rp $ LocalRepoDirect LocalRepo - -groupedRecipientFromCollection - :: LocalPersonCollection -> LocalGroupedRecipient -groupedRecipientFromCollection - (LocalPersonCollectionSharerFollowers shr) = - LocalSharerRelated shr $ LocalSharerDirect LocalSharerFollowers -groupedRecipientFromCollection - (LocalPersonCollectionSharerTicketTeam shr talkhid) = - LocalSharerRelated shr $ - LocalSharerTicketRelated talkhid LocalTicketTeam -groupedRecipientFromCollection - (LocalPersonCollectionSharerTicketFollowers shr talkhid) = - LocalSharerRelated shr $ - LocalSharerTicketRelated talkhid LocalTicketFollowerz -groupedRecipientFromCollection - (LocalPersonCollectionSharerProposalFollowers shr talkhid) = - LocalSharerRelated shr $ - LocalSharerProposalRelated talkhid LocalPatchFollowers -groupedRecipientFromCollection - (LocalPersonCollectionProjectTeam shr prj) = - LocalSharerRelated shr $ LocalProjectRelated prj $ - LocalProjectDirect LocalProjectTeam -groupedRecipientFromCollection - (LocalPersonCollectionProjectFollowers shr prj) = - LocalSharerRelated shr $ LocalProjectRelated prj $ - LocalProjectDirect LocalProjectFollowers -groupedRecipientFromCollection - (LocalPersonCollectionProjectTicketTeam shr prj num) = - LocalSharerRelated shr $ LocalProjectRelated prj $ - LocalProjectTicketRelated num LocalTicketTeam -groupedRecipientFromCollection - (LocalPersonCollectionProjectTicketFollowers shr prj num) = - LocalSharerRelated shr $ LocalProjectRelated prj $ - LocalProjectTicketRelated num LocalTicketFollowerz -groupedRecipientFromCollection - (LocalPersonCollectionRepoTeam shr rp) = - LocalSharerRelated shr $ LocalRepoRelated rp $ - LocalRepoDirect LocalRepoTeam -groupedRecipientFromCollection - (LocalPersonCollectionRepoFollowers shr rp) = - LocalSharerRelated shr $ LocalRepoRelated rp $ - LocalRepoDirect LocalRepoFollowers -groupedRecipientFromCollection - (LocalPersonCollectionRepoProposalFollowers shr rp ltkhid) = - LocalSharerRelated shr $ LocalRepoRelated rp $ - LocalRepoProposalRelated ltkhid LocalPatchFollowers - -------------------------------------------------------------------------------- --- Recipient set types --- --- These types represent a set of recipients grouped by the variable components --- of their routes. It's convenient to use when looking for the recipients in --- the DB, and easy to manipulate and check the recipient list in terms of app --- logic rather than plain lists of routes. -------------------------------------------------------------------------------- - -data LocalTicketDirectSet = LocalTicketDirectSet - { localRecipTicketTeam :: Bool - , localRecipTicketFollowers :: Bool - } - deriving Eq - -newtype LocalPatchDirectSet = LocalPatchDirectSet - { localRecipPatchFollowers :: Bool - } - deriving Eq - -data LocalProjectDirectSet = LocalProjectDirectSet - { localRecipProject :: Bool - , localRecipProjectTeam :: Bool - , localRecipProjectFollowers :: Bool - } - deriving Eq - -data LocalProjectRelatedSet = LocalProjectRelatedSet - { localRecipProjectDirect - :: LocalProjectDirectSet - , localRecipProjectTicketRelated - :: [(KeyHashid LocalTicket, LocalTicketDirectSet)] - } - deriving Eq - -data LocalRepoDirectSet = LocalRepoDirectSet - { localRecipRepo :: Bool - , localRecipRepoTeam :: Bool - , localRecipRepoFollowers :: Bool - } - deriving Eq - -data LocalRepoRelatedSet = LocalRepoRelatedSet - { localRecipRepoDirect - :: LocalRepoDirectSet - , localRecipRepoProposalRelated - :: [(KeyHashid LocalTicket, LocalPatchDirectSet)] - } - deriving Eq - -data LocalSharerDirectSet = LocalSharerDirectSet - { localRecipSharer :: Bool - , localRecipSharerFollowers :: Bool - } - deriving Eq - -data LocalSharerRelatedSet = LocalSharerRelatedSet - { localRecipSharerDirect - :: LocalSharerDirectSet - , localRecipSharerTicketRelated - :: [(KeyHashid TicketAuthorLocal, LocalTicketDirectSet)] - , localRecipSharerProposalRelated - :: [(KeyHashid TicketAuthorLocal, LocalPatchDirectSet)] - , localRecipProjectRelated - :: [(PrjIdent, LocalProjectRelatedSet)] - , localRecipRepoRelated - :: [(RpIdent, LocalRepoRelatedSet)] - } - deriving Eq - -type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)] - -groupLocalRecipients :: [LocalGroupedRecipient] -> LocalRecipientSet -groupLocalRecipients - = map (second lsr2set) - . groupAllExtract - (\ (LocalSharerRelated shr _) -> shr) - (\ (LocalSharerRelated _ lsr) -> lsr) - where - lsr2set = mk . partitionLSR . NE.toList - where - partitionLSR = foldr f ([], [], [], [], []) - where - f i (ds, ts, ps, js, rs) = - case i of - LocalSharerDirect d -> - (d:ds, ts, ps, js, rs) - LocalSharerTicketRelated talkhid ltr -> - (ds, (talkhid, ltr):ts, ps, js, rs) - LocalSharerProposalRelated talkhid lpr -> - (ds, ts, (talkhid, lpr):ps, js, rs) - LocalProjectRelated prj ljr -> - (ds, ts, ps, (prj, ljr):js, rs) - LocalRepoRelated rp lrr -> - (ds, ts, ps, js, (rp, lrr):rs) - mk (ds, ts, ps, js, rs) = - LocalSharerRelatedSet - (lsrs2set ds) - (map (second ltrs2set) $ groupWithExtract fst snd ts) - (map (second lprs2set) $ groupWithExtract fst snd ps) - (map (second ljr2set) $ groupWithExtract fst snd js) - (map (second lrr2set) $ groupWithExtract fst snd rs) - where - lsrs2set = foldl' f initial - where - initial = LocalSharerDirectSet False False - f s LocalSharer = - s { localRecipSharer = True } - f s LocalSharerFollowers = - s { localRecipSharerFollowers = True } - ltrs2set = foldl' f initial - where - initial = LocalTicketDirectSet False False - f s LocalTicketTeam = - s { localRecipTicketTeam = True } - f s LocalTicketFollowerz = - s { localRecipTicketFollowers = True } - lprs2set = foldl' f initial - where - initial = LocalPatchDirectSet False - f s LocalPatchFollowers = s { localRecipPatchFollowers = True } - ljr2set = uncurry mk . partitionEithers . map ljr2e . NE.toList - where - ljr2e (LocalProjectDirect d) = Left d - ljr2e (LocalProjectTicketRelated num ltrs) = Right (num, ltrs) - mk ds ts = - LocalProjectRelatedSet - (ljrs2set ds) - (map (second ltrs2set) $ groupWithExtract fst snd ts) - where - ljrs2set = foldl' f initial - where - initial = LocalProjectDirectSet False False False - f s LocalProject = - s { localRecipProject = True } - f s LocalProjectTeam = - s { localRecipProjectTeam = True } - f s LocalProjectFollowers = - s { localRecipProjectFollowers = True } - lrr2set = uncurry mk . partitionEithers . map lrr2e . NE.toList - where - lrr2e (LocalRepoDirect d) = Left d - lrr2e (LocalRepoProposalRelated num ltrs) = Right (num, ltrs) - mk ds ps = - LocalRepoRelatedSet - (lrrs2set ds) - (map (second lprs2set) $ groupWithExtract fst snd ps) - where - lrrs2set = foldl' f initial - where - initial = LocalRepoDirectSet False False False - f s LocalRepo = s { localRecipRepo = True } - f s LocalRepoTeam = s { localRecipRepoTeam = True } - f s LocalRepoFollowers = s { localRecipRepoFollowers = True } - -------------------------------------------------------------------------------- --- Parse URIs into a grouped recipient set -------------------------------------------------------------------------------- - -makeRecipientSet - :: [LocalActor] -> [LocalPersonCollection] -> LocalRecipientSet -makeRecipientSet actors collections = - groupLocalRecipients $ - map groupedRecipientFromActor actors ++ - map groupedRecipientFromCollection collections - -parseRecipients - :: (MonadSite m, SiteEnv m ~ App) - => NonEmpty FedURI - -> ExceptT Text m (LocalRecipientSet, [FedURI]) -parseRecipients recips = do - hLocal <- asksSite siteInstanceHost - let (locals, remotes) = splitRecipients hLocal recips - (lusInvalid, routesInvalid, localsSet) = parseLocalRecipients locals - unless (null lusInvalid) $ - throwE $ - "Local recipients are invalid routes: " <> - T.pack (show $ map (renderObjURI . ObjURI hLocal) lusInvalid) - unless (null routesInvalid) $ do - renderUrl <- askUrlRender - throwE $ - "Local recipients are non-recipient routes: " <> - T.pack (show $ map renderUrl routesInvalid) - return (localsSet, remotes) - where - splitRecipients :: Host -> NonEmpty FedURI -> ([LocalURI], [FedURI]) - splitRecipients home recips = - let (local, remote) = NE.partition ((== home) . objUriAuthority) recips - in (map objUriLocal local, remote) - - parseLocalRecipients - :: [LocalURI] -> ([LocalURI], [Route App], LocalRecipientSet) - parseLocalRecipients lus = - let (lusInvalid, routes) = partitionEithers $ map parseRoute lus - (routesInvalid, recips) = partitionEithers $ map parseRecip routes - (actors, collections) = partitionEithers recips - grouped = - map groupedRecipientFromActor actors ++ - map groupedRecipientFromCollection collections - in (lusInvalid, routesInvalid, groupLocalRecipients grouped) - where - parseRoute lu = - case decodeRouteLocal lu of - Nothing -> Left lu - Just route -> Right route - parseRecip route = - case parseLocalRecipient route of - Nothing -> Left route - Just recip -> Right recip - -data ParsedAudience u = ParsedAudience - { paudLocalRecips :: LocalRecipientSet - , paudRemoteActors :: [(Authority u, NonEmpty LocalURI)] - , paudBlinded :: Audience u - , paudFwdHosts :: [Authority u] - } - -parseAudience - :: (MonadSite m, SiteEnv m ~ App) - => Audience URIMode - -> ExceptT Text m (Maybe (ParsedAudience URIMode)) -parseAudience audience = do - let recips = concatRecipients audience - for (nonEmpty recips) $ \ recipsNE -> do - (localsSet, remotes) <- parseRecipients recipsNE - let remotesGrouped = - groupByHost $ remotes \\ audienceNonActors audience - hosts = map fst remotesGrouped - return ParsedAudience - { paudLocalRecips = localsSet - , paudRemoteActors = remotesGrouped - , paudBlinded = - audience { audienceBto = [], audienceBcc = [] } - , paudFwdHosts = - let nonActorHosts = - LO.nubSort $ - map objUriAuthority $ audienceNonActors audience - in LO.isect hosts nonActorHosts - } - where - groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)] - groupByHost = groupAllExtract objUriAuthority objUriLocal - -actorIsMember :: LocalActor -> LocalRecipientSet -> Bool -actorIsMember (LocalActorSharer shr) lrSet = - case lookup shr lrSet of - Just lsrSet -> localRecipSharer $ localRecipSharerDirect lsrSet - Nothing -> False -actorIsMember (LocalActorProject shr prj) lrSet = fromMaybe False $ do - lsrSet <- lookup shr lrSet - lprSet <- lookup prj $ localRecipProjectRelated lsrSet - return $ localRecipProject $ localRecipProjectDirect $ lprSet -actorIsMember (LocalActorRepo shr rp) lrSet = fromMaybe False $ do - lsrSet <- lookup shr lrSet - lrrSet <- lookup rp $ localRecipRepoRelated lsrSet - return $ localRecipRepo $ localRecipRepoDirect $ lrrSet - -actorRecips :: LocalActor -> LocalRecipientSet -actorRecips = groupLocalRecipients . (: []) . groupedRecipientFromActor - -localRecipSieve - :: LocalRecipientSet -> Bool -> LocalRecipientSet -> LocalRecipientSet -localRecipSieve sieve allowActors = - localRecipSieve' sieve allowActors allowActors - -localRecipSieve' - :: LocalRecipientSet - -> Bool - -> Bool - -> LocalRecipientSet - -> LocalRecipientSet -localRecipSieve' sieve allowSharers allowOthers = - mapMaybe (uncurry applySharerRelated) . sortAlign sieve - where - onlyActorsJ (LocalProjectRelatedSet (LocalProjectDirectSet j _t _f) _ts) = - LocalProjectRelatedSet (LocalProjectDirectSet (j && allowOthers) False False) [] - onlyActorsR (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f) _ps) = - LocalRepoRelatedSet (LocalRepoDirectSet (r && allowOthers) False False) [] - onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) _ts _ps js rs) = - LocalSharerRelatedSet - (LocalSharerDirectSet (s && allowSharers) False) - [] - [] - (map (second onlyActorsJ) js) - (map (second onlyActorsR) rs) - - applySharerRelated _ (This _) = Nothing - applySharerRelated shr (That s) = - if allowSharers || allowOthers - then Just (shr, onlyActorsS s) - else Nothing - applySharerRelated shr (These (LocalSharerRelatedSet s' t' p' j' r') (LocalSharerRelatedSet s t p j r)) = - Just - ( shr - , LocalSharerRelatedSet - (applySharer s' s) - (mapMaybe (uncurry applyTicketRelated) $ sortAlign t' t) - (mapMaybe (uncurry applyPatchRelated) $ sortAlign p' p) - (mapMaybe (uncurry applyProjectRelated) $ sortAlign j' j) - (mapMaybe (uncurry applyRepoRelated) $ sortAlign r' r) - ) - where - applySharer (LocalSharerDirectSet s' f') (LocalSharerDirectSet s f) = - LocalSharerDirectSet (s && (s' || allowSharers)) (f && f') - - applyTicketRelated ltkhid (These t' t) = Just (ltkhid, applyTicket t' t) - where - applyTicket (LocalTicketDirectSet t' f') (LocalTicketDirectSet t f) = - LocalTicketDirectSet (t && t') (f && f') - applyTicketRelated _ _ = Nothing - - applyPatchRelated ltkhid (These p' p) = Just (ltkhid, applyPatch p' p) - where - applyPatch (LocalPatchDirectSet f') (LocalPatchDirectSet f) = - LocalPatchDirectSet $ f && f' - applyPatchRelated _ _ = Nothing - - applyProjectRelated _ (This _) = Nothing - applyProjectRelated prj (That j) = - if allowOthers - then Just (prj, onlyActorsJ j) - else Nothing - applyProjectRelated prj (These (LocalProjectRelatedSet j' t') (LocalProjectRelatedSet j t)) = - Just - ( prj - , LocalProjectRelatedSet - (applyProject j' j) - (mapMaybe (uncurry applyTicketRelated) $ sortAlign t' t) - ) - where - applyProject (LocalProjectDirectSet j' t' f') (LocalProjectDirectSet j t f) = - LocalProjectDirectSet (j && (j' || allowOthers)) (t && t') (f && f') - - applyRepoRelated _ (This _) = Nothing - applyRepoRelated rp (That r) = - if allowOthers - then Just (rp, onlyActorsR r) - else Nothing - applyRepoRelated rp (These (LocalRepoRelatedSet r' p') (LocalRepoRelatedSet r p)) = - Just - ( rp - , LocalRepoRelatedSet - (applyRepo r' r) - (mapMaybe (uncurry applyPatchRelated) $ sortAlign p' p) - ) - where - applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) = - LocalRepoDirectSet (r && (r' || allowOthers)) (t && t') (f && f') - -data Aud u - = AudLocal [LocalActor] [LocalPersonCollection] - | AudRemote (Authority u) [LocalURI] [LocalURI] - -collectAudience - :: Foldable f - => f (Aud u) - -> ( LocalRecipientSet - , [(Authority u, NonEmpty LocalURI)] - , [Authority u] - , [Route App] - , [ObjURI u] - ) -collectAudience auds = - let (locals, remotes) = partitionAudience auds - (actors, collections) = - let organize = LO.nubSort . concat - in bimap organize organize $ unzip locals - groupedRemotes = - let organize = LO.nubSort . sconcat - in map (second $ bimap organize organize . NE.unzip) $ - groupAllExtract fst snd remotes - in ( makeRecipientSet actors collections - , mapMaybe (\ (h, (as, _)) -> (h,) <$> nonEmpty as) groupedRemotes - , [ h | (h, (_, cs)) <- groupedRemotes, not (null cs) ] - , map renderLocalActor actors ++ - map renderLocalPersonCollection collections - , concatMap (\ (h, (as, cs)) -> ObjURI h <$> as ++ cs) groupedRemotes - ) - where - partitionAudience = foldl' f ([], []) - where - f (ls, rs) (AudLocal as cs) = ((as, cs) : ls, rs) - f (ls, rs) (AudRemote h as cs) = (ls , (h, (as, cs)) : rs) diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs new file mode 100644 index 0000000..c2bde44 --- /dev/null +++ b/src/Vervis/Actor.hs @@ -0,0 +1,399 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2020, 2022 by fr33domlover . + - + - β™‘ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Actor + ( getInbox + , getOutbox + , getOutboxItem + , getFollowersCollection + , getActorFollowersCollection + , getFollowingCollection + ) +where + +import Control.Applicative ((<|>)) +import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar') +import Control.Exception hiding (Handler) +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger.CallStack +import Control.Monad.STM (atomically) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Bifunctor +import Data.Bitraversable +import Data.Foldable (for_) +import Data.List +import Data.Maybe +import Data.Text (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.Time.Clock +import Data.Time.Interval (TimeInterval, toTimeUnit) +import Data.Time.Units (Second) +import Data.Traversable +import Database.Persist +import Database.Persist.Sql +import Network.HTTP.Types.Status +import Text.Blaze.Html (Html, preEscapedToHtml) +import Text.Blaze.Html.Renderer.Text +import Text.HTML.SanitizeXSS +import Text.Shakespeare.I18N (RenderMessage) +import Yesod.Core hiding (logDebug) +import Yesod.Core.Handler +import Yesod.Form.Fields +import Yesod.Form.Functions +import Yesod.Form.Types +import Yesod.Persist.Core + +import qualified Data.ByteString.Char8 as BC (unpack) +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL (toStrict) +import qualified Data.Vector as V +import qualified Database.Esqueleto as E + +import Database.Persist.JSON +import Network.FedURI +import Web.ActivityPub hiding (Project (..), ActorLocal (..)) +import Yesod.ActivityPub +import Yesod.Auth.Unverified +import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite +import Yesod.RenderSource + +import Data.Aeson.Local +import Data.Either.Local +import Data.EventTime.Local +import Data.Paginate.Local +import Data.Time.Clock.Local +import Database.Persist.Local +import Yesod.Persist.Local + +import Vervis.ActivityPub +import Vervis.ActorKey +import Vervis.API +import Vervis.FedURI +import Vervis.Federation +import Vervis.Federation.Auth +import Vervis.Foundation +import Vervis.Model hiding (Ticket) +import Vervis.Model.Ident +import Vervis.Paginate +import Vervis.Recipient +import Vervis.Settings +import Vervis.Ticket + +getShowTime = showTime <$> liftIO getCurrentTime + where + showTime now = + showEventTime . + intervalToEventTime . + FriendlyConvert . + diffUTCTime now + +objectSummary o = + case M.lookup "summary" o of + Just (String t) | not (T.null t) -> Just t + _ -> Nothing + +objectId o = + case M.lookup "id" o <|> M.lookup "@id" o of + Just (String t) | not (T.null t) -> t + _ -> error "'id' field not found" + +getInbox here actor hash = do + key <- decodeKeyHashid404 hash + (total, pages, mpage) <- runDB $ do + inboxID <- do + actorID <- actor <$> get404 key + actorInbox <$> getJust actorID + getPageAndNavCount + (countItems inboxID) + (\ off lim -> map adaptItem <$> getItems inboxID off lim) + + encodeRouteLocal <- getEncodeRouteLocal + encodeRoutePageLocal <- getEncodeRoutePageLocal + let here' = here hash + pageUrl = encodeRoutePageLocal here' + host <- getsYesod $ appInstanceHost . appSettings + selectRep $ + case mpage of + Nothing -> do + provideAP $ pure $ Doc host $ Collection + { collectionId = encodeRouteLocal here' + , collectionType = CollectionTypeOrdered + , collectionTotalItems = Just total + , collectionCurrent = Nothing + , collectionFirst = Just $ pageUrl 1 + , collectionLast = Just $ pageUrl pages + , collectionItems = [] :: [Text] + } + provideRep (redirectFirstPage here' :: Handler Html) + Just (items, navModel) -> do + let current = nmCurrent navModel + provideAP $ pure $ Doc host $ CollectionPage + { collectionPageId = pageUrl current + , collectionPageType = CollectionPageTypeOrdered + , collectionPageTotalItems = Nothing + , collectionPageCurrent = Just $ pageUrl current + , collectionPageFirst = Just $ pageUrl 1 + , collectionPageLast = Just $ pageUrl pages + , collectionPagePartOf = encodeRouteLocal here' + , collectionPagePrev = + if current > 1 + then Just $ pageUrl $ current - 1 + else Nothing + , collectionPageNext = + if current < pages + then Just $ pageUrl $ current + 1 + else Nothing + , collectionPageStartIndex = Nothing + , collectionPageItems = map fst items + } + provideRep $ do + let pageNav = navWidget navModel + showTime <- getShowTime + defaultLayout $(widgetFile "person/inbox") + where + countItems ibid = + (+) <$> count [InboxItemLocalInbox ==. ibid] + <*> count [InboxItemRemoteInbox ==. ibid] + getItems ibid off lim = + E.select $ E.from $ + \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do + E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId + E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem + E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId + E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem + E.where_ + $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||. + ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid) + ) + E.&&. + ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||. + ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid) + ) + E.orderBy [E.desc $ ib E.^. InboxItemId] + E.offset $ fromIntegral off + E.limit $ fromIntegral lim + return + ( ib E.^. InboxItemId + , ob E.?. OutboxItemActivity + , ob E.?. OutboxItemPublished + , ract E.?. RemoteActivityContent + , ract E.?. RemoteActivityReceived + ) + adaptItem + (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) = + case (mact, mpub, mobj, mrec) of + (Nothing, Nothing, Nothing, Nothing) -> + error $ ibiidString ++ " neither local nor remote" + (Just _, Just _, Just _, Just _) -> + error $ ibiidString ++ " both local and remote" + (Just act, Just pub, Nothing, Nothing) -> + (persistJSONObject act, (pub, False)) + (Nothing, Nothing, Just obj, Just rec) -> + (persistJSONObject obj, (rec, True)) + _ -> error $ "Unexpected query result for " ++ ibiidString + where + ibiidString = "InboxItem #" ++ show (fromSqlKey ibid) + +getOutbox here actor hash = do + key <- decodeKeyHashid404 hash + (total, pages, mpage) <- runDB $ do + outboxID <- do + actorID <- actor <$> get404 key + actorOutbox <$> getJust actorID + let countAllItems = count [OutboxItemOutbox ==. outboxID] + selectItems off lim = selectList [OutboxItemOutbox ==. outboxID] [Desc OutboxItemId, OffsetBy off, LimitTo lim] + getPageAndNavCount countAllItems selectItems + + encodeRouteLocal <- getEncodeRouteLocal + encodeRoutePageLocal <- getEncodeRoutePageLocal + let here' = here hash + pageUrl = encodeRoutePageLocal here' + host <- getsYesod $ appInstanceHost . appSettings + selectRep $ + case mpage of + Nothing -> do + provideAP $ pure $ Doc host $ Collection + { collectionId = encodeRouteLocal here' + , collectionType = CollectionTypeOrdered + , collectionTotalItems = Just total + , collectionCurrent = Nothing + , collectionFirst = Just $ pageUrl 1 + , collectionLast = Just $ pageUrl pages + , collectionItems = [] :: [Text] + } + provideRep (redirectFirstPage here' :: Handler Html) + Just (items, navModel) -> do + let current = nmCurrent navModel + provideAP $ pure $ Doc host $ CollectionPage + { collectionPageId = pageUrl current + , collectionPageType = CollectionPageTypeOrdered + , collectionPageTotalItems = Nothing + , collectionPageCurrent = Just $ pageUrl current + , collectionPageFirst = Just $ pageUrl 1 + , collectionPageLast = Just $ pageUrl pages + , collectionPagePartOf = encodeRouteLocal here' + , collectionPagePrev = + if current > 1 + then Just $ pageUrl $ current - 1 + else Nothing + , collectionPageNext = + if current < pages + then Just $ pageUrl $ current + 1 + else Nothing + , collectionPageStartIndex = Nothing + , collectionPageItems = map (persistJSONObject . outboxItemActivity . entityVal) items + } + provideRep $ do + let pageNav = navWidget navModel + showTime <- getShowTime + defaultLayout $(widgetFile "person/outbox") + +getOutboxItem here actor topicHash itemHash = do + topicID <- decodeKeyHashid404 topicHash + itemID <- decodeKeyHashid404 itemHash + body <- runDB $ do + outboxID <- do + actorID <- actor <$> get404 topicID + actorOutbox <$> getJust actorID + item <- get404 itemID + unless (outboxItemOutbox item == outboxID) notFound + return $ outboxItemActivity item + let here' = here topicHash itemHash + provideHtmlAndAP'' body $ redirectToPrettyJSON here' + +getLocalActors + :: [ActorId] -> ReaderT SqlBackend Handler [LocalActorBy Key] +getLocalActors actorIDs = do + localActors <- + concat <$> sequenceA + [ map LocalActorPerson <$> + selectKeysList [PersonActor <-. actorIDs] [] + , map LocalActorGroup <$> + selectKeysList [GroupActor <-. actorIDs] [] + , map LocalActorRepo <$> + selectKeysList [RepoActor <-. actorIDs] [] + , map LocalActorDeck <$> + selectKeysList [DeckActor <-. actorIDs] [] + , map LocalActorLoom <$> + selectKeysList [LoomActor <-. actorIDs] [] + ] + case compare (length localActors) (length actorIDs) of + LT -> error "Found actor ID not used by any specific actor" + GT -> error "Found actor ID used by multiple specific actors" + EQ -> return localActors + +getFollowersCollection + :: Route App -> AppDB FollowerSetId -> Handler TypedContent +getFollowersCollection here getFsid = do + (locals, remotes, l, r) <- runDB $ do + fsid <- getFsid + (,,,) <$> do actorIDs <- + map (followActor . entityVal) <$> + selectList + [FollowTarget ==. fsid, FollowPublic ==. True] + [] + getLocalActors actorIDs + <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId + E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId + E.where_ + $ rf E.^. RemoteFollowTarget E.==. E.val fsid + E.&&. rf E.^. RemoteFollowPublic E.==. E.val True + return + ( i E.^. InstanceHost + , ro E.^. RemoteObjectIdent + ) + <*> count [FollowTarget ==. fsid] + <*> count [RemoteFollowTarget ==. fsid] + + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hashActor <- getHashLocalActor + let followersAP = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ l + r + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map (encodeRouteHome . renderLocalActor . hashActor) locals ++ + map (uncurry ObjURI . bimap E.unValue E.unValue) remotes + } + provideHtmlAndAP followersAP $ redirectToPrettyJSON here + +getActorFollowersCollection here actor hash = do + key <- decodeKeyHashid404 hash + getFollowersCollection (here hash) (getFsid key) + where + getFsid key = do + actorID <- actor <$> get404 key + actorFollowers <$> getJust actorID + +getFollowingCollection here actor hash = do + key <- decodeKeyHashid404 hash + (localTotal, localActors, workItems, remotes) <- runDB $ do + followerActorID <- actor <$> get404 key + followerSetIDs <- + map (followTarget . entityVal) <$> + selectList [FollowActor ==. followerActorID] [] + actorIDs <- selectKeysList [ActorFollowers <-. followerSetIDs] [] + ticketIDs <- selectKeysList [TicketFollowers <-. followerSetIDs] [] + (,,,) (length followerSetIDs) + <$> getLocalActors actorIDs + <*> ((++) <$> getTickets ticketIDs <*> getCloths ticketIDs) + <*> getRemotes followerActorID + + hashActor <- getHashLocalActor + workItemRoute <- askWorkItemRoute + let locals = + map (renderLocalActor . hashActor) localActors ++ + map workItemRoute workItems + unless (length locals == localTotal) $ + error "Bug! List length mismatch" + + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let here' = here hash + followingAP = Collection + { collectionId = encodeRouteLocal here' + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ localTotal + length remotes + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = map encodeRouteHome locals ++ remotes + } + provideHtmlAndAP followingAP $ redirectToPrettyJSON here' + where + getTickets tids = + map workItem <$> selectList [TicketDeckTicket <-. tids] [] + where + workItem (Entity t (TicketDeck _ d)) = WorkItemTicket d t + getCloths tids = + map workItem <$> selectList [TicketLoomTicket <-. tids] [] + where + workItem (Entity c (TicketLoom _ l _)) = WorkItemCloth l c + getRemotes aid = + map (followRemoteTarget . entityVal) <$> + selectList [FollowRemoteActor ==. aid] [] diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index eb731a9..3ba6f08 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020 by fr33domlover . + - Written in 2016, 2018, 2019, 2020, 2022 + - by fr33domlover . - - β™‘ Copying is an act of love. Please copy, reuse and share. - @@ -84,6 +85,7 @@ import Yesod.Mail.Send (runMailer) import Control.Concurrent.ResultShare import Data.KeyFile import Network.FedURI +import Yesod.Hashids import Yesod.MonadSite import Control.Concurrent.Local @@ -103,20 +105,19 @@ import Vervis.RemoteActorStore -- Don't forget to add new modules to your cabal file! import Vervis.Handler.Client import Vervis.Handler.Common -import Vervis.Handler.Git +import Vervis.Handler.Cloth +import Vervis.Handler.Deck +--import Vervis.Handler.Git import Vervis.Handler.Group -import Vervis.Handler.Home -import Vervis.Handler.Inbox -import Vervis.Handler.Key -import Vervis.Handler.Patch +--import Vervis.Handler.Key +import Vervis.Handler.Loom import Vervis.Handler.Person -import Vervis.Handler.Project import Vervis.Handler.Repo -import Vervis.Handler.Role -import Vervis.Handler.Sharer +--import Vervis.Handler.Role +--import Vervis.Handler.Sharer import Vervis.Handler.Ticket -import Vervis.Handler.Wiki -import Vervis.Handler.Workflow +--import Vervis.Handler.Wiki +--import Vervis.Handler.Workflow import Vervis.Migration (migrateDB) import Vervis.Model @@ -230,8 +231,8 @@ makeFoundation appSettings = do return app where verifyRepoDir = do - repos <- lift repoTreeFromDir - repos' <- repoTreeFromDB + repos <- lift reposFromDir + repos' <- reposFromDB unless (repos == repos') $ liftIO $ do putStrLn "Repo tree based on filesystem:" printRepos repos @@ -240,31 +241,23 @@ makeFoundation appSettings = do throwIO $ userError "Repo dir check failed!" liftIO $ printRepos repos where - printRepos = traverse_ $ \ (shr, rps) -> - for_ rps $ \ (rp, vcs) -> - putStrLn $ - "Found repo " ++ - shr ++ " / " ++ rp ++ - " [" ++ T.unpack (versionControlSystemName vcs) ++ "]" - repoTreeFromDir = do + printRepos = traverse_ $ \ (rp, vcs) -> + putStrLn $ + "Found repo " ++ rp ++ + " [" ++ T.unpack (versionControlSystemName vcs) ++ "]" + reposFromDir = do dir <- askRepoRootDir - outers <- liftIO $ sort <$> listDirectory dir - repos <- for outers $ \ outer -> do - let path = dir outer - checkDir path - inners <- liftIO $ sort <$> listDirectory path - inners' <- for inners $ \ inner -> do - checkDir $ path inner - vcs <- do - mvcs <- detectVcs $ path inner - let ref = outer ++ "/" ++ inner - case mvcs of - Left False -> error $ "Failed to detect VCS: " ++ ref - Left True -> error $ "Detected both VCSs: " ++ ref - Right v -> return v - return (inner, vcs) - return $ (outer,) <$> nonEmpty inners' - return $ catMaybes repos + subdirs <- liftIO $ sort <$> listDirectory dir + for subdirs $ \ subdir -> do + checkDir $ dir subdir + vcs <- do + mvcs <- detectVcs $ dir subdir + let ref = dir ++ "/" ++ subdir + case mvcs of + Left False -> error $ "Failed to detect VCS: " ++ ref + Left True -> error $ "Detected both VCSs: " ++ ref + Right v -> return v + return (subdir, vcs) where checkDir path = liftIO $ do isdir <- doesDirectoryExist path @@ -280,18 +273,12 @@ makeFoundation appSettings = do (False, True) -> Right VCSGit (False, False) -> Left False (True, True) -> Left True - repoTreeFromDB = - fmap adapt $ E.select $ E.from $ \ (s `E.InnerJoin` r) -> do - E.on $ s E.^. SharerId E.==. r E.^. RepoSharer - E.orderBy [E.asc $ s E.^. SharerIdent, E.asc $ r E.^. RepoIdent] - return (s E.^. SharerIdent, (r E.^. RepoIdent, r E.^. RepoVcs)) + reposFromDB = do + hashRepo <- getEncodeKeyHashid + sortOn fst . map (adapt hashRepo) <$> selectList [] [] where - adapt = - groupWithExtract - (lower . unShrIdent . E.unValue . fst) - (first (lower . unRpIdent) . bimap E.unValue E.unValue . snd) - where - lower = T.unpack . CI.foldedCase + adapt hashRepo (Entity repoID repo) = + (T.unpack $ keyHashidText $ hashRepo repoID, repoVcs repo) migrate :: MonadLogger m => Text -> ReaderT b m (Either Text (Int, Int)) -> ReaderT b m () migrate name a = do r <- a @@ -372,6 +359,7 @@ sshServer :: App -> IO () sshServer foundation = runSsh (appSettings foundation) + (appHashidsContext foundation) (appConnPool foundation) (loggingFunction foundation) diff --git a/src/Vervis/ChangeFeed.hs b/src/Vervis/ChangeFeed.hs index c15fb4a..c517c6a 100644 --- a/src/Vervis/ChangeFeed.hs +++ b/src/Vervis/ChangeFeed.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2018, 2020 by fr33domlover . + - Written in 2018, 2020, 2022 by fr33domlover . - - β™‘ Copying is an act of love. Please copy, reuse and share. - @@ -25,14 +25,16 @@ import Yesod.Feed import qualified Data.Text as T (concat) +import Yesod.Hashids + import Vervis.Changes import Vervis.Foundation -import Vervis.Model.Ident +import Vervis.Model import Development.PatchMediaType -changeEntry :: ShrIdent -> RpIdent -> LogEntry -> FeedEntry (Route App) -changeEntry shr rp le = FeedEntry - { feedEntryLink = RepoCommitR shr rp $ leHash le +changeEntry :: KeyHashid Repo -> LogEntry -> FeedEntry (Route App) +changeEntry rp le = FeedEntry + { feedEntryLink = RepoCommitR rp $ leHash le , feedEntryUpdated = fst $ leTime le , feedEntryTitle = leMessage le , feedEntryContent = mempty @@ -40,15 +42,14 @@ changeEntry shr rp le = FeedEntry } changeFeed - :: ShrIdent -- ^ Sharer name - -> RpIdent -- ^ Repo name + :: KeyHashid Repo -- ^ Repo key -> Maybe Text -- ^ Optional branch name -> VersionControlSystem -- ^ To pick VCS specific terms -> [LogEntry] -- ^ Changes, recent first -> Feed (Route App) -changeFeed shr repo mbranch vcs les = Feed +changeFeed repo mbranch vcs les = Feed { feedTitle = T.concat - [ rp2text repo + [ keyHashidText repo , case mbranch of Nothing -> "" Just b -> ":" <> b @@ -59,16 +60,16 @@ changeFeed shr repo mbranch vcs les = Feed ] , feedLinkSelf = case mbranch of - Nothing -> RepoHeadChangesR shr repo - Just b -> RepoChangesR shr repo b + Nothing -> RepoCommitsR repo + Just b -> RepoBranchCommitsR repo b , feedLinkHome = case mbranch of - Nothing -> RepoHeadChangesR shr repo - Just b -> RepoChangesR shr repo b - , feedAuthor = shr2text shr + Nothing -> RepoCommitsR repo + Just b -> RepoBranchCommitsR repo b + , feedAuthor = keyHashidText repo , feedDescription = mempty , feedLanguage = "en" , feedUpdated = fst $ leTime $ head les , feedLogo = Nothing - , feedEntries = map (changeEntry shr repo) les + , feedEntries = map (changeEntry repo) les } diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 2f1bc9b..a323440 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -22,14 +22,12 @@ module Vervis.Client , followTicket , followRepo , offerTicket - , createTicket , resolve , undoFollowSharer , undoFollowProject , undoFollowTicket , undoFollowRepo , unresolve - , createMR , offerMR , createDeck ) @@ -69,11 +67,11 @@ import Data.Either.Local import Database.Persist.Local import Vervis.ActivityPub -import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Recipient import Vervis.Ticket import Vervis.WorkItem @@ -87,6 +85,8 @@ createThread -> Route App -> m (Either Text (Note URIMode)) createThread shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context = runExceptT $ do + error "Temporarily disabled" + {- encodeRouteLocal <- getEncodeRouteLocal let encodeRecipRoute = ObjURI hDest . encodeRouteLocal contentHtml <- ExceptT . pure $ renderPandocMarkdown msg @@ -109,6 +109,7 @@ createThread shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context = , noteSource = msg , noteContent = contentHtml } + -} createReply :: ShrIdent @@ -120,6 +121,8 @@ createReply -> MessageId -> Handler (Either Text (Note URIMode)) createReply shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context midParent = runExceptT $ do + error "Temporarily disabled" + {- encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal let encodeRecipRoute = ObjURI hDest . encodeRouteLocal @@ -159,11 +162,14 @@ createReply shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context mid , noteSource = msg , noteContent = contentHtml } + -} follow :: (MonadHandler m, HandlerSite m ~ App) => ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do + error "Temporarily disabled" + {- summary <- TextHtml . TL.toStrict . renderHtml <$> withUrlRenderer @@ -186,44 +192,59 @@ follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do } audience = Audience [uRecip] [] [] [] [] [] return (summary, audience, followAP) + -} followSharer :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) followSharer shrAuthor shrObject hide = do + error "Temporarily disabled" + {- encodeRouteHome <- getEncodeRouteHome let uObject = encodeRouteHome $ SharerR shrObject follow shrAuthor uObject uObject hide + -} followProject :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent -> ShrIdent -> PrjIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) followProject shrAuthor shrObject prjObject hide = do + error "Temporarily disabled" + {- encodeRouteHome <- getEncodeRouteHome let uObject = encodeRouteHome $ ProjectR shrObject prjObject follow shrAuthor uObject uObject hide + -} followTicket :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent -> ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) followTicket shrAuthor shrObject prjObject numObject hide = do + error "Temporarily disabled" + {- encodeRouteHome <- getEncodeRouteHome let uObject = encodeRouteHome $ ProjectTicketR shrObject prjObject numObject uRecip = encodeRouteHome $ ProjectR shrObject prjObject follow shrAuthor uObject uRecip hide + -} followRepo :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent -> ShrIdent -> RpIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) followRepo shrAuthor shrObject rpObject hide = do + error "Temporarily disabled" + {- encodeRouteHome <- getEncodeRouteHome let uObject = encodeRouteHome $ RepoR shrObject rpObject follow shrAuthor uObject uObject hide + -} offerTicket :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, AP.Ticket URIMode, FedURI)) offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runExceptT $ do + error "Temporarily disabled" + {- encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome descHtml <- ExceptT . pure $ renderPandocMarkdown desc @@ -266,68 +287,6 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx } return (summary, audience, ticket, target) -createTicket - :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) - => ShrIdent - -> TextHtml - -> TextPandocMarkdown - -> FedURI - -> FedURI - -> m (Either Text (TextHtml, Audience URIMode, Create URIMode)) -createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context = runExceptT $ do - summary <- - TextHtml . TL.toStrict . renderHtml <$> - withUrlRenderer - [hamlet| -

- - #{shr2text shrAuthor} - \ opened a ticket on project # - - #{renderObjURI context} - : #{preEscapedToHtml title}. - |] - - encodeRouteHome <- getEncodeRouteHome - let recipsA = [target] - recipsC = - let ObjURI h (LocalURI lu) = context - in [ ObjURI h $ LocalURI $ lu <> "/followers" - , ObjURI h $ LocalURI $ lu <> "/team" - , encodeRouteHome $ SharerFollowersR shrAuthor - ] - audience = Audience - { audienceTo = recipsA ++ recipsC - , audienceBto = [] - , audienceCc = [] - , audienceBcc = [] - , audienceGeneral = [] - , audienceNonActors = recipsC - } - - encodeRouteLocal <- getEncodeRouteLocal - hLocal <- asksSite siteInstanceHost - descHtml <- ExceptT . pure $ renderPandocMarkdown desc - let ticket = AP.Ticket - { AP.ticketLocal = Nothing - , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor - , AP.ticketPublished = Nothing - , AP.ticketUpdated = Nothing - , AP.ticketContext = Just context - , AP.ticketSummary = TextHtml title - , AP.ticketContent = TextHtml descHtml - , AP.ticketSource = TextPandocMarkdown desc - , AP.ticketAssignedTo = Nothing - , AP.ticketResolved = Nothing - , AP.ticketAttachment = Nothing - } - create = Create - { createObject = CreateTicket hLocal ticket - , createTarget = Just target - } - - return (summary, audience, create) - resolve :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent @@ -358,6 +317,7 @@ resolve shrUser uObject = runExceptT $ do recips = map encodeRouteHome audLocal ++ audRemote return (Nothing, Audience recips [] [] [] [] [], Resolve uObject) + -} undoFollow :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -369,6 +329,8 @@ undoFollow -> Route App -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do + error "Temporarily disabled" + {- encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome obiidFollow <- runSiteDBExcept $ do @@ -395,6 +357,7 @@ undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do } audience = Audience [encodeRouteHome recipRoute] [] [] [] [] [] return (summary, audience, undo) + -} undoFollowSharer :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -403,6 +366,8 @@ undoFollowSharer -> ShrIdent -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) undoFollowSharer shrAuthor pidAuthor shrFollowee = + error "Temporarily disabled" + {- undoFollow shrAuthor pidAuthor getFsid "sharer" objRoute objRoute where objRoute = SharerR shrFollowee @@ -432,6 +397,7 @@ undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee = mj <- lift $ getValBy $ UniqueProject prjFollowee sidFollowee 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) @@ -442,6 +408,8 @@ undoFollowTicket -> KeyHashid LocalTicket -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee = + error "Temporarily disabled" + {- undoFollow shrAuthor pidAuthor getFsid "project" objRoute recipRoute where objRoute = ProjectTicketR shrFollowee prjFollowee numFollowee @@ -467,6 +435,7 @@ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee = unless (ticketProjectLocalProject tpl == jid) $ throwE "Hashid doesn't match sharer/project" return $ localTicketFollowers lt + -} undoFollowRepo :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -476,6 +445,8 @@ undoFollowRepo -> RpIdent -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee = + error "Temporarily disabled" + {- undoFollow shrAuthor pidAuthor getFsid "repo" objRoute objRoute where objRoute = RepoR shrFollowee rpFollowee @@ -486,6 +457,7 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee = mr <- lift $ getValBy $ UniqueRepo rpFollowee sidFollowee repoFollowers <$> fromMaybeE mr "Unfollow target no such local repo" + -} unresolve :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -493,6 +465,8 @@ unresolve -> FedURI -> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode)) unresolve shrUser uTicket = runExceptT $ do + error "Temporarily disabled" + {- encodeRouteHome <- getEncodeRouteHome wiFollowers <- askWorkItemFollowers ticket <- parseWorkItem "Ticket" uTicket @@ -550,75 +524,7 @@ unresolve shrUser uTicket = runExceptT $ do recips = map encodeRouteHome audLocal ++ audRemote return (Nothing, Audience recips [] [] [] [] [], Undo uResolve) - -createMR - :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) - => ShrIdent - -> TextHtml - -> TextPandocMarkdown - -> FedURI - -> Maybe FedURI - -> PatchMediaType - -> Text - -> m (Either Text (Maybe TextHtml, Audience URIMode, AP.Ticket URIMode, Maybe FedURI)) -createMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - manager <- asksSite appHttpManager - hLocal <- asksSite siteInstanceHost - - context <- parseTicketContext uContext - descHtml <- - ExceptT . pure $ renderPandocMarkdown $ unTextPandocMarkdown desc - context' <- bitraverse pure (getRemoteContextHttp "Context") context - - let audAuthor = - AudLocal - [] - [LocalPersonCollectionSharerFollowers shrAuthor] - audContext = contextAudience context' - - uTarget = - case context' of - Left _ -> uContext - Right (uTracker, _, _, _) -> uTracker - (_, _, _, audLocal, audRemote) = - collectAudience $ audAuthor : audContext - - recips = map encodeRouteHome audLocal ++ audRemote - ObjURI hBranch luBranch = fromMaybe uContext muBranch - luAuthor = encodeRouteLocal $ SharerR shrAuthor - - ticket = AP.Ticket - { AP.ticketLocal = Nothing - , AP.ticketAttributedTo = luAuthor - , AP.ticketPublished = Nothing - , AP.ticketUpdated = Nothing - , AP.ticketContext = Just uContext - , AP.ticketSummary = title - , AP.ticketContent = TextHtml descHtml - , AP.ticketSource = desc - , AP.ticketAssignedTo = Nothing - , AP.ticketResolved = Nothing - , AP.ticketAttachment = Just - ( hBranch - , MergeRequest - { mrOrigin = Nothing - , mrTarget = luBranch - , mrBundle = Right - ( hLocal - , BundleOffer Nothing $ pure AP.Patch - { AP.patchLocal = Nothing - , AP.patchAttributedTo = luAuthor - , AP.patchPublished = Nothing - , AP.patchType = typ - , AP.patchContent = diff - } - ) - } - ) - } - return (Nothing, Audience recips [] [] [] [] [], ticket, Just uTarget) + -} offerMR :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -631,6 +537,8 @@ offerMR -> Text -> m (Either Text (Maybe TextHtml, Audience URIMode, AP.Ticket URIMode)) offerMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do + error "Temporarily disabled" + {- encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome manager <- asksSite appHttpManager @@ -684,6 +592,7 @@ offerMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do ) } return (Nothing, Audience recips [] [] [] [] [], ticket) + -} createDeck :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -692,6 +601,8 @@ createDeck -> Maybe Text -> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail, Maybe FedURI) createDeck shrAuthor name mdesc = do + error "Temporarily disabled" + {- encodeRouteHome <- getEncodeRouteHome let audAuthor = @@ -709,3 +620,4 @@ createDeck shrAuthor name mdesc = do } return (Nothing, Audience recips [] [] [] [] [], detail, Nothing) + -} diff --git a/src/Vervis/Cloth.hs b/src/Vervis/Cloth.hs new file mode 100644 index 0000000..b385430 --- /dev/null +++ b/src/Vervis/Cloth.hs @@ -0,0 +1,133 @@ +{- This file is part of Vervis. + - + - Written in 2020, 2022 by fr33domlover . + - + - β™‘ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Cloth + ( getCloth + , getCloth404 + ) +where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Maybe +import Data.Traversable +import Database.Persist +import Database.Persist.Sql +import Yesod.Core + +import Yesod.Hashids + +import Data.Either.Local +import Database.Persist.Local + +import Vervis.Foundation +import Vervis.Model + +getCloth + :: MonadIO m + => LoomId + -> TicketLoomId + -> ReaderT SqlBackend m + ( Maybe + ( Entity Loom + , Entity TicketLoom + , Entity Ticket + , Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote) + , Maybe + ( Entity TicketResolve + , Either + (Entity TicketResolveLocal) + (Entity TicketResolveRemote) + ) + , NonEmpty BundleId + ) + ) +getCloth lid tlid = runMaybeT $ do + l <- MaybeT $ get lid + tl <- MaybeT $ get tlid + guard $ ticketLoomLoom tl == lid + + let tid = ticketLoomTicket tl + t <- lift $ getJust tid + + bnids <- lift $ do + mne <- + nonEmpty <$> selectKeysList [BundleTicket ==. tlid] [Desc BundleId] + case mne of + Nothing -> error "Found Loom Ticket without any Bundles" + Just ne -> return ne + + author <- + lift $ + requireEitherAlt + (getBy $ UniqueTicketAuthorLocal tid) + (getBy $ UniqueTicketAuthorRemote tid) + "MR doesn't have author" + "MR has both local and remote author" + + mresolved <- lift $ getResolved tid + + return (Entity lid l, Entity tlid tl, Entity tid t, author, mresolved, bnids) + + where + + getResolved + :: MonadIO m + => TicketId + -> ReaderT SqlBackend m + (Maybe + ( Entity TicketResolve + , Either + (Entity TicketResolveLocal) + (Entity TicketResolveRemote) + ) + ) + getResolved tid = do + metr <- getBy $ UniqueTicketResolve tid + for metr $ \ etr@(Entity trid _) -> + (etr,) <$> + requireEitherAlt + (getBy $ UniqueTicketResolveLocal trid) + (getBy $ UniqueTicketResolveRemote trid) + "No TRX" + "Both TRL and TRR" + +getCloth404 + :: KeyHashid Loom + -> KeyHashid TicketLoom + -> AppDB + ( Entity Loom + , Entity TicketLoom + , Entity Ticket + , Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote) + , Maybe + ( Entity TicketResolve + , Either + (Entity TicketResolveLocal) + (Entity TicketResolveRemote) + ) + , NonEmpty BundleId + ) +getCloth404 lkhid tlkhid = do + lid <- decodeKeyHashid404 lkhid + tlid <- decodeKeyHashid404 tlkhid + mcloth <- getCloth lid tlid + case mcloth of + Nothing -> notFound + Just cloth -> return cloth diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 190c5af..248790d 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -15,13 +15,13 @@ -} module Vervis.Darcs - ( readSourceView - , readWikiView - , readChangesView - , lastChange - , readPatch - , writePostApplyHooks - , applyDarcsPatch + ( --readSourceView + --, readWikiView + --, readChangesView + --, lastChange + --, readPatch + writePostApplyHooks + --, applyDarcsPatch ) where @@ -45,6 +45,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8With, decodeUtf8) import Data.Text.Encoding.Error (strictDecode) import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) import Data.Traversable (for) +import Database.Persist import Development.Darcs.Internal.Hash.Codec import Development.Darcs.Internal.Hash.Types import Development.Darcs.Internal.Inventory.Parser @@ -71,6 +72,7 @@ import qualified Development.Darcs.Internal.Patch.Parser as P import Network.FedURI import Yesod.ActivityPub +import Yesod.Hashids import Yesod.MonadSite import Darcs.Local.Repository @@ -94,8 +96,8 @@ import Vervis.Path import Vervis.Readme import Vervis.Settings import Vervis.SourceTree -import Vervis.Wiki (WikiView (..)) +{- dirToAnchoredPath :: [EntryName] -> AnchoredPath dirToAnchoredPath = AnchoredPath . map (decodeWhiteName . encodeUtf8) @@ -164,7 +166,9 @@ readSourceView path dir = do let mitem = find expandedTree anch for mitem $ itemToSourceView (last dir) return $ renderSources dir <$> msv +-} +{- readWikiView :: (EntryName -> EntryName -> Maybe Text) -- ^ Page name predicate. Returns 'Nothing' for a file which isn't a page. @@ -214,7 +218,9 @@ readWikiView isPage isMain path dir = do mkview Nothing b = WikiViewRaw b mkview (Just mt) b = WikiViewPage mt b for mpage $ \ (load, mmtitle) -> mkview mmtitle <$> load +-} +{- readChangesView :: FilePath -- ^ Repository path @@ -383,20 +389,20 @@ readPatch path hash = handle $ runExceptT $ do mkedit' (Replace fp regex old new) = AddTextFile "Replace" 0 [T.concat ["replace ", T.pack fp, " ", regex, " ", old, " ", new]] mkedit' (Binary fp old new) = EditBinaryFile fp (fromIntegral $ B.length old) 0 (fromIntegral $ B.length new) 0 mkedit' (Pref pref old new) = AddTextFile "Pref" 0 [T.concat ["changepref ", pref, " ", old, " ", new]] +-} writePostApplyHooks :: WorkerDB () writePostApplyHooks = do - repos <- E.select $ E.from $ \ (r `E.InnerJoin` s) -> do - E.on $ r E.^. RepoSharer E.==. s E.^. SharerId - E.where_ $ r E.^. RepoVcs E.==. E.val VCSDarcs - return (s E.^. SharerIdent, r E.^. RepoIdent) hook <- asksSite $ appPostApplyHookFile . appSettings authority <- asksSite $ renderAuthority . siteInstanceHost - for_ repos $ \ (E.Value shr, E.Value rp) -> do - path <- askRepoDir shr rp + repos <- selectKeysList [RepoVcs ==. VCSDarcs] [] + for_ repos $ \ repoID -> do + repoHash <- encodeKeyHashid repoID + path <- askRepoDir repoHash liftIO $ - writeDefaultsFile path hook authority (shr2text shr) (rp2text rp) + writeDefaultsFile path hook authority (keyHashidText repoHash) +{- applyDarcsPatch shr rp patch = do path <- askRepoDir shr rp let input = BL.fromStrict $ TE.encodeUtf8 patch @@ -414,3 +420,4 @@ applyDarcsPatch shr rp patch = do , "\nstderr: ", out2text err ] ExitSuccess -> return () +-} diff --git a/src/Vervis/Delivery.hs b/src/Vervis/Delivery.hs new file mode 100644 index 0000000..b787bbc --- /dev/null +++ b/src/Vervis/Delivery.hs @@ -0,0 +1,807 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2020, 2021, 2022 by fr33domlover . + - + - β™‘ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Delivery + ( deliverHttp + , deliverHttpBL + , deliverRemoteDB_D + , deliverRemoteDB_P + , deliverRemoteDB_R + , deliverRemoteHTTP_D + , deliverRemoteHTTP_P + , deliverRemoteHTTP_R + , deliverRemoteDB' + , deliverRemoteDB'' + , deliverRemoteHttp + , deliverRemoteHttp' + , deliverLocal' + , deliverLocal + , insertRemoteActivityToLocalInboxes + ) +where + +import Control.Applicative +import Control.Exception hiding (Handler, try) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift +import Control.Monad.Logger.CallStack +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Bifunctor +import Data.Bitraversable +import Data.ByteString (ByteString) +import Data.Either +import Data.Foldable +import Data.Function +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import Data.Maybe +import Data.Semigroup +import Data.Text (Text) +import Data.Text.Encoding +import Data.Time.Clock +import Data.Traversable +import Database.Persist +import Database.Persist.Sql +import Network.HTTP.Client +import Network.TLS -- hiding (SHA256) +import Text.Blaze.Html (preEscapedToHtml) +import Text.Blaze.Html.Renderer.Text +import UnliftIO.Exception (try) +import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) +import Yesod.Core.Handler +import Yesod.Persist.Core + +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import qualified Data.List.NonEmpty as NE +import qualified Data.List as L +import qualified Data.List.Ordered as LO +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Database.Esqueleto as E + +import Yesod.HttpSignature + +import Database.Persist.JSON +import Network.FedURI +import Network.HTTP.Digest +import Yesod.ActivityPub +import Yesod.MonadSite +import Yesod.FedURI +import Yesod.Hashids + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Data.Either.Local +import Data.List.NonEmpty.Local +import Data.Patch.Local hiding (Patch) +import Data.Tuple.Local +import Database.Persist.Local + +import qualified Data.Patch.Local as P + +import Vervis.ActivityPub +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident +import Vervis.Recipient +import Vervis.RemoteActorStore +import Vervis.Settings +import Vervis.Time + +deliverHttp + :: (MonadSite m, SiteEnv m ~ App) + => AP.Doc AP.Activity URIMode + -> Maybe LocalURI + -> Host + -> LocalURI + -> m (Either AP.APPostError (Response ())) +deliverHttp doc mfwd h luInbox = + deliverActivity (ObjURI h luInbox) (ObjURI h <$> mfwd) doc + +deliverHttpBL + :: (MonadSite m, SiteEnv m ~ App) + => BL.ByteString + -> Maybe LocalURI + -> Host + -> LocalURI + -> m (Either AP.APPostError (Response ())) +deliverHttpBL body mfwd h luInbox = + deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body + +deliverRemoteDB_ + :: (MonadIO m, PersistRecordBackend fwder SqlBackend) + => (ForwardingId -> Key sender -> fwder) + -> BL.ByteString + -> RemoteActivityId + -> Key sender + -> ByteString + -> [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m + [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] +deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do + let body' = BL.toStrict body + makeFwd (RemoteRecipient raid _ _ msince) = + Forwarding raid ractid body' sig (isNothing msince) + fetchedDeliv <- for recips $ bitraverse pure $ \ rs -> do + fwds <- insertMany' makeFwd rs + insertMany' (flip makeFwder senderKey . snd) fwds + return $ takeNoError5 fetchedDeliv + where + takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs) + takeNoError5 = takeNoError noError + where + noError ((RemoteRecipient ak luA luI Nothing , fwid), fwrid) = Just (ak, luA, luI, fwid, fwrid) + noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing + +deliverRemoteDB_D + :: MonadIO m + => BL.ByteString + -> RemoteActivityId + -> DeckId + -> ByteString + -> [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m + [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderDeckId))] +deliverRemoteDB_D = deliverRemoteDB_ ForwarderDeck + +deliverRemoteDB_P + :: MonadIO m + => BL.ByteString + -> RemoteActivityId + -> PersonId + -> ByteString + -> [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m + [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderPersonId))] +deliverRemoteDB_P = deliverRemoteDB_ ForwarderPerson + +deliverRemoteDB_R + :: MonadIO m + => BL.ByteString + -> RemoteActivityId + -> RepoId + -> ByteString + -> [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m + [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))] +deliverRemoteDB_R = deliverRemoteDB_ ForwarderRepo + +deliverRemoteHTTP' + :: (MonadSite m, SiteEnv m ~ App, PersistRecordBackend fwder SqlBackend) + => UTCTime + -> LocalActor + -> BL.ByteString + -> ByteString + -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] + -> m () +deliverRemoteHTTP' now sender body sig fetched = do + let deliver h inbox = + forwardActivity (ObjURI h inbox) sig (renderLocalActor sender) body + traverse_ (fork . deliverFetched deliver now) fetched + where + fork = forkWorker "Inbox forwarding to remote members of local collections: delivery failed" + deliverFetched deliver now ((_, h), recips@(r :| rs)) = do + let (raid, _luActor, luInbox, fwid, forwarderKey) = r + e <- deliver h luInbox + let e' = case e of + Left err -> + if isInstanceErrorP err + then Nothing + else Just False + Right _resp -> Just True + case e' of + Nothing -> runSiteDB $ do + let recips' = NE.toList recips + updateWhere [RemoteActorId <-. map fst5 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + updateWhere [ForwardingId <-. map fourth5 recips'] [ForwardingRunning =. False] + Just success -> do + runSiteDB $ + if success + then do + delete forwarderKey + delete fwid + else do + updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + update fwid [ForwardingRunning =. False] + for_ rs $ \ (raid, _luActor, luInbox, fwid, forwarderKey) -> + fork $ do + e <- deliver h luInbox + runSiteDB $ + case e of + Left _err -> do + updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + update fwid [ForwardingRunning =. False] + Right _resp -> do + delete forwarderKey + delete fwid + +deliverRemoteHTTP_D + :: (MonadSite m, SiteEnv m ~ App) + => UTCTime + -> KeyHashid Deck + -> BL.ByteString + -> ByteString + -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderDeckId))] + -> m () +deliverRemoteHTTP_D now dkhid = + deliverRemoteHTTP' now $ LocalActorDeck dkhid + +deliverRemoteHTTP_P + :: (MonadSite m, SiteEnv m ~ App) + => UTCTime + -> KeyHashid Person + -> BL.ByteString + -> ByteString + -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderPersonId))] + -> m () +deliverRemoteHTTP_P now pkhid = deliverRemoteHTTP' now $ LocalActorPerson pkhid + +deliverRemoteHTTP_R + :: (MonadSite m, SiteEnv m ~ App) + => UTCTime + -> KeyHashid Repo + -> BL.ByteString + -> ByteString + -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))] + -> m () +deliverRemoteHTTP_R now rkhid = deliverRemoteHTTP' now $ LocalActorRepo rkhid + +deliverRemoteDB' + :: Host + -> OutboxItemId + -> [(Host, NonEmpty LocalURI)] + -> [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> AppDB + ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + ) +deliverRemoteDB' hContext = deliverRemoteDB'' [hContext] + +data Recip + = RecipRA (Entity RemoteActor) + | RecipURA (Entity UnfetchedRemoteActor) + | RecipRC (Entity RemoteCollection) + +deliverRemoteDB'' + :: MonadIO m + => [Host] + -> OutboxItemId + -> [(Host, NonEmpty LocalURI)] + -> [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend m + ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + ) +deliverRemoteDB'' hContexts obid recips known = do + recips' <- for recips $ \ (h, lus) -> do + let lus' = NE.nub lus + (iid, inew) <- idAndNew <$> insertBy' (Instance h) + if inew + then return ((iid, h), (Nothing, Nothing, Just lus')) + else do + es <- for lus' $ \ lu -> do + ma <- runMaybeT $ do + Entity roid ro <- MaybeT $ getBy $ UniqueRemoteObject iid lu + recip <- RecipRA <$> MaybeT (getBy $ UniqueRemoteActor roid) + <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor roid) + <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection roid) + return (ro, recip) + return $ + case ma of + Nothing -> Just $ Left lu + Just (ro, r) -> + case r of + RecipRA (Entity raid ra) -> Just $ Right $ Left $ RemoteRecipient raid (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra) + RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura) + RecipRC _ -> Nothing + let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es + (fetched, unfetched) = partitionEithers newKnown + return ((iid, h), (nonEmpty fetched, nonEmpty unfetched, nonEmpty unknown)) + let moreKnown = mapMaybe (\ (i, (f, _, _)) -> (i,) <$> f) recips' + unfetched = mapMaybe (\ (i, (_, uf, _)) -> (i,) <$> uf) recips' + stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips' + allFetched = unionRemotes known moreKnown + fetchedDeliv <- for allFetched $ \ (i, rs) -> + let fwd = snd i `elem` hContexts + in (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs + unfetchedDeliv <- for unfetched $ \ (i, rs) -> + let fwd = snd i `elem` hContexts + in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs + unknownDeliv <- for stillUnknown $ \ (i, lus) -> do + -- TODO maybe for URA insertion we should do insertUnique? + ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus + rs <- insertMany' (\ (_lu, roid) -> UnfetchedRemoteActor roid Nothing) ros + let fwd = snd i `elem` hContexts + (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs + return + ( takeNoError4 fetchedDeliv + , takeNoError3 unfetchedDeliv + , map + (second $ NE.map $ \ (((lu, _roid), ak), dlk) -> (ak, lu, dlk)) + unknownDeliv + ) + where + takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs) + takeNoError3 = takeNoError noError + where + noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk) + noError ((_ , _ , Just _ ), _ ) = Nothing + takeNoError4 = takeNoError noError + where + noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk) + noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing + +deliverRemoteHttp + :: Host + -> OutboxItemId + -> AP.Doc AP.Activity URIMode + -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + ) + -> Worker () +deliverRemoteHttp hContext = deliverRemoteHttp' [hContext] + +deliverRemoteHttp' + :: [Host] + -> OutboxItemId + -> AP.Doc AP.Activity URIMode + -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + ) + -> Worker () +deliverRemoteHttp' hContexts obid doc (fetched, unfetched, unknown) = do + logDebug' "Starting" + let deliver fwd h inbox = do + let fwd' = if h `elem` hContexts then Just fwd else Nothing + (isJust fwd',) <$> deliverHttp doc fwd' h inbox + now <- liftIO getCurrentTime + logDebug' $ + "Launching fetched " <> showHosts fetched + traverse_ (fork . deliverFetched deliver now) fetched + logDebug' $ + "Launching unfetched " <> showHosts unfetched + traverse_ (fork . deliverUnfetched deliver now) unfetched + logDebug' $ + "Launching unknown " <> showHosts unknown + traverse_ (fork . deliverUnfetched deliver now) unknown + logDebug' "Done (async delivery may still be running)" + where + showHosts = T.pack . show . map (renderAuthority . snd . fst) + logDebug' t = logDebug $ prefix <> t + where + prefix = + T.concat + [ "Outbox POST handler: deliverRemoteHttp obid#" + , T.pack $ show $ fromSqlKey obid + , ": " + ] + fork = forkWorker "Outbox POST handler: HTTP delivery" + deliverFetched deliver now ((_, h), recips@(r :| rs)) = do + logDebug'' "Starting" + let (raid, luActor, luInbox, dlid) = r + (_, e) <- deliver luActor h luInbox + e' <- case e of + Left err -> do + logError $ T.concat + [ "Outbox DL delivery #", T.pack $ show dlid + , " error for <", renderObjURI $ ObjURI h luActor + , ">: ", T.pack $ displayException err + ] + return $ + if isInstanceErrorP err + then Nothing + else Just False + Right _resp -> return $ Just True + case e' of + Nothing -> runSiteDB $ do + let recips' = NE.toList recips + updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False] + Just success -> do + runSiteDB $ + if success + then delete dlid + else do + updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + update dlid [DeliveryRunning =. False] + for_ rs $ \ (raid, luActor, luInbox, dlid) -> + fork $ do + (_, e) <- deliver luActor h luInbox + runSiteDB $ + case e of + Left err -> do + logError $ T.concat + [ "Outbox DL delivery #", T.pack $ show dlid + , " error for <", renderObjURI $ ObjURI h luActor + , ">: ", T.pack $ displayException err + ] + updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + update dlid [DeliveryRunning =. False] + Right _resp -> delete dlid + where + logDebug'' t = logDebug' $ T.concat ["deliverFetched ", renderAuthority h, t] + deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do + logDebug'' "Starting" + let (uraid, luActor, udlid) = r + e <- fetchRemoteActor iid h luActor + let e' = case e of + Left err -> Just Nothing + Right (Left err) -> + if isInstanceErrorG err + then Nothing + else Just Nothing + Right (Right mera) -> Just $ Just mera + case e' of + Nothing -> runSiteDB $ do + let recips' = NE.toList recips + updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] + updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False] + Just mmera -> do + for_ rs $ \ (uraid, luActor, udlid) -> + fork $ do + e <- fetchRemoteActor iid h luActor + case e of + Right (Right mera) -> + case mera of + Nothing -> runSiteDB $ delete udlid + Just (Entity raid ra) -> do + (fwd, e') <- deliver luActor h $ remoteActorInbox ra + runSiteDB $ + case e' of + Left _ -> do + updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + delete udlid + insert_ $ Delivery raid obid fwd False + Right _ -> delete udlid + _ -> runSiteDB $ do + updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] + update udlid [UnlinkedDeliveryRunning =. False] + case mmera of + Nothing -> runSiteDB $ do + updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] + update udlid [UnlinkedDeliveryRunning =. False] + Just mera -> + case mera of + Nothing -> runSiteDB $ delete udlid + Just (Entity raid ra) -> do + (fwd, e'') <- deliver luActor h $ remoteActorInbox ra + runSiteDB $ + case e'' of + Left _ -> do + updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + delete udlid + insert_ $ Delivery raid obid fwd False + Right _ -> delete udlid + where + logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", renderAuthority h, t] + +-- | Given a list of local recipients, which may include actors and +-- collections, +-- +-- * Insert activity to inboxes of actors +-- * If collections are listed, insert activity to the local members and return +-- the remote members +insertActivityToLocalInboxes + :: ( MonadSite m + , YesodHashids (SiteEnv m) + , PersistRecordBackend record SqlBackend + ) + => (InboxId -> InboxItemId -> record) + -- ^ Database record to insert as an new inbox item to each inbox + -> Bool + -- ^ Whether to deliver to collection only if owner actor is addressed + -> Maybe LocalActor + -- ^ An actor whose collections are excluded from requiring an owner, i.e. + -- even if owner is required, this actor's collections will be delivered + -- to, even if this actor isn't addressed. This is meant to be the + -- activity's author. + -> Maybe ActorId + -- ^ A un actor whose inbox to exclude from delivery, even if this actor is + -- listed in the recipient set. This is meant to be the activity's + -- author. + -> RecipientRoutes + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] +insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recips = do + + -- Predicate for filtering addressed stages + --allowStage <- getAllowStage + + -- Unhash actor and work item hashids + people <- unhashKeys $ recipPeople recips + groups <- unhashKeys $ recipGroups recips + repos <- unhashKeys $ recipRepos recips + decksAndTickets <- do + decks <- unhashKeys $ recipDecks recips + for decks $ \ (deckID, (DeckFamilyRoutes deck tickets)) -> + (deckID,) . (deck,) <$> unhashKeys tickets + loomsAndCloths <- do + looms <- unhashKeys $ recipLooms recips + for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) -> + (loomID,) . (loom,) <$> unhashKeys cloths + + -- Grab local actor sets whose stages are allowed for delivery + isAuthor <- getIsAuthor + let allowStages' + :: (famili -> routes) + -> (routes -> Bool) + -> (Key record -> LocalActorBy Key) + -> (Key record, famili) + -> Bool + allowStages' = allowStages isAuthor + + peopleForStages = + filter (allowStages' id routePerson LocalActorPerson) people + groupsForStages = + filter (allowStages' id routeGroup LocalActorGroup) groups + reposForStages = + filter (allowStages' id routeRepo LocalActorRepo) repos + decksAndTicketsForStages = + filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets + loomsAndClothsForStages = + filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths + + -- Grab local actors being addressed + let personIDsForSelf = + [ key | (key, routes) <- people, routePerson routes ] + groupIDsForSelf = + [ key | (key, routes) <- groups, routeGroup routes ] + repoIDsForSelf = + [ key | (key, routes) <- repos, routeRepo routes ] + deckIDsForSelf = + [ key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ] + loomIDsForSelf = + [ key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ] + + -- Grab actor actors whose followers are going to be delivered to + let personIDsForFollowers = + [ key | (key, routes) <- peopleForStages, routePersonFollowers routes ] + repoIDsForFollowers = + [ key | (key, routes) <- reposForStages, routeRepoFollowers routes ] + deckIDsForFollowers = + [ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ] + loomIDsForFollowers = + [ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ] + + -- Grab tickets and cloths whose followers are going to be delivered to + let ticketSetsForFollowers = + mapMaybe + (\ (deckID, (_, tickets)) -> (deckID,) <$> + NE.nonEmpty + [ ticketDeckID | (ticketDeckID, routes) <- tickets + , routeTicketFollowers routes + ] + ) + decksAndTicketsForStages + clothSetsForFollowers = + mapMaybe + (\ (loomID, (_, cloths)) -> (loomID,) <$> + NE.nonEmpty + [ ticketLoomID | (ticketLoomID, routes) <- cloths + , routeClothFollowers routes + ] + ) + loomsAndClothsForStages + + -- Get addressed Actor IDs from DB + actorIDsForSelf <- orderedUnion <$> sequenceA + [ selectActorIDsOrdered personActor PersonActor personIDsForSelf + , selectActorIDsOrdered groupActor GroupActor groupIDsForSelf + , selectActorIDsOrdered repoActor RepoActor repoIDsForSelf + , selectActorIDsOrdered deckActor DeckActor deckIDsForSelf + , selectActorIDsOrdered loomActor LoomActor loomIDsForSelf + ] + + -- Get actor and work item FollowerSet IDs from DB + followerSetIDs <- do + actorIDs <- concat <$> sequenceA + [ selectActorIDs personActor personIDsForFollowers + , selectActorIDs repoActor repoIDsForFollowers + , selectActorIDs deckActor deckIDsForFollowers + , selectActorIDs loomActor loomIDsForFollowers + ] + ticketIDs <- + concat <$> + ((++) + <$> traverse + (selectTicketIDs ticketDeckTicket TicketDeckDeck) + ticketSetsForFollowers + <*> traverse + (selectTicketIDs ticketLoomTicket TicketLoomLoom) + clothSetsForFollowers + ) + (++) + <$> (map (actorFollowers . entityVal) <$> + selectList [ActorId <-. actorIDs] [] + ) + <*> (map (ticketFollowers . entityVal) <$> + selectList [TicketId <-. ticketIDs] [] + ) + + -- Get the local and remote followers of the follower sets from DB + localFollowers <- + map (followActor . entityVal) <$> + selectList [FollowTarget <-. followerSetIDs] [Asc FollowActor] + remoteFollowers <- getRemoteFollowers followerSetIDs + + -- Insert inbox items to all local recipients, i.e. the local actors + -- directly addressed or listed in a local stage addressed + let localRecipients = + let allLocal = LO.union localFollowers actorIDsForSelf + in case maidAuthor of + Nothing -> allLocal + Just actorID -> LO.minus' allLocal [actorID] + inboxIDs <- + map (actorInbox . entityVal) <$> + selectList [ActorId <-. localRecipients] [] + inboxItemIDs <- insertMany $ replicate (length inboxIDs) $ InboxItem True + insertMany_ $ zipWith makeInboxItem inboxIDs inboxItemIDs + + -- Return remote followers, to whom we need to deliver via HTTP + return remoteFollowers + where + orderedUnion = foldl' LO.union [] + + unhashKeys + :: ( MonadSite m + , YesodHashids (SiteEnv m) + , ToBackendKey SqlBackend record + ) + => [(KeyHashid record, routes)] + -> m [(Key record, routes)] + unhashKeys actorSets = do + unhash <- decodeKeyHashidPure <$> asksSite siteHashidsContext + return $ mapMaybe (unhashKey unhash) actorSets + where + unhashKey unhash (hash, famili) = (,famili) <$> unhash hash + + getIsAuthor = + case mauthor of + Nothing -> pure $ const False + Just author -> maybe (const False) (==) <$> unhashLocalActor author + + allowStages + :: (LocalActorBy Key -> Bool) + -> (famili -> routes) + -> (routes -> Bool) + -> (Key record -> LocalActorBy Key) + -> (Key record, famili) + -> Bool + allowStages isAuthor familyActor routeActor makeActor (actorID, famili) + = routeActor (familyActor famili) + || not requireOwner + || isAuthor (makeActor actorID) + + selectActorIDs + :: (MonadIO m, PersistRecordBackend record SqlBackend) + => (record -> ActorId) + -> [Key record] + -> ReaderT SqlBackend m [ActorId] + selectActorIDs grabActor ids = + map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] [] + + selectActorIDsOrdered + :: (MonadIO m, PersistRecordBackend record SqlBackend) + => (record -> ActorId) + -> EntityField record ActorId + -> [Key record] + -> ReaderT SqlBackend m [ActorId] + selectActorIDsOrdered grabActor actorField ids = + map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] [Asc actorField] + + selectTicketIDs + :: ( MonadIO m + , PersistRecordBackend tracker SqlBackend + , PersistRecordBackend item SqlBackend + ) + => (item -> TicketId) + -> EntityField item (Key tracker) + -> (Key tracker, NonEmpty (Key item)) + -> ReaderT SqlBackend m [TicketId] + selectTicketIDs grabTicket trackerField (trackerID, workItemIDs) = do + maybeTracker <- get trackerID + case maybeTracker of + Nothing -> pure [] + Just _ -> + map (grabTicket . entityVal) <$> + selectList [persistIdField <-. NE.toList workItemIDs, trackerField ==. trackerID] [] + + getRemoteFollowers + :: MonadIO m + => [FollowerSetId] + -> ReaderT SqlBackend m + [((InstanceId, Host), NonEmpty RemoteRecipient)] + getRemoteFollowers fsids = + fmap groupRemotes $ + E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId + E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId + E.where_ $ rf E.^. RemoteFollowTarget `E.in_` E.valList fsids + E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId] + return + ( i E.^. InstanceId + , i E.^. InstanceHost + , ra E.^. RemoteActorId + , ro E.^. RemoteObjectIdent + , ra E.^. RemoteActorInbox + , ra E.^. RemoteActorErrorSince + ) + where + groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples + where + toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms) + +-- | Given a list of local recipients, which may include actors and +-- collections, +-- +-- * Insert activity to inboxes of actors +-- * If collections are listed, insert activity to the local members and return +-- the remote members +deliverLocal' + :: (MonadSite m, YesodHashids (SiteEnv m)) + => Bool -- ^ Whether to deliver to collection only if owner actor is addressed + -> LocalActor + -> ActorId + -> OutboxItemId + -> RecipientRoutes + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] +deliverLocal' requireOwner author aidAuthor obiid = + insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just aidAuthor) + where + makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid + +-- | Given a list of local recipients, which may include actors and +-- collections, +-- +-- * Insert activity to inboxes of actors +-- * If the author's follower collection is listed, insert activity to the +-- local members and return the remote members +-- * Ignore other collections +deliverLocal + :: KeyHashid Person + -> ActorId + -> OutboxItemId + -> RecipientRoutes + -> AppDB + [ ( (InstanceId, Host) + , NonEmpty RemoteRecipient + ) + ] +deliverLocal authorHash aidAuthor obiid + = deliverLocal' True (LocalActorPerson authorHash) aidAuthor obiid + . localRecipSieve sieve True + where + sieve = RecipientRoutes [(authorHash, PersonRoutes False True)] [] [] [] [] + +insertRemoteActivityToLocalInboxes + :: (MonadSite m, YesodHashids (SiteEnv m)) + => Bool + -> RemoteActivityId + -> RecipientRoutes + -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] +insertRemoteActivityToLocalInboxes requireOwner ractid = + insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing + where + makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Discussion.hs index 2ce47c9..5dcebb7 100644 --- a/src/Vervis/Discussion.hs +++ b/src/Vervis/Discussion.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. - @@ -18,9 +18,18 @@ module Vervis.Discussion , MessageTreeNode (..) , getDiscussionTree , getRepliesCollection + , NoteTopic (..) + , NoteParent (..) + , parseNoteContext + , parseNoteParent + , getLocalParentMessageId ) where +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except import Data.Graph.Inductive.Graph (mkGraph, lab') import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Graph.Inductive.Query.DFS (dffWith) @@ -39,7 +48,9 @@ import Web.ActivityPub import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids +import Yesod.MonadSite +import Control.Monad.Trans.Except.Local import Data.Tree.Local (sortForestOn) import Vervis.FedURI @@ -47,7 +58,7 @@ import Vervis.Foundation import Vervis.Model data MessageTreeNodeAuthor - = MessageTreeNodeLocal LocalMessageId Sharer + = MessageTreeNodeLocal LocalMessageId PersonId | MessageTreeNodeRemote Host LocalURI LocalURI (Maybe Text) data MessageTreeNode = MessageTreeNode @@ -59,12 +70,10 @@ data MessageTreeNode = MessageTreeNode getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode] getMessages getdid = runDB $ do did <- getdid - l <- select $ from $ \ (lm `InnerJoin` m `InnerJoin` p `InnerJoin` s) -> do - on $ p ^. PersonIdent ==. s ^. SharerId - on $ lm ^. LocalMessageAuthor ==. p ^. PersonId + l <- select $ from $ \ (lm `InnerJoin` m) -> do on $ lm ^. LocalMessageRest ==. m ^. MessageId where_ $ m ^. MessageRoot ==. val did - return (m, lm ^. LocalMessageId, s) + return (m, lm ^. LocalMessageId, lm ^. LocalMessageAuthor) r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` ra `InnerJoin` ro `InnerJoin` i `InnerJoin` ro2) -> do on $ rm ^. RemoteMessageIdent ==. ro2 ^. RemoteObjectId on $ ro ^. RemoteObjectInstance ==. i ^. InstanceId @@ -81,8 +90,8 @@ getMessages getdid = runDB $ do ) return $ map mklocal l ++ map mkremote r where - mklocal (Entity mid m, Value lmid, Entity _ s) = - MessageTreeNode mid m $ MessageTreeNodeLocal lmid s + mklocal (Entity mid m, Value lmid, Value pid) = + MessageTreeNode mid m $ MessageTreeNodeLocal lmid pid mkremote (Entity mid m, Value h, Value luMsg, Value luAuthor, Value name) = MessageTreeNode mid m $ MessageTreeNodeRemote h luMsg luAuthor name @@ -120,7 +129,8 @@ getRepliesCollection here getDiscussionId404 = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome encodeHid <- getEncodeKeyHashid - let localUri' = localUri encodeRouteHome encodeHid + hashPerson <- getEncodeKeyHashid + let localUri' = localUri hashPerson encodeRouteHome encodeHid replies = Collection { collectionId = encodeRouteLocal here , collectionType = CollectionTypeUnordered @@ -135,15 +145,13 @@ getRepliesCollection here getDiscussionId404 = do where selectLocals did = E.select $ E.from $ - \ (m `E.InnerJoin` lm `E.InnerJoin` p `E.InnerJoin` s) -> do - E.on $ p E.^. PersonIdent E.==. s E.^. SharerId - E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId + \ (m `E.InnerJoin` lm) -> do E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest E.where_ $ m E.^. MessageRoot E.==. E.val did E.&&. E.isNothing (m E.^. MessageParent) E.&&. E.isNothing (lm E.^. LocalMessageUnlinkedParent) - return (s E.^. SharerIdent, lm E.^. LocalMessageId) + return (lm E.^. LocalMessageAuthor, lm E.^. LocalMessageId) selectRemotes did = E.select $ E.from $ \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do @@ -155,6 +163,81 @@ getRepliesCollection here getDiscussionId404 = do E.isNothing (m E.^. MessageParent) E.&&. E.isNothing (rm E.^. RemoteMessageLostParent) return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) - localUri encR encH (E.Value shrAuthor, E.Value lmid) = - encR $ MessageR shrAuthor (encH lmid) + localUri hashPerson encR encH (E.Value pid, E.Value lmid) = + encR $ PersonMessageR (hashPerson pid) (encH lmid) remoteUri (E.Value h, E.Value lu) = ObjURI h lu + +data NoteTopic + = NoteTopicTicket DeckId TicketDeckId + | NoteTopicCloth LoomId TicketLoomId + deriving Eq + +parseNoteTopic (TicketR dkhid ltkhid) = + NoteTopicTicket + <$> decodeKeyHashidE dkhid "Note context invalid dkhid" + <*> decodeKeyHashidE ltkhid "Note context invalid ltkhid" +parseNoteTopic (ClothR lkhid ltkhid) = + NoteTopicCloth + <$> decodeKeyHashidE lkhid "Note context invalid lkhid" + <*> decodeKeyHashidE ltkhid "Note context invalid ltkhid" +parseNoteTopic _ = throwE "Local context isn't a ticket/cloth route" + +parseNoteContext + :: (MonadSite m, SiteEnv m ~ App) + => FedURI + -> ExceptT Text m (Either NoteTopic FedURI) +parseNoteContext uContext = do + let ObjURI hContext luContext = uContext + local <- hostIsLocal hContext + if local + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal luContext) + "Local context isn't a valid route" + parseNoteTopic route + else return $ Right uContext + +data NoteParent + = NoteParentMessage PersonId LocalMessageId + | NoteParentTopic NoteTopic + deriving Eq + +parseNoteParent + :: (MonadSite m, SiteEnv m ~ App) + => FedURI + -> ExceptT Text m (Either NoteParent FedURI) +parseNoteParent uParent = do + let ObjURI hParent luParent = uParent + local <- hostIsLocal hParent + if local + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal luParent) + "Local parent isn't a valid route" + (<|>) + (uncurry NoteParentMessage <$> parseNoteID route) + (NoteParentTopic <$> parseNoteTopic route) + else return $ Right uParent + where + parseNoteID (PersonMessageR pkhid lmkhid) = + (,) <$> decodeKeyHashidE pkhid + "Local parent has non-existent person hashid" + <*> decodeKeyHashidE lmkhid + "Local parent has non-existent message hashid" + parseNoteID _ = throwE "Local parent isn't a message route" + +getLocalParentMessageId :: DiscussionId -> PersonId -> LocalMessageId -> ExceptT Text AppDB MessageId +getLocalParentMessageId did pid lmid = do + mp <- lift $ get pid + _ <- fromMaybeE mp "Local parent: no such pid" + mlm <- lift $ get lmid + lm <- fromMaybeE mlm "Local parent: no such lmid" + unless (localMessageAuthor lm == pid) $ throwE "Local parent: No such message, lmid mismatches pid" + + let mid = localMessageRest lm + m <- lift $ getJust mid + unless (messageRoot m == did) $ + throwE "Local parent belongs to a different discussion" + return mid diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 343537c..fcbe049 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -13,11 +13,21 @@ - . -} +-- These are for Barbie-related generated instances for ForwarderBy +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +--{-# LANGUAGE StandaloneDeriving #-} +--{-# LANGUAGE UndecidableInstances #-} + module Vervis.Federation - ( handleSharerInbox - , handleProjectInbox + ( + {- + handlePersonInbox + , handleDeckInbox + , handleLoomInbox , handleRepoInbox - , fixRunningDeliveries + -} + fixRunningDeliveries , retryOutboxDelivery ) where @@ -33,6 +43,7 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Crypto.Hash import Data.Aeson +import Data.Barbie import Data.Bifunctor import Data.ByteString (ByteString) import Data.Either @@ -50,6 +61,7 @@ import Data.Traversable import Data.Tuple import Database.Persist hiding (deleteBy) import Database.Persist.Sql hiding (deleteBy) +import GHC.Generics import Network.HTTP.Client import Network.HTTP.Types.Header import Network.HTTP.Types.URI @@ -95,45 +107,22 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub -import Vervis.ActivityPub.Recipient import Vervis.ActorKey +import Vervis.Delivery import Vervis.Federation.Auth -import Vervis.Federation.Discussion -import Vervis.Federation.Offer -import Vervis.Federation.Push -import Vervis.Federation.Ticket import Vervis.Foundation import Vervis.Model -import Vervis.Model.Ident +import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings -prependError :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a -prependError t a = do - r <- lift $ runExceptT a - case r of - Left e -> throwE $ t <> ": " <> e - Right x -> return x - -parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m (KeyHashid LocalTicket) -parseTicket project luContext = do - route <- case decodeRouteLocal luContext of - Nothing -> throwE "Local context isn't a valid route" - Just r -> return r - case route of - ProjectTicketR shr prj num -> - if (shr, prj) == project - then return num - else throwE "Local context ticket doesn't belong to the recipient project" - _ -> throwE "Local context isn't a ticket route" - -handleSharerInbox - :: ShrIdent - -> UTCTime +{- +handlePersonInbox + :: KeyHashid Person -> ActivityAuthentication -> ActivityBody -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalPerson pidAuthor)) body = (,Nothing) <$> do +handlePersonInbox recipHash (ActivityAuthLocal (LocalActorPerson pidAuthor)) body = (,Nothing) <$> do (shrActivity, obiid) <- do luAct <- fromMaybeE @@ -274,7 +263,7 @@ handleSharerInbox shrRecip now (ActivityAuthRemote author) body = do localRecips <- do mrecips <- parseAudience $ activityAudience $ actbActivity body paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" - msig <- checkForward $ LocalActorSharer shrRecip + msig <- checkForwarding $ LocalActorSharer shrRecip let mfwd = (localRecips,) <$> msig case activitySpecific $ actbActivity body of AcceptActivity accept -> @@ -327,7 +316,58 @@ handleProjectInbox shrRecip prjRecip now auth body = do localRecips <- do mrecips <- parseAudience $ activityAudience $ actbActivity body paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" - msig <- checkForward $ LocalActorProject shrRecip prjRecip + msig <- checkForwarding $ LocalActorProject shrRecip prjRecip + let mfwd = (localRecips,) <$> msig + case activitySpecific $ actbActivity body of + CreateActivity (Create obj mtarget) -> + case obj of + CreateNote _ note -> + (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note + CreateTicket _ ticket -> + (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget + _ -> error "Unsupported create object type for projects" + FollowActivity follow -> + (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow + OfferActivity (Offer obj target) -> + case obj of + OfferTicket ticket -> + (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target + OfferDep dep -> + projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target + _ -> return ("Unsupported offer object type for projects", Nothing) + ResolveActivity resolve -> + (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve + UndoActivity undo -> + (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo + _ -> return ("Unsupported activity type for projects", Nothing) + where + errorLocalForwarded (ActivityAuthLocalPerson pid) = + "Project inbox got local forwarded activity by pid#" <> + T.pack (show $ fromSqlKey pid) + errorLocalForwarded (ActivityAuthLocalProject jid) = + "Project inbox got local forwarded activity by jid#" <> + T.pack (show $ fromSqlKey jid) + errorLocalForwarded (ActivityAuthLocalRepo rid) = + "Project inbox got local forwarded activity by rid#" <> + T.pack (show $ fromSqlKey rid) + +handleDeckInbox + :: KeyHashid Project + -> UTCTime + -> ActivityAuthentication + -> ActivityBody + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +handleDeckInbox dkkhid now auth body = do + remoteAuthor <- + case auth of + ActivityAuthLocal local -> throwE $ errorLocalForwarded local + ActivityAuthRemote ra -> return ra + luActivity <- + fromMaybeE (activityId $ actbActivity body) "Activity without 'id'" + localRecips <- do + mrecips <- parseAudience $ activityAudience $ actbActivity body + paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" + msig <- checkForwarding $ LocalActorProject shrRecip prjRecip let mfwd = (localRecips,) <$> msig case activitySpecific $ actbActivity body of CreateActivity (Create obj mtarget) -> @@ -379,7 +419,7 @@ handleRepoInbox shrRecip rpRecip now auth body = do localRecips <- do mrecips <- parseAudience $ activityAudience $ actbActivity body paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" - msig <- checkForward $ LocalActorRepo shrRecip rpRecip + msig <- checkForwarding $ LocalActorRepo shrRecip rpRecip let mfwd = (localRecips,) <$> msig case activitySpecific $ actbActivity body of ApplyActivity (AP.Apply uObject uTarget) -> @@ -420,6 +460,7 @@ handleRepoInbox shrRecip rpRecip now auth body = do errorLocalForwarded (ActivityAuthLocalRepo rid) = "Repo inbox got local forwarded activity by rid#" <> T.pack (show $ fromSqlKey rid) +-} fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m () fixRunningDeliveries = do @@ -442,23 +483,38 @@ fixRunningDeliveries = do , " forwarding deliveries" ] -data Fwder - = FwderProject ForwarderProjectId - | FwderSharer ForwarderSharerId - | FwderRepo ForwarderRepoId +data ForwarderBy f + = FwderPerson (f ForwarderPerson) + | FwderGroup (f ForwarderGroup) + | FwderRepo (f ForwarderRepo) + | FwderDeck (f ForwarderDeck) + | FwderLoom (f ForwarderLoom) + deriving (Generic, FunctorB, ConstraintsB) -partitionFwders :: [Fwder] -> ([ForwarderProjectId], [ForwarderSharerId], [ForwarderRepoId]) -partitionFwders = foldl' f ([], [], []) +partitionFwders + :: [ForwarderBy f] + -> ( [f ForwarderPerson] + , [f ForwarderGroup] + , [f ForwarderRepo] + , [f ForwarderDeck] + , [f ForwarderLoom] + ) +partitionFwders = foldl' f ([], [], [], [], []) where - f (js, ss, rs) (FwderProject j) = (j : js, ss , rs) - f (js, ss, rs) (FwderSharer s) = (js , s : ss, rs) - f (js, ss, rs) (FwderRepo r) = (js , ss , r : rs) + f (ps, gs, rs, ds, ls) = \ fwder -> + case fwder of + FwderPerson p -> (p : ps, gs, rs, ds, ls) + FwderGroup g -> (ps, g : gs, rs, ds, ls) + FwderRepo r -> (ps, gs, r : rs, ds, ls) + FwderDeck d -> (ps, gs, rs, d : ds, ls) + FwderLoom l -> (ps, gs, rs, ds, l : ls) retryOutboxDelivery :: Worker () retryOutboxDelivery = do logInfo "Periodic delivery starting" now <- liftIO $ getCurrentTime - (udls, dls, fws) <- runSiteDB $ do + (unlinkedHttp, linkedHttp, forwardingHttp) <- runSiteDB $ do + -- Get all unlinked deliveries which aren't running already in outbox -- post handlers unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc) -> do @@ -483,21 +539,27 @@ retryOutboxDelivery = do , ra E.?. RemoteActorId , rc E.?. RemoteCollectionId ) + -- Strip the E.Value wrappers and organize the records for the -- filtering and grouping we'll need to do let unlinked = map adaptUnlinked unlinked' + -- Split into found (recipient has been reached) and lonely (recipient -- hasn't been reached (found, lonely) = partitionMaybes unlinked + -- Turn the found ones into linked deliveries deleteWhere [UnlinkedDeliveryId <-. map (unlinkedID . snd) found] insertMany_ $ mapMaybe toLinked found + -- We're left with the lonely ones. We'll check which actors have been -- unreachable for too long, and we'll delete deliveries for them. The -- rest of the actors we'll try to reach by HTTP. dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings - let (lonelyOld, lonelyNew) = partitionEithers $ map (decideBySinceUDL dropAfter now) lonely + let (lonelyOld, lonelyNew) = + partitionEithers $ map (decideBySinceUDL dropAfter now) lonely deleteWhere [UnlinkedDeliveryId <-. lonelyOld] + -- Now let's grab the linked deliveries, and similarly delete old ones -- and return the rest for HTTP delivery. linked <- E.select $ E.from $ \ (dl `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` ob) -> do @@ -518,73 +580,68 @@ retryOutboxDelivery = do , dl E.^. DeliveryForwarding , ob E.^. OutboxItemActivity ) - let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked + let (linkedOld, linkedNew) = + partitionEithers $ + map (decideBySinceDL dropAfter now . adaptLinked) linked deleteWhere [DeliveryId <-. linkedOld] + -- Same for forwarding deliveries, which are always linked - forwarding <- E.select $ E.from $ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` (fwj `E.InnerJoin` j `E.InnerJoin` s) `E.LeftOuterJoin` (fws `E.InnerJoin` s2) `E.LeftOuterJoin` (fwr `E.InnerJoin` r `E.InnerJoin` s3)) -> do - E.on $ r E.?. RepoSharer E.==. s3 E.?. SharerId - E.on $ fwr E.?. ForwarderRepoSender E.==. r E.?. RepoId + forwarding <- E.select $ E.from $ + \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i + `E.LeftOuterJoin` fwp + `E.LeftOuterJoin` fwg + `E.LeftOuterJoin` fwr + `E.LeftOuterJoin` fwd + `E.LeftOuterJoin` fwl + ) -> do + E.on $ E.just (fw E.^. ForwardingId) E.==. fwl E.?. ForwarderLoomTask + E.on $ E.just (fw E.^. ForwardingId) E.==. fwd E.?. ForwarderDeckTask E.on $ E.just (fw E.^. ForwardingId) E.==. fwr E.?. ForwarderRepoTask - - E.on $ fws E.?. ForwarderSharerSender E.==. s2 E.?. SharerId - E.on $ E.just (fw E.^. ForwardingId) E.==. fws E.?. ForwarderSharerTask - - E.on $ j E.?. ProjectSharer E.==. s E.?. SharerId - E.on $ fwj E.?. ForwarderProjectSender E.==. j E.?. ProjectId - E.on $ E.just (fw E.^. ForwardingId) E.==. fwj E.?. ForwarderProjectTask - + E.on $ E.just (fw E.^. ForwardingId) E.==. fwg E.?. ForwarderGroupTask + E.on $ E.just (fw E.^. ForwardingId) E.==. fwp E.?. ForwarderPersonTask E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId E.where_ $ fw E.^. ForwardingRunning E.==. E.val False E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId] - return - ( i E.^. InstanceId - , i E.^. InstanceHost - , ra E.^. RemoteActorId - , ra E.^. RemoteActorInbox - , ra E.^. RemoteActorErrorSince - , fw E.^. ForwardingId - , fw E.^. ForwardingActivityRaw - - , fwj E.?. ForwarderProjectId - , s E.?. SharerIdent - , j E.?. ProjectIdent - - , fws E.?. ForwarderSharerId - , s2 E.?. SharerIdent - - , fwr E.?. ForwarderRepoId - , s3 E.?. SharerIdent - , r E.?. RepoIdent - - , fw E.^. ForwardingSignature - ) - let (forwardingOld, forwardingNew) = partitionEithers $ map (decideBySinceFW dropAfter now . adaptForwarding) forwarding + return (i, ra, fw, fwp, fwg, fwr, fwd, fwl) + let (forwardingOld, forwardingNew) = + partitionEithers $ + map (decideBySinceFW dropAfter now . adaptForwarding) + forwarding (fwidsOld, fwdersOld) = unzip forwardingOld - (fwjidsOld, fwsidsOld, fwridsOld) = partitionFwders fwdersOld - deleteWhere [ForwarderProjectId <-. fwjidsOld] - deleteWhere [ForwarderSharerId <-. fwsidsOld] + (fwpidsOld, fwgidsOld, fwridsOld, fwdidsOld, fwlidsOld) = + partitionFwders fwdersOld + deleteWhere [ForwarderPersonId <-. fwpidsOld] + deleteWhere [ForwarderGroupId <-. fwgidsOld] deleteWhere [ForwarderRepoId <-. fwridsOld] + deleteWhere [ForwarderDeckId <-. fwdidsOld] + deleteWhere [ForwarderLoomId <-. fwlidsOld] deleteWhere [ForwardingId <-. fwidsOld] - return (groupUnlinked lonelyNew, groupLinked linkedNew, groupForwarding forwardingNew) + + return + ( groupUnlinked lonelyNew + , groupLinked linkedNew + , groupForwarding forwardingNew + ) + let deliver = deliverHttpBL logInfo "Periodic delivery prepared DB, starting async HTTP POSTs" logDebug $ "Periodic delivery forking linked " <> - T.pack (show $ map (renderAuthority . snd . fst) dls) - waitsDL <- traverse (fork . deliverLinked deliver now) dls + T.pack (show $ map (renderAuthority . snd . fst) linkedHttp) + waitsDL <- traverse (fork . deliverLinked deliver now) linkedHttp logDebug $ "Periodic delivery forking forwarding " <> - T.pack (show $ map (renderAuthority . snd . fst) fws) - waitsFW <- traverse (fork . deliverForwarding now) fws + T.pack (show $ map (renderAuthority . snd . fst) forwardingHttp) + waitsFW <- traverse (fork . deliverForwarding now) forwardingHttp logDebug $ "Periodic delivery forking unlinked " <> - T.pack (show $ map (renderAuthority . snd . fst) udls) - waitsUDL <- traverse (fork . deliverUnlinked deliver now) udls + T.pack (show $ map (renderAuthority . snd . fst) unlinkedHttp) + waitsUDL <- traverse (fork . deliverUnlinked deliver now) unlinkedHttp logDebug $ T.concat @@ -621,10 +678,14 @@ retryOutboxDelivery = do , since ) ) + unlinkedID ((_, (_, (udlid, _, _, _))), _) = udlid + toLinked (Left raid, ((_, (_, (_, fwd, obid, _))), _)) = Just $ Delivery raid obid fwd False toLinked (Right _ , _ ) = Nothing + relevant dropAfter now since = addUTCTime dropAfter since > now + decideBySinceUDL dropAfter now (udl@(_, (_, (udlid, _, _, _))), msince) = case msince of Nothing -> Right udl @@ -632,9 +693,7 @@ retryOutboxDelivery = do if relevant dropAfter now since then Right udl else Left udlid - groupUnlinked - = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) - . groupWithExtractBy ((==) `on` fst) fst snd + adaptLinked (E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act) = ( ( (iid, h) @@ -642,6 +701,7 @@ retryOutboxDelivery = do ) , since ) + decideBySinceDL dropAfter now (dl@(_, (_, (dlid, _, _))), msince) = case msince of Nothing -> Right dl @@ -649,56 +709,58 @@ retryOutboxDelivery = do if relevant dropAfter now since then Right dl else Left dlid - groupLinked - = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) - . groupWithExtractBy ((==) `on` fst) fst snd + adaptForwarding - ( E.Value iid, E.Value h, E.Value raid, E.Value inbox, E.Value since - , E.Value fwid, E.Value body - , E.Value mfwjid, E.Value mprj, E.Value mshr - , E.Value mfwsid, E.Value mshr2 - , E.Value mfwrid, E.Value mrp, E.Value mshr3 - , E.Value sig + ( Entity iid (Instance h) + , Entity raid (RemoteActor _ _ inbox _ since) + , Entity fwid (Forwarding _ _ body sig _) + , mfwp, mfwg, mfwr, mfwd, mfwl ) = ( ( (iid, h) , ( (raid, inbox) , ( fwid , BL.fromStrict body - , let project = together3 mfwjid mprj mshr - sharer = together2 mfwsid mshr2 - repo = together3 mfwrid mrp mshr3 - in case (project, sharer, repo) of - (Just (fwjid, shr, prj), Nothing, Nothing) -> - (FwderProject fwjid, ProjectR shr prj) - (Nothing, Just (fwsid, shr), Nothing) -> - (FwderSharer fwsid, SharerR shr) - (Nothing, Nothing, Just (fwrid, shr, rp)) -> - (FwderRepo fwrid, RepoR shr rp) - _ -> error $ "Non-single fwder for fw#" ++ show fwid + , case (mfwp, mfwg, mfwr, mfwd, mfwl) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> + error "Found fwid without a Forwarder* record" + (Just fwp, Nothing, Nothing, Nothing, Nothing) -> + FwderPerson fwp + (Nothing, Just fwg, Nothing, Nothing, Nothing) -> + FwderGroup fwg + (Nothing, Nothing, Just fwr, Nothing, Nothing) -> + FwderRepo fwr + (Nothing, Nothing, Nothing, Just fwd, Nothing) -> + FwderDeck fwd + (Nothing, Nothing, Nothing, Nothing, Just fwl) -> + FwderLoom fwl + _ -> error "Found fwid with multiple forwarders" , sig ) ) ) , since ) - where - together2 (Just x) (Just y) = Just (x, y) - together2 Nothing Nothing = Nothing - together2 _ _ = error $ "Got weird forwarder for fw#" ++ show fwid - together3 :: Maybe a -> Maybe b -> Maybe c -> Maybe (a, b, c) - together3 (Just x) (Just y) (Just z) = Just (x, y, z) - together3 Nothing Nothing Nothing = Nothing - together3 _ _ _ = error $ "Got weird forwarder for fw#" ++ show fwid - decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, (fwder, _), _))), msince) = + + decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, fwder, _))), msince) = case msince of Nothing -> Right fw Just since -> if relevant dropAfter now since then Right fw - else Left (fwid, fwder) + else Left (fwid, bmap entityKey fwder) + + groupUnlinked + = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) + . groupWithExtractBy ((==) `on` fst) fst snd + + groupLinked + = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) + . groupWithExtractBy ((==) `on` fst) fst snd + groupForwarding = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) . groupWithExtractBy ((==) `on` fst) fst snd + fork action = do wait <- asyncWorker action return $ do @@ -708,6 +770,7 @@ retryOutboxDelivery = do logError $ "Periodic delivery error! " <> T.pack (displayException e) return False Right success -> return success + deliverLinked deliver now ((_, h), recips) = do logDebug $ "Periodic deliver starting linked for host " <> renderAuthority h waitsR <- for recips $ \ ((raid, (ident, inbox)), delivs) -> fork $ do @@ -740,6 +803,7 @@ retryOutboxDelivery = do unless (and results) $ logError $ "Periodic DL delivery error for host " <> renderAuthority h return True + deliverUnlinked deliver now ((iid, h), recips) = do logDebug $ "Periodic deliver starting unlinked for host " <> renderAuthority h waitsR <- for recips $ \ ((uraid, luRecip), delivs) -> fork $ do @@ -777,22 +841,27 @@ retryOutboxDelivery = do unless (and results) $ logError $ "Periodic UDL delivery error for host " <> renderAuthority h return True + deliverForwarding now ((_, h), recips) = do logDebug $ "Periodic deliver starting forwarding for host " <> renderAuthority h waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do logDebug $ "Periodic deliver starting forwarding for inbox " <> renderObjURI (ObjURI h inbox) - waitsD <- for delivs $ \ (fwid, body, (fwder, sender), sig) -> fork $ do + waitsD <- for delivs $ \ (fwid, body, fwderE, sig) -> fork $ do + let (fwderK, senderK) = splitForwarder fwderE + sender <- renderLocalActor <$> hashLocalActor senderK e <- forwardActivity (ObjURI h inbox) sig sender body case e of Left _err -> return False Right _resp -> do runSiteDB $ do - case fwder of - FwderProject k -> delete k - FwderSharer k -> delete k + case fwderK of + FwderPerson k -> delete k + FwderGroup k -> delete k FwderRepo k -> delete k + FwderDeck k -> delete k + FwderLoom k -> delete k delete fwid return True results <- sequence waitsD @@ -807,3 +876,14 @@ retryOutboxDelivery = do unless (and results) $ logError $ "Periodic FW delivery error for host " <> renderAuthority h return True + where + splitForwarder (FwderPerson (Entity f (ForwarderPerson _ p))) = + (FwderPerson f, LocalActorPerson p) + splitForwarder (FwderGroup (Entity f (ForwarderGroup _ g))) = + (FwderGroup f, LocalActorGroup g) + splitForwarder (FwderRepo (Entity f (ForwarderRepo _ r))) = + (FwderRepo f, LocalActorRepo r) + splitForwarder (FwderDeck (Entity f (ForwarderDeck _ d))) = + (FwderDeck f, LocalActorDeck d) + splitForwarder (FwderLoom (Entity f (ForwarderLoom _ l))) = + (FwderLoom f, LocalActorLoom l) diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index 68b0d98..0bea7c7 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/src/Vervis/Federation/Auth.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2022 by fr33domlover . - - β™‘ Copying is an act of love. Please copy, reuse and share. - @@ -15,10 +15,10 @@ module Vervis.Federation.Auth ( RemoteAuthor (..) - , ActivityAuthenticationLocal (..) , ActivityAuthentication (..) , ActivityBody (..) , authenticateActivity + , checkForwarding ) where @@ -94,12 +94,12 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub -import Vervis.ActivityPub.Recipient import Vervis.ActorKey import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings @@ -109,13 +109,8 @@ data RemoteAuthor = RemoteAuthor , remoteAuthorId :: RemoteActorId } -data ActivityAuthenticationLocal - = ActivityAuthLocalPerson PersonId - | ActivityAuthLocalProject ProjectId - | ActivityAuthLocalRepo RepoId - data ActivityAuthentication - = ActivityAuthLocal ActivityAuthenticationLocal + = ActivityAuthLocal (LocalActorBy Key) | ActivityAuthRemote RemoteAuthor data ActivityBody = ActivityBody @@ -271,7 +266,7 @@ verifySelfSig -> LocalRefURI -> ByteString -> Signature - -> ExceptT String Handler ActivityAuthenticationLocal + -> ExceptT String Handler (LocalActorBy Key) verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do author <- do route <- @@ -299,22 +294,25 @@ verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do ExceptT . pure $ verifySignature (actorKeyPublicBin akey) input sig unless valid $ throwE "Self sig verification says not valid" - ExceptT $ runDB $ do - mauthorId <- runMaybeT $ getLocalActor author - return $ - case mauthorId of - Nothing -> Left "Local author: No such user/project" - Just id_ -> Right id_ + localAuth <- unhashLocalActorE author "No such actor" + withExceptT T.unpack $ runDBExcept $ findLocalAuthInDB localAuth + return localAuth where - getLocalActor (LocalActorSharer shr) = do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - ActivityAuthLocalPerson <$> MaybeT (getKeyBy $ UniquePersonIdent sid) - getLocalActor (LocalActorProject shr prj) = do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - ActivityAuthLocalProject <$> MaybeT (getKeyBy $ UniqueProject prj sid) - getLocalActor (LocalActorRepo shr rp) = do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - ActivityAuthLocalRepo <$> MaybeT (getKeyBy $ UniqueRepo rp sid) + findLocalAuthInDB (LocalActorPerson pid) = do + mp <- lift $ get pid + when (isNothing mp) $ throwE "No such person" + findLocalAuthInDB (LocalActorGroup gid) = do + mg <- lift $ get gid + when (isNothing mg) $ throwE "No such group" + findLocalAuthInDB (LocalActorRepo rid) = do + mr <- lift $ get rid + when (isNothing mr) $ throwE "No such repo" + findLocalAuthInDB (LocalActorDeck did) = do + md <- lift $ get did + when (isNothing md) $ throwE "No such deck" + findLocalAuthInDB (LocalActorLoom lid) = do + ml <- lift $ get lid + when (isNothing ml) $ throwE "No such loom" verifyForwardedSig :: Host @@ -413,3 +411,31 @@ authenticateActivity now = do case parseObjURI =<< (first displayException . decodeUtf8') fwd of Left e -> throwE $ "ActivityPub-Forwarder isn't a valid FedURI: " <> T.pack e Right u -> return u + +checkForwarding recip = join <$> do + let hSig = hForwardingSignature + msig <- maybeHeader hSig + for msig $ \ sig -> do + _proof <- withExceptT (T.pack . displayException) $ ExceptT $ + let requires = [hDigest, hActivityPubForwarder] + in prepareToVerifyHttpSigWith hSig False requires [] Nothing + forwarder <- requireHeader hActivityPubForwarder + renderUrl <- getUrlRender + return $ + if forwarder == encodeUtf8 (renderUrl $ renderLocalActor recip) + then Just sig + else Nothing + where + maybeHeader n = do + let n' = decodeUtf8 $ CI.original n + hs <- lookupHeaders n + case hs of + [] -> return Nothing + [h] -> return $ Just h + _ -> throwE $ n' <> " multiple headers found" + requireHeader n = do + let n' = decodeUtf8 $ CI.original n + mh <- maybeHeader n + case mh of + Nothing -> throwE $ n' <> " header not found" + Just h -> return h diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 802fe1b..38b7f5d 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -65,13 +65,13 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub -import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Recipient import Vervis.Settings import Vervis.Ticket import Vervis.Patch @@ -209,14 +209,20 @@ updateOrphans author luNote did mid = do sharerCreateNoteF :: UTCTime - -> ShrIdent + -> PersonId -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) -> LocalURI -> Note URIMode -> ExceptT Text Handler Text -sharerCreateNoteF now shrRecip author body mfwd luCreate note = do +sharerCreateNoteF now pidRecip author body mfwd luCreate note = do + error "sharerCreateF temporarily disabled" + + +{- + + (luNote, published, context, mparent, source, content) <- checkNote note case context of Right uContext -> runDBExcept $ do @@ -338,18 +344,24 @@ sharerCreateNoteF now shrRecip author body mfwd luCreate note = do did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion" unless (messageRoot m == did) $ throwE "Remote parent belongs to a different discussion" +-} projectCreateNoteF :: UTCTime - -> ShrIdent - -> PrjIdent + -> KeyHashid Project -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) -> LocalURI -> Note URIMode -> ExceptT Text Handler Text -projectCreateNoteF now shrRecip prjRecip author body mfwd luCreate note = do +projectCreateNoteF now deckRecip author body mfwd luCreate note = do + error "projectCreateNoteF temporarily disabled" + + +{- + + (luNote, published, context, mparent, source, content) <- checkNote note case context of Right _ -> return "Not using; context isn't local" @@ -436,18 +448,24 @@ projectCreateNoteF now shrRecip prjRecip author body mfwd luCreate note = do Entity jid j <- getBy404 $ UniqueProject prjRecip sid a <- getJust $ projectActor j return (jid, actorInbox a) +-} repoCreateNoteF :: UTCTime - -> ShrIdent - -> RpIdent + -> KeyHashid Repo -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) -> LocalURI -> Note URIMode -> ExceptT Text Handler Text -repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do +repoCreateNoteF now repoRecip author body mfwd luCreate note = do + error "repoCreateNoteF temporarily disabled" + + +{- + + (luNote, published, context, mparent, source, content) <- checkNote note case context of Right _ -> return "Not using; context isn't local" @@ -535,3 +553,4 @@ repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do sid <- getKeyBy404 $ UniqueSharer shrRecip Entity rid r <- getBy404 $ UniqueRepo rpRecip sid return (rid, repoInbox r) +-} diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 31733e4..fc28528 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -89,7 +89,7 @@ import Vervis.Patch import Vervis.Ticket sharerAcceptF - :: ShrIdent + :: KeyHashid Person -> UTCTime -> RemoteAuthor -> ActivityBody @@ -97,7 +97,12 @@ sharerAcceptF -> LocalURI -> Accept URIMode -> ExceptT Text Handler Text -sharerAcceptF shr now author body mfwd luAccept (Accept (ObjURI hOffer luOffer) mresult) = do +sharerAcceptF recipHash now author body mfwd luAccept (Accept (ObjURI hOffer luOffer) mresult) = do + error "sharerAcceptF temporarily disabled" + +{- + + mres <- lift $ runDB $ do Entity pidRecip recip <- do sid <- getKeyBy404 $ UniqueSharer shr @@ -231,9 +236,10 @@ sharerAcceptF shr now author body mfwd luAccept (Accept (ObjURI hOffer luOffer) ( "Inserted remote reverse ticket dep" , (,collections) <$> msig ) +-} sharerRejectF - :: ShrIdent + :: KeyHashid Person -> UTCTime -> RemoteAuthor -> ActivityBody @@ -241,7 +247,14 @@ sharerRejectF -> LocalURI -> Reject URIMode -> ExceptT Text Handler Text -sharerRejectF shr now author body mfwd luReject (Reject (ObjURI hOffer luOffer)) = do +sharerRejectF recipHash now author body mfwd luReject (Reject (ObjURI hOffer luOffer)) = do + error "sharerRejectF temporarily disabled" + + +{- + + + lift $ runDB $ do Entity pidRecip recip <- do sid <- getKeyBy404 $ UniqueSharer shr @@ -277,7 +290,9 @@ sharerRejectF shr now author body mfwd luReject (Reject (ObjURI hOffer luOffer)) Just u -> u guard $ originalRecip == remoteAuthorURI author lift $ delete frrid +-} +{- followF :: (Route App -> Maybe a) -> Route App @@ -402,9 +417,10 @@ followF doc = accept $ Just luAct update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc) +-} sharerFollowF - :: ShrIdent + :: KeyHashid Person -> UTCTime -> RemoteAuthor -> ActivityBody @@ -412,7 +428,13 @@ sharerFollowF -> LocalURI -> AP.Follow URIMode -> ExceptT Text Handler Text -sharerFollowF shr = +sharerFollowF recipHash = + error "sharerFollowF temporarily disabled" + + +{- + + followF objRoute (SharerR shr) @@ -450,10 +472,10 @@ sharerFollowF shr = followers (p, Nothing) = personFollowers p followers (_, Just lt) = localTicketFollowers lt +-} projectFollowF - :: ShrIdent - -> PrjIdent + :: KeyHashid Project -> UTCTime -> RemoteAuthor -> ActivityBody @@ -461,7 +483,12 @@ projectFollowF -> LocalURI -> AP.Follow URIMode -> ExceptT Text Handler Text -projectFollowF shr prj = +projectFollowF deckHash = + error "projectFollowF temporarily disabled" + +{- + + followF objRoute (ProjectR shr prj) @@ -493,10 +520,10 @@ projectFollowF shr prj = followers (a, Nothing) = actorFollowers a followers (_, Just lt) = localTicketFollowers lt +-} repoFollowF - :: ShrIdent - -> RpIdent + :: KeyHashid Repo -> UTCTime -> RemoteAuthor -> ActivityBody @@ -504,7 +531,13 @@ repoFollowF -> LocalURI -> AP.Follow URIMode -> ExceptT Text Handler Text -repoFollowF shr rp = +repoFollowF repoHash = + error "repoFollowF temporarily disabled" + + +{- + + followF objRoute (RepoR shr rp) @@ -535,6 +568,7 @@ repoFollowF shr rp = followers (r, Nothing) = repoFollowers r followers (_, Just lt) = localTicketFollowers lt +-} getFollow (Left _) = return Nothing getFollow (Right ractid) = getBy $ UniqueRemoteFollowFollow ractid @@ -612,7 +646,7 @@ insertAcceptOnUndo actor author luUndo obiid auds = do actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp sharerUndoF - :: ShrIdent + :: KeyHashid Person -> UTCTime -> RemoteAuthor -> ActivityBody @@ -620,7 +654,13 @@ sharerUndoF -> LocalURI -> Undo URIMode -> ExceptT Text Handler Text -sharerUndoF shrRecip now author body mfwd luUndo (Undo uObj) = do +sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do + error "sharerUndoF temporarily disabled" + + +{- + + object <- parseActivity uObj mmmhttp <- runDBExcept $ do p <- lift $ do @@ -702,10 +742,10 @@ sharerUndoF shrRecip now author body mfwd luUndo (Undo uObj) = do audTicket = AudLocal [] [ticketFollowers] return ([ticketFollowers], [audAuthor, audTicket]) +-} projectUndoF - :: ShrIdent - -> PrjIdent + :: KeyHashid Project -> UTCTime -> RemoteAuthor -> ActivityBody @@ -713,7 +753,17 @@ projectUndoF -> LocalURI -> Undo URIMode -> ExceptT Text Handler Text -projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do +projectUndoF recipHash now author body mfwd luUndo (Undo uObj) = do + error "projectUndoF temporarily disabled" + + + + +{- + + + + object <- parseActivity uObj mmmhttp <- runDBExcept $ do (Entity jid j, a) <- lift $ do @@ -794,10 +844,10 @@ projectUndoF shrRecip prjRecip now author body mfwd luUndo (Undo uObj) = do audTicket = AudLocal [] [ticketFollowers] return ([ticketFollowers], [audAuthor, audTicket]) +-} repoUndoF - :: ShrIdent - -> RpIdent + :: KeyHashid Repo -> UTCTime -> RemoteAuthor -> ActivityBody @@ -805,7 +855,14 @@ repoUndoF -> LocalURI -> Undo URIMode -> ExceptT Text Handler Text -repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do +repoUndoF recipHash now author body mfwd luUndo (Undo uObj) = do + error "repoUndoF temporarily disabled" + + + +{- + + object <- parseActivity uObj mmmhttp <- runDBExcept $ do Entity rid r <- lift $ do @@ -885,3 +942,4 @@ repoUndoF shrRecip rpRecip now author body mfwd luUndo (Undo uObj) = do audTicket = AudLocal [] [ticketFollowers] return ([ticketFollowers], [audAuthor, audTicket]) +-} diff --git a/src/Vervis/Federation/Push.hs b/src/Vervis/Federation/Push.hs index 58f50ca..25bbf41 100644 --- a/src/Vervis/Federation/Push.hs +++ b/src/Vervis/Federation/Push.hs @@ -69,7 +69,7 @@ import Vervis.Model import Vervis.Model.Ident sharerPushF - :: ShrIdent + :: KeyHashid Person -> UTCTime -> RemoteAuthor -> ActivityBody @@ -77,7 +77,13 @@ sharerPushF -> LocalURI -> Push URIMode -> ExceptT Text Handler Text -sharerPushF shr now author body mfwd luPush push = do +sharerPushF recipHash now author body mfwd luPush push = do + error "sharerPushF temporarily disabled" + + +{- + + lift $ runDB $ do Entity pidRecip recip <- do sid <- getKeyBy404 $ UniqueSharer shr @@ -113,3 +119,4 @@ sharerPushF shr now author body mfwd luPush push = do delete ibiid return Nothing Just _ -> return $ Just ractid +-} diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index cdd6948..4627c8a 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -14,25 +14,18 @@ -} module Vervis.Federation.Ticket - ( sharerOfferTicketF - , projectOfferTicketF + ( personOfferTicketF + , deckOfferTicketF , repoOfferTicketF - , sharerCreateTicketF - , projectCreateTicketF - , repoCreateTicketF - - , sharerAddBundleF , repoAddBundleF , repoApplyF - , sharerOfferDepF - , projectOfferDepF + , deckOfferDepF , repoOfferDepF - , sharerResolveF - , projectResolveF + , deckResolveF , repoResolveF ) where @@ -96,7 +89,7 @@ import qualified Data.Text.UTF8.Local as TU import Development.PatchMediaType import Vervis.ActivityPub -import Vervis.ActivityPub.Recipient +import Vervis.Cloth import Vervis.Darcs import Vervis.FedURI import Vervis.Federation.Auth @@ -104,15 +97,15 @@ import Vervis.Federation.Util import Vervis.Foundation import Vervis.Git import Vervis.Model -import Vervis.Model.Ident import Vervis.Model.Role import Vervis.Model.Ticket -import Vervis.Patch import Vervis.Path import Vervis.Query +import Vervis.Recipient import Vervis.Ticket import Vervis.WorkItem +{- checkBranch :: Host -> LocalURI @@ -244,10 +237,11 @@ checkOfferTicket author ticket uTarget = do , diffs ) return $ Right (h, lu, Just bundle) +-} -sharerOfferTicketF +personOfferTicketF :: UTCTime - -> ShrIdent + -> KeyHashid Person -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) @@ -255,7 +249,12 @@ sharerOfferTicketF -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler Text -sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do +personOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do + error "sharerOfferTicketF temporarily disabled" + + + +{- (target, _, _, _) <- checkOfferTicket author ticket uTarget mractid <- runDBExcept $ do ibidRecip <- lift $ do @@ -278,7 +277,9 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do case mractid of Nothing -> "Activity already exists in my inbox" Just _ -> "Activity inserted to my inbox" +-} +{- insertLocalTicket now author txl summary content source ractidOffer obiidAccept = do did <- insert Discussion fsid <- insert FollowerSet @@ -307,11 +308,11 @@ insertLocalTicket now author txl summary content source ractidOffer obiidAccept , ticketAuthorRemoteOpen = ractidOffer } return (tid, ltid) +-} -projectOfferTicketF +deckOfferTicketF :: UTCTime - -> ShrIdent - -> PrjIdent + -> KeyHashid Deck -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) @@ -319,7 +320,11 @@ projectOfferTicketF -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler Text -projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarget = do +deckOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do + error "projectOfferTicketF temporarily disabled" + + +{- (target, summary, content, source) <- checkOfferTicket author ticket uTarget mmhttp <- for (targetRelevance target) $ \ () -> lift $ runDB $ do Entity jid j <- do @@ -416,11 +421,11 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) +-} repoOfferTicketF :: UTCTime - -> ShrIdent - -> RpIdent + -> KeyHashid Repo -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) @@ -428,7 +433,13 @@ repoOfferTicketF -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler Text -repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = do +repoOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do + error "repoOfferTicketF temporarily disabled" + + + +{- + (target, summary, content, source) <- checkOfferTicket author ticket uTarget mmhttp <- for (targetRelevance target) $ \ (mb, typ, diffs) -> runDBExcept $ do Entity rid r <- lift $ do @@ -529,7 +540,9 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) +-} +{- data RemoteBundle = RemoteBundle { rpBranch :: Maybe LocalURI , rpType :: PatchMediaType @@ -557,727 +570,11 @@ data ParsedCreateTicket = ParsedCreateTicket , pctDesc :: TextHtml , pctSource :: TextPandocMarkdown } - -checkCreateTicket - :: RemoteAuthor - -> AP.Ticket URIMode - -> Maybe FedURI - -> ExceptT Text Handler ParsedCreateTicket -checkCreateTicket author ticket muTarget = do - mtarget <- traverse (checkTracker "Create target") muTarget - (context, tlocal, published, summary, content, source) <- - checkTicket ticket - item <- checkTargetAndContext mtarget context - return $ ParsedCreateTicket item tlocal published summary content source - where - checkTracker - :: Text - -> FedURI - -> ExceptT Text Handler - (Either - (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) - FedURI - ) - checkTracker name u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - (name <> " is local but isn't a valid route") - case route of - ProjectR shr prj -> return $ Left (shr, prj) - RepoR shr rp -> return $ Right (shr, rp) - _ -> - throwE $ - name <> - " is a valid local route, but isn't a \ - \project/repo route" - else return $ Right u - checkTicket - :: AP.Ticket URIMode - -> ExceptT Text Handler - ( Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle) - , TicketLocal - , UTCTime - , TextHtml - , TextHtml - , TextPandocMarkdown - ) - checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary - content source muAssigned mresolved mmr) = do - (hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'" - hl <- hostIsLocal hTicket - when hl $ throwE "Remote author claims to create local ticket" - unless (hTicket == objUriAuthority (remoteAuthorURI author)) $ - throwE "Author created ticket hosted elsewhere" - unless (attrib == objUriLocal (remoteAuthorURI author)) $ - throwE "Author created ticket attibuted to someone else" - uContext <- fromMaybeE muContext "Ticket without 'context'" - context <- checkTracker "Ticket context" uContext - - pub <- fromMaybeE mpublished "Ticket without 'published'" - verifyNothingE mupdated "Ticket has 'updated'" - verifyNothingE muAssigned "Ticket has 'assignedTo'" - when (isJust mresolved) $ throwE "Ticket is resolved" - - mmr' <- traverse (uncurry $ checkMR $ ticketId tlocal) mmr - context' <- matchTicketAndMR (AP.ticketId tlocal) pub context mmr' - - return (context', tlocal, pub, summary, content, source) - where - checkMR - :: LocalURI - -> Host - -> MergeRequest URIMode - -> ExceptT Text Handler - ( Either (ShrIdent, RpIdent, Maybe Text) FedURI - , PatchMediaType - , NonEmpty (Maybe LocalURI, Maybe UTCTime, Text) - ) - checkMR luTicket h (MergeRequest muOrigin luTarget ebundle) = do - verifyNothingE muOrigin "MR with 'origin'" - branch <- checkBranch h luTarget - (typ, patches) <- - case ebundle of - Left _ -> throwE "MR bundle specified as a URI" - Right (hBundle, bundle) -> checkBundle hBundle bundle - case (typ, patches) of - (PatchMediaTypeDarcs, _ :| _ : _) -> - throwE "More than one Darcs patch bundle provided" - _ -> return () - return (branch, typ, patches) - where - checkBundle _ (AP.BundleHosted _ _) = - throwE "Patches specified as URIs" - checkBundle h (AP.BundleOffer mblocal patches) = do - for_ mblocal $ \ (h', BundleLocal _luId luCtx prevs mcurr) -> do - unless (h == h') $ - throwE "Bundle and author hosts differ" - unless (luCtx == luTicket) $ - throwE "Bundle 'context' doesn't match Ticket 'id'" - unless (null prevs) $ - throwE "Bundle has previous versions" - unless (isNothing mcurr) $ - throwE "Bundle has a more recent version" - (mlocal, mpub, typ, diff) :| patches' <- traverse (checkPatch h) patches - patches'' <- for patches' $ \ (mlocal', mpub', typ', diff') -> do - mluId <- for mlocal' $ \ (luId', luContext') -> do - for_ mlocal $ \ (_, luContext) -> - unless (luContext == luContext') $ - throwE "Patches have different context" - return luId' - unless (typ == typ') $ throwE "Different patch types" - return (mluId, mpub', diff') - return (typ, (fst <$> mlocal, mpub, diff) :| patches'') - where - checkPatch - :: Host - -> AP.Patch URIMode - -> ExceptT Text Handler - ( Maybe (LocalURI, LocalURI) - , Maybe UTCTime - , PatchMediaType - , Text - ) - checkPatch h (AP.Patch mlocal attrib mpub typ content) = do - mlocal' <- - for mlocal $ - \ (h', PatchLocal luId luContext) -> do - unless (h == h') $ - throwE "Patch & its author on different hosts" - return (luId, luContext) - unless (ObjURI h attrib == remoteAuthorURI author) $ - throwE "Ticket & Patch attrib mismatch" - return (mlocal', mpub, typ, content) - matchTicketAndMR - :: LocalURI - -> UTCTime - -> Either - (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) - FedURI - -> Maybe - ( Either (ShrIdent, RpIdent, Maybe Text) FedURI - , PatchMediaType - , NonEmpty (Maybe LocalURI, Maybe UTCTime, Text) - ) - -> ExceptT Text Handler (Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle)) - matchTicketAndMR _ _ (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj - matchTicketAndMR _ _ (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project" - matchTicketAndMR _ _ (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo" - matchTicketAndMR luTicket pub (Left (Right (shr, rp))) (Just (branch, typ, patches)) = do - branch' <- - case branch of - Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb - _ -> throwE "MR target repo/branch and Offer target repo mismatch" - case patchMediaTypeVCS typ of - VCSDarcs -> - unless (isNothing branch') $ - throwE "Darcs MR specifies a branch" - VCSGit -> - unless (isJust branch') $ - throwE "Git MR doesn't specify the branch" - diffs <- for patches $ \ (_mluId, mpub, diff) -> do - for_ mpub $ \ pub' -> - unless (pub == pub') $ - throwE "Ticket & Patch 'published' differ" - return diff - return $ Left $ WITRepo shr rp branch' typ diffs - matchTicketAndMR _ _ (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing) - matchTicketAndMR luTicket pub (Right (ObjURI h lu)) (Just (branch, typ, patches)) = do - luBranch <- - case branch of - Right (ObjURI h' lu') | h == h' -> return lu - _ -> throwE "MR target repo/branch and Offer target repo mismatch" - diffs <- for patches $ \ (_mluId, mpub, diff) -> do - for_ mpub $ \ pub' -> - unless (pub == pub') $ - throwE "Ticket & Patch 'published' differ" - return diff - let bundle = - RemoteBundle - (if lu == luBranch then Nothing else Just luBranch) - typ - diffs - return $ Right (h, lu, Just bundle) - checkTargetAndContext - :: Maybe - ( Either - (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) - FedURI - ) - -> Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle) - -> ExceptT Text Handler (Either (Bool, WorkItemTarget) RemoteWorkItem) - checkTargetAndContext Nothing context = - return $ - case context of - Left wit -> Left (False, wit) - Right (h, luCtx, mbundle) -> Right $ RemoteWorkItem h Nothing luCtx mbundle - checkTargetAndContext (Just target) context = - case (target, context) of - (Left _, Right _) -> - throwE "Create target is local but ticket context is remote" - (Right _, Left _) -> - throwE "Create target is remote but ticket context is local" - (Right (ObjURI hTarget luTarget), Right (hContext, luContext, mbundle)) -> - if hTarget == hContext - then return $ Right $ RemoteWorkItem hTarget (Just luTarget) luContext mbundle - else throwE "Create target and ticket context on \ - \different remote hosts" - (Left proj, Left wit) -> - case (proj, wit) of - (Left (shr, prj), WITProject shr' prj') - | shr == shr' && prj == prj' -> - return $ Left (True, wit) - (Right (shr, rp), WITRepo shr' rp' _ _ _) - | shr == shr' && rp == rp' -> - return $ Left (True, wit) - _ -> throwE - "Create target and ticket context are \ - \different local projects" - -sharerCreateTicketF - :: UTCTime - -> ShrIdent - -> RemoteAuthor - -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) - -> LocalURI - -> AP.Ticket URIMode - -> Maybe FedURI - -> ExceptT Text Handler Text -sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do - targetAndContext <- pctItem <$> checkCreateTicket author ticket muTarget - mractid <- runDBExcept $ do - ibidRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - personInbox <$> getValBy404 (UniquePersonIdent sid) - checkTargetAndContextDB targetAndContext - lift $ insertToInbox now author body ibidRecip luCreate True - return $ - case mractid of - Nothing -> "Activity already exists in my inbox" - Just _ -> "Activity inserted to my inbox" - where - checkTargetAndContextDB (Left (_, WITProject shr prj)) = do - mj <- lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - MaybeT $ getBy $ UniqueProject prj sid - unless (isJust mj) $ throwE "Local context: No such project" - checkTargetAndContextDB (Left (_, WITRepo shr rp _ _ _)) = do - mr <- lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - MaybeT $ getBy $ UniqueRepo rp sid - unless (isJust mr) $ throwE "Local context: No such repo" - checkTargetAndContextDB (Right _) = return () - -insertRemoteTicket - :: (MonadIO m, PersistRecordBackend txl SqlBackend) - => (TicketContextLocalId -> txl) - -> RemoteAuthor - -> LocalURI - -> UTCTime - -> TextHtml - -> TextHtml - -> TextPandocMarkdown - -> RemoteActivityId - -> OutboxItemId - -> ReaderT SqlBackend m (Either Bool TicketId) -insertRemoteTicket mktxl author luTicket published summary content source ractidCreate obiidAccept = do - tid <- insert Ticket - { ticketNumber = Nothing - , ticketCreated = published - , ticketTitle = unTextHtml summary - , ticketSource = unTextPandocMarkdown source - , ticketDescription = unTextHtml content - , ticketAssignee = Nothing - , ticketStatus = TSNew - } - tclid <- insert TicketContextLocal - { ticketContextLocalTicket = tid - , ticketContextLocalAccept = obiidAccept - } - txlid <- insert $ mktxl tclid - mtarid <- insertUnique TicketAuthorRemote - { ticketAuthorRemoteTicket = tclid - , ticketAuthorRemoteAuthor = remoteAuthorId author - , ticketAuthorRemoteOpen = ractidCreate - } - case mtarid of - Nothing -> do - delete txlid - delete tclid - delete tid - return $ Left False - Just tarid -> do - roid <- either entityKey id <$> insertBy' RemoteObject - { remoteObjectInstance = remoteAuthorInstance author - , remoteObjectIdent = luTicket - } - did <- insert Discussion - (rdid, rdnew) <- idAndNew <$> insertBy' RemoteDiscussion - { remoteDiscussionIdent = roid - , remoteDiscussionDiscuss = did - } - unless rdnew $ delete did - mrtid <- insertUnique RemoteTicket - { remoteTicketTicket = tarid - , remoteTicketIdent = roid - , remoteTicketDiscuss = rdid - } - case mrtid of - Nothing -> do - delete tarid - delete txlid - delete tclid - delete tid - return $ Left True - Just _rtid -> return $ Right tid - -insertAcceptOnCreate collections outboxItemRoute actorRoute author luCreate tlocal obiidAccept = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - - hLocal <- asksSite siteInstanceHost - - obikhidAccept <- encodeKeyHashid obiidAccept - - ra <- getJust $ remoteAuthorId author - - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audAuthorAndTicket = - AudRemote hAuthor [luAuthor] $ catMaybes - [ remoteActorFollowers ra - , Just $ AP.ticketParticipants tlocal - ] - audProject = AudLocal [] collections - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audAuthorAndTicket, audProject] - - recips = map encodeRouteHome audLocal ++ audRemote - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept - , activityActor = encodeRouteLocal actorRoute - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hAuthor luCreate - , acceptResult = Nothing - } - } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) - -insertAcceptOnCreate_J shr prj = - insertAcceptOnCreate - [ LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj - ] - (ProjectOutboxItemR shr prj) - (ProjectR shr prj) - -insertAcceptOnCreate_R shr rp = - insertAcceptOnCreate - [ LocalPersonCollectionRepoTeam shr rp - , LocalPersonCollectionRepoFollowers shr rp - ] - (RepoOutboxItemR shr rp) - (RepoR shr rp) - -projectCreateTicketF - :: UTCTime - -> ShrIdent - -> PrjIdent - -> RemoteAuthor - -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) - -> LocalURI - -> AP.Ticket URIMode - -> Maybe FedURI - -> ExceptT Text Handler Text -projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTarget = do - ParsedCreateTicket targetAndContext tlocal published title desc src <- - checkCreateTicket author ticket muTarget - mmhttp <- for (targetRelevance targetAndContext) $ \ () -> lift $ runDB $ do - Entity jid j <- do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniqueProject prjRecip sid - a <- getJust $ projectActor j - mractid <- insertToInbox now author body (actorInbox a) luCreate False - for mractid $ \ ractid -> do - 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 - for result $ \ _tid -> do - mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do - let sieve = - makeRecipientSet - [] - [ LocalPersonCollectionProjectTeam shrRecip prjRecip - , LocalPersonCollectionProjectFollowers shrRecip prjRecip - ] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False ractid $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - insertAcceptOnCreate_J shrRecip prjRecip author luCreate tlocal obiidAccept - knownRemoteRecipsAccept <- - deliverLocal' - False - (LocalActorProject shrRecip prjRecip) - (actorInbox a) - obiidAccept - localRecipsAccept - (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept - case mmhttp of - Nothing -> return "Create/Ticket against different project, not using" - Just mhttp -> - case mhttp of - Nothing -> return "Activity already in my inbox, doing nothing" - Just e -> - case e of - Left False -> return "Already have a ticket opened by this activity, ignoring" - Left True -> return "Already have this ticket, ignoring" - Right (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do - for_ mremotesHttpFwd $ \ (sig, remotes) -> - forkWorker "projectCreateTicketF inbox-forwarding" $ - deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes - forkWorker "projectCreateTicketF Accept HTTP delivery" $ - deliverRemoteHttp' fwdHosts obiid doc remotes - return $ - case mremotesHttpFwd of - Nothing -> "Accepted and listed ticket, no inbox-forwarding to do" - Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create" - where - targetRelevance (Left (_, WITProject shr prj)) - | shr == shrRecip && prj == prjRecip = Just () - targetRelevance _ = Nothing - -repoCreateTicketF - :: UTCTime - -> ShrIdent - -> RpIdent - -> RemoteAuthor - -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) - -> LocalURI - -> AP.Ticket URIMode - -> Maybe FedURI - -> ExceptT Text Handler Text -repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget = do - ParsedCreateTicket targetAndContext tlocal published title desc src <- - checkCreateTicket author ticket muTarget - mmhttp <- for (targetRelevance targetAndContext) $ \ (mb, typ, diffs) -> runDBExcept $ do - Entity rid r <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniqueRepo rpRecip sid - unless (repoVcs r == patchMediaTypeVCS typ) $ - throwE "Patch type and repo VCS mismatch" - mractid <- lift $ insertToInbox now author body (repoInbox r) luCreate False - lift $ for mractid $ \ ractid -> do - obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now - let mkTRL tclid = TicketRepoLocal tclid rid mb - result <- insertRemoteTicket mkTRL author (AP.ticketId tlocal) published title desc src ractid obiidAccept - unless (isRight result) $ delete obiidAccept - for result $ \ tid -> do - bnid <- insert $ Bundle tid - insertMany_ $ NE.toList $ NE.map (Patch bnid published typ) diffs - mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do - let sieve = - makeRecipientSet - [] - [ LocalPersonCollectionRepoTeam shrRecip rpRecip - , LocalPersonCollectionRepoFollowers shrRecip rpRecip - ] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False ractid $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - insertAcceptOnCreate_R shrRecip rpRecip author luCreate tlocal obiidAccept - knownRemoteRecipsAccept <- - deliverLocal' - False - (LocalActorRepo shrRecip rpRecip) - (repoInbox r) - obiidAccept - localRecipsAccept - (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept - case mmhttp of - Nothing -> return "Create/MR against different repo, not using" - Just mhttp -> - case mhttp of - Nothing -> return "Activity already in my inbox, doing nothing" - Just e -> - case e of - Left False -> return "Already have a MR opened by this activity, ignoring" - Left True -> return "Already have this MR, ignoring" - Right (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do - for_ mremotesHttpFwd $ \ (sig, remotes) -> - forkWorker "repoCreateTicketF inbox-forwarding" $ - deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes - forkWorker "repoCreateTicketF Accept HTTP delivery" $ - deliverRemoteHttp' fwdHosts obiid doc remotes - return $ - case mremotesHttpFwd of - Nothing -> "Accepted and listed MR, no inbox-forwarding to do" - Just _ -> "Accepted and listed MR and ran inbox-forwarding of the Create" - where - targetRelevance (Left (_, WITRepo shr rp mb vcs diffs)) - | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diffs) - targetRelevance _ = Nothing - -getSharerWorkItemDetail shrRecip talid patch = do - manager <- asksSite appHttpManager - (parentLtid, parentCtx) <- runSiteDBExcept $ do - let getTcr tcr = do - let getRoid roid = do - ro <- getJust roid - i <- getJust $ remoteObjectInstance ro - return $ mkuri (i, ro) - roidT <- remoteActorIdent <$> getJust (ticketProjectRemoteTracker tcr) - let mroidJ = ticketProjectRemoteProject tcr - (,) <$> getRoid roidT <*> traverse getRoid mroidJ - if patch - then do - (_, Entity ltid _, _, context, _, _) <- do - mticket <- lift $ getSharerProposal shrRecip talid - fromMaybeE mticket $ "Parent" <> ": No such sharer-patch" - context' <- - lift $ - bitraverse - (\ (_, Entity _ trl) -> do - r <- getJust $ ticketRepoLocalRepo trl - s <- getJust $ repoSharer r - return $ Right (sharerIdent s, repoIdent r) - ) - (\ (Entity _ tcr, _) -> getTcr tcr) - context - return (ltid, context') - else do - (_, Entity ltid _, _, context, _) <- do - mticket <- lift $ getSharerTicket shrRecip talid - fromMaybeE mticket $ "Parent" <> ": No such sharer-ticket" - context' <- - lift $ - bitraverse - (\ (_, Entity _ tpl) -> do - j <- getJust $ ticketProjectLocalProject tpl - s <- getJust $ projectSharer j - return $ Left (sharerIdent s, projectIdent j) - ) - (\ (Entity _ tcr, _) -> getTcr tcr) - context - return (ltid, context') - parentCtx' <- bifor parentCtx pure $ \ (uTracker, muProject) -> do - let uProject = fromMaybe uTracker muProject - obj <- withExceptT T.pack $ AP.fetchAP manager $ Left uProject - unless (objId obj == uProject) $ - throwE "Project 'id' differs from the URI we fetched" - return - (uTracker, objUriAuthority uProject, objFollowers obj, objTeam obj) - return (parentLtid, parentCtx') - -sharerAddBundleF - :: UTCTime - -> ShrIdent - -> RemoteAuthor - -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) - -> LocalURI - -> NonEmpty (AP.Patch URIMode) - -> FedURI - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -sharerAddBundleF now shrRecip author body mfwd luAdd patches uTarget = do - ticket <- parseWorkItem "Target" uTarget - (typ, diffs) <- do - ((typ, diff) :| rest) <- - for patches $ \ (AP.Patch mlocal attrib mpub typ content) -> do - verifyNothingE mlocal "Patch with 'id'" - unless (attrib == objUriLocal (remoteAuthorURI author)) $ - throwE "Add and Patch attrib mismatch" - verifyNothingE mpub "Patch has 'published'" - return (typ, content) - let (typs, diffs) = unzip rest - unless (all (== typ) typs) $ throwE "Patches of different media types" - return (typ, diff :| diffs) - personRecip <- lift $ runDB $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getValBy404 $ UniquePersonIdent sid - return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do - relevantTicket <- - for (ticketRelevance shrRecip ticket) $ \ talid -> do - (ltid, ctx) <- getSharerWorkItemDetail shrRecip talid True - return (talid, ltid, ctx) - mhttp <- runSiteDBExcept $ do - mractid <- lift $ insertToInbox now author body (personInbox personRecip) luAdd True - for mractid $ \ ractid -> do - mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do - relevantFollowers <- askRelevantFollowers - let sieve = - makeRecipientSet [] $ catMaybes - [ relevantFollowers shrRecip ticket - ] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False ractid $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips - mremotesHttpAccept <- for relevantTicket $ \ ticketData@(_, ltid, ctx) -> do - case ctx of - Left (Left _) -> error "Context of sharer-MR is a local project" - Left (Right (shr, rp)) -> do - mr <- lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - MaybeT $ getValBy $ UniqueRepo rp sid - let r = fromMaybe (error "Ticket context no such local repo in DB") mr - unless (repoVcs r == patchMediaTypeVCS typ) $ - throwE "Patch type and repo VCS mismatch" - Right _ -> pure () - obiidAccept <- lift $ insertEmptyOutboxItem (personOutbox personRecip) now - tid <- lift $ localTicketTicket <$> getJust ltid - bnid <- lift $ insert $ Bundle tid - lift $ insertMany_ $ NE.toList $ NE.map (Patch bnid now typ) diffs - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ insertAccept luAdd obiidAccept bnid ticketData - knownRemoteRecipsAccept <- - lift $ - deliverLocal' - False - (LocalActorSharer shrRecip) - (personInbox personRecip) - obiidAccept - localRecipsAccept - lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept - return (mremotesHttpFwd, mremotesHttpAccept) - case mhttp of - Nothing -> return "I already have this activity in my inbox, doing nothing" - Just (mremotesHttpFwd, mremotesHttpAccept) -> do - for_ mremotesHttpFwd $ \ (sig, remotes) -> - forkWorker "sharerAddBundleF inbox-forwarding" $ - deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes - for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) -> - forkWorker "sharerAddBundleF Accept HTTP delivery" $ - deliverRemoteHttp' fwdHosts obiid doc remotes - return $ - case (mremotesHttpAccept, mremotesHttpFwd) of - (Nothing, Nothing) -> "Ticket not mine, just stored in inbox and no inbox-forwarding to do" - (Nothing, Just _) -> "Ticket not mine, just stored in inbox and ran inbox-forwarding" - (Just _, Nothing) -> "Accepted new bundle, no inbox-forwarding to do" - (Just _, Just _) -> "Accepted new bundle and ran inbox-forwarding of the Add" - where - ticketRelevance shr (Left (WorkItemSharerTicket shr' talid True)) - | shr == shr' = Just talid - ticketRelevance _ _ = Nothing - askRelevantFollowers = do - hashTALID <- getEncodeKeyHashid - return $ \ shr wi -> followers hashTALID <$> ticketRelevance shr wi - where - followers hashTALID talid = - LocalPersonCollectionSharerProposalFollowers shrRecip $ - hashTALID talid - insertAccept luAdd obiidAccept bnid (talid, _, ctx) = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - followers <- askFollowers - workItemFollowers <- askWorkItemFollowers - hLocal <- asksSite siteInstanceHost - obikhidAccept <- encodeKeyHashid obiidAccept - talkhid <- encodeKeyHashid talid - bnkhid <- encodeKeyHashid bnid - ra <- getJust $ remoteAuthorId author - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audAuthor = - AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) - audContext = contextAudience ctx - audTicket = AudLocal [LocalActorSharer shrRecip] [followers talid] - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience $ audAuthor : audTicket : audContext - - recips = map encodeRouteHome audLocal ++ audRemote - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - SharerOutboxItemR shrRecip obikhidAccept - , activityActor = encodeRouteLocal $ SharerR shrRecip - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hAuthor luAdd - , acceptResult = - Just $ encodeRouteLocal $ - SharerProposalBundleR shrRecip talkhid bnkhid - } - } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) - where - askFollowers = do - hashTALID <- getEncodeKeyHashid - return $ LocalPersonCollectionSharerProposalFollowers shrRecip . hashTALID +-} repoAddBundleF :: UTCTime - -> ShrIdent - -> RpIdent + -> KeyHashid Repo -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) @@ -1285,7 +582,13 @@ repoAddBundleF -> NonEmpty (AP.Patch URIMode) -> FedURI -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -repoAddBundleF now shrRecip rpRecip author body mfwd luAdd patches uTarget = do +repoAddBundleF now recipHash author body mfwd luAdd patches uTarget = do + error "repoAddBundleF temporarily disabled" + + + +{- + ticket <- parseWorkItem "Target" uTarget (typ, diffs) <- do ((typ, diff) :| rest) <- @@ -1429,11 +732,11 @@ repoAddBundleF now shrRecip rpRecip author body mfwd luAdd patches uTarget = do \ ltid -> LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip (hashLTID ltid) +-} repoApplyF :: UTCTime - -> ShrIdent - -> RpIdent + -> KeyHashid Repo -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) @@ -1441,7 +744,13 @@ repoApplyF -> FedURI -> FedURI -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do +repoApplyF now recipHash author body mfwd luApply uObject uTarget = do + error "repoApplyF temporarily disabled" + + +{- + + -- Verify the patch bundle URI is one of: -- * A local sharer-hosted bundle -- * A local repo-hosted bundle under the receiving repo @@ -1981,10 +1290,11 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) +-} -sharerOfferDepF +personOfferDepF :: UTCTime - -> ShrIdent + -> KeyHashid Person -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) @@ -1992,7 +1302,13 @@ sharerOfferDepF -> AP.TicketDependency URIMode -> FedURI -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do +personOfferDepF now recipHash author body mfwd luOffer dep uTarget = do + error "sharerOfferDepF temporarily disabled" + + + + +{- (parent, child) <- checkDepAndTarget dep uTarget personRecip <- lift $ runDB $ do sid <- getKeyBy404 $ UniqueSharer shrRecip @@ -2143,9 +1459,11 @@ sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do then LocalPersonCollectionSharerProposalFollowers else LocalPersonCollectionSharerTicketFollowers in coll shrRecip (hashTALID talid) +-} mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro) +{- insertDep :: MonadIO m => UTCTime @@ -2179,11 +1497,11 @@ insertDep now author ractidOffer ltidParent child obiidAccept = do , ticketDependencyAuthorRemoteOpen = ractidOffer } return tdid +-} -projectOfferDepF +deckOfferDepF :: UTCTime - -> ShrIdent - -> PrjIdent + -> KeyHashid Deck -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) @@ -2191,7 +1509,14 @@ projectOfferDepF -> AP.TicketDependency URIMode -> FedURI -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do +deckOfferDepF now recipHash author body mfwd luOffer dep uTarget = do + error "projectOfferDepF temporarily disabled" + + + +{- + + (parent, child) <- checkDepAndTarget dep uTarget (Entity jidRecip projectRecip, actorRecip) <- lift $ runDB $ do sid <- getKeyBy404 $ UniqueSharer shrRecip @@ -2342,11 +1667,11 @@ projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do \ ltid -> LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip (hashLTID ltid) +-} repoOfferDepF :: UTCTime - -> ShrIdent - -> RpIdent + -> KeyHashid Repo -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) @@ -2354,7 +1679,13 @@ repoOfferDepF -> AP.TicketDependency URIMode -> FedURI -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do +repoOfferDepF now recipHash author body mfwd luOffer dep uTarget = do + error "repoOfferDepF temporarily disabled" + + +{- + + (parent, child) <- checkDepAndTarget dep uTarget Entity ridRecip repoRecip <- lift $ runDB $ do sid <- getKeyBy404 $ UniqueSharer shrRecip @@ -2504,7 +1835,9 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do \ ltid -> LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip (hashLTID ltid) +-} +{- verifyWorkItemExists (WorkItemSharerTicket shr talid False) = do mticket <- lift $ getSharerTicket shr talid verifyNothingE mticket $ "Object" <> ": No such sharer-ticket" @@ -2529,157 +1862,24 @@ insertResolve author ltid ractid obiidAccept = do , ticketResolveRemoteActivity = ractid , ticketResolveRemoteActor = remoteAuthorId author } +-} -sharerResolveF +deckResolveF :: UTCTime - -> ShrIdent + -> KeyHashid Deck -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) -> LocalURI -> Resolve URIMode -> ExceptT Text Handler Text -sharerResolveF now shrRecip author body mfwd luResolve (Resolve uObject) = do - object <- parseWorkItem "Resolve object" uObject - mmmmhttp <- runDBExcept $ do - personRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getValBy404 $ UniquePersonIdent sid - mltid <- - case relevantObject object of - Nothing -> do - case object of - Left wi -> verifyWorkItemExists wi - Right _ -> return () - return Nothing - Just (talid, patch) -> - Just . (talid,patch,) <$> getObjectLtid talid patch - mractid <- lift $ insertToInbox now author body (personInbox personRecip) luResolve True - lift $ for mractid $ \ ractid -> for mltid $ \ (talid, patch, (ltid, tid)) -> do - mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do - hashTALID <- getEncodeKeyHashid - let followers = - let collection = - if patch - then LocalPersonCollectionSharerProposalFollowers - else LocalPersonCollectionSharerTicketFollowers - in collection shrRecip $ hashTALID talid - sieve = - makeRecipientSet - [] - [ followers - , LocalPersonCollectionSharerFollowers shrRecip - ] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False ractid $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips - obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now - mmtrrid <- insertResolve author ltid ractid obiidAccept - case mmtrrid of - Just (Just _) -> update tid [TicketStatus =. TSClosed] - _ -> delete obiidAccept - for mmtrrid $ \ mtrrid -> for mtrrid $ \ trrid -> do - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - insertAccept luResolve talid patch obiidAccept - knownRemoteRecipsAccept <- - deliverLocal' - False - (LocalActorSharer shrRecip) - (personInbox personRecip) - obiidAccept - localRecipsAccept - (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept - case mmmmhttp of - Nothing -> return "I already have this activity in my inbox, doing nothing" - Just mmmhttp -> - case mmmhttp of - Nothing -> return "Object not mine, just stored in inbox" - Just mmhttp -> - case mmhttp of - Nothing -> return "Ticket already resolved" - Just mhttp -> - case mhttp of - Nothing -> return "Activity already resolved a ticket" - Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do - for_ mremotesHttpFwd $ \ (sig, remotes) -> - forkWorker "sharerResolveF inbox-forwarding" $ - deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes - forkWorker "sharerResolveF Accept HTTP delivery" $ - deliverRemoteHttp' fwdHosts obiid doc recips - return $ - if isJust mremotesHttpFwd - then "Ticket is mine, now resolved, did inbox-forwarding" - else "Ticket is mine, now resolved, no inbox-forwarding to do" - where - relevantObject (Left (WorkItemSharerTicket shr talid patch)) - | shr == shrRecip = Just (talid, patch) - relevantObject _ = Nothing +deckResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do + error "projectResolveF temporarily disabled" - getObjectLtid talid True = do - (_, Entity ltid _, Entity tid _, _, _, _) <- do - mticket <- lift $ getSharerProposal shrRecip talid - fromMaybeE mticket $ "Object" <> ": No such sharer-patch" - return (ltid, tid) - getObjectLtid talid False = do - (_, Entity ltid _, Entity tid _, _, _) <- do - mticket <- lift $ getSharerTicket shrRecip talid - fromMaybeE mticket $ "Object" <> ": No such sharer-ticket" - return (ltid, tid) - insertAccept luResolve talid patch obiidAccept = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - obikhidAccept <- encodeKeyHashid obiidAccept - talkhid <- encodeKeyHashid talid - ra <- getJust $ remoteAuthorId author - let ObjURI hAuthor luAuthor = remoteAuthorURI author +{- - audAuthor = - AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) - audTicket = - let followers = - if patch - then LocalPersonCollectionSharerProposalFollowers - else LocalPersonCollectionSharerTicketFollowers - in AudLocal [] [followers shrRecip talkhid] - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audAuthor, audTicket] - - recips = map encodeRouteHome audLocal ++ audRemote - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - SharerOutboxItemR shrRecip obikhidAccept - , activityActor = encodeRouteLocal $ SharerR shrRecip - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hAuthor luResolve - , acceptResult = Nothing - } - } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) - -projectResolveF - :: UTCTime - -> ShrIdent - -> PrjIdent - -> RemoteAuthor - -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) - -> LocalURI - -> Resolve URIMode - -> ExceptT Text Handler Text -projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObject) = do object <- parseWorkItem "Resolve object" uObject mmmmhttp <- runDBExcept $ do (Entity jidRecip projectRecip, actorRecip) <- lift $ do @@ -2799,18 +1999,25 @@ projectResolveF now shrRecip prjRecip author body mfwd luResolve (Resolve uObjec } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) +-} repoResolveF :: UTCTime - -> ShrIdent - -> RpIdent + -> KeyHashid Repo -> RemoteAuthor -> ActivityBody -> Maybe (LocalRecipientSet, ByteString) -> LocalURI -> Resolve URIMode -> ExceptT Text Handler Text -repoResolveF now shrRecip rpRecip author body mfwd luResolve (Resolve uObject) = do +repoResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do + error "repoResolveF temporarily disabled" + + + +{- + + object <- parseWorkItem "Resolve object" uObject mmmmhttp <- runDBExcept $ do Entity ridRecip repoRecip <- lift $ do @@ -2929,3 +2136,4 @@ repoResolveF now shrRecip rpRecip author body mfwd luResolve (Resolve uObject) = } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) +-} diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 56065e4..6742d85 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -72,12 +72,13 @@ import qualified Network.HTTP.Signature as S (Algorithm (..)) import Crypto.PublicVerifKey import Network.FedURI import Web.ActivityAccess -import Web.ActivityPub hiding (Ticket, TicketDependency, Bundle, Patch) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite +import qualified Web.ActivityPub as AP + import Text.Email.Local import Text.Jasmine.Local (discardm) import Yesod.Paginate.Local @@ -126,15 +127,20 @@ data App = App -- Aliases for the routes file, because it doesn't like spaces in path piece -- type names. +type PersonKeyHashid = KeyHashid Person +type GroupKeyHashid = KeyHashid Group +type RepoKeyHashid = KeyHashid Repo type OutboxItemKeyHashid = KeyHashid OutboxItem type SshKeyKeyHashid = KeyHashid SshKey type MessageKeyHashid = KeyHashid Message type LocalMessageKeyHashid = KeyHashid LocalMessage -type LocalTicketKeyHashid = KeyHashid LocalTicket -type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal type TicketDepKeyHashid = KeyHashid LocalTicketDependency type BundleKeyHashid = KeyHashid Bundle type PatchKeyHashid = KeyHashid Patch +type DeckKeyHashid = KeyHashid Deck +type LoomKeyHashid = KeyHashid Loom +type TicketDeckKeyHashid = KeyHashid TicketDeck +type TicketLoomKeyHashid = KeyHashid TicketLoom -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: @@ -203,13 +209,15 @@ instance Yesod App where csrfCheckMiddleware handler (getCurrentRoute >>= \ mr -> case mr of - Nothing -> return False - Just PostReceiveR -> return False - Just (SharerOutboxR _) -> return False - Just (SharerInboxR _) -> return False - Just (ProjectInboxR _ _) -> return False - Just (RepoInboxR _ _) -> return False - Just (GitUploadRequestR _ _) -> return False + Nothing -> return False + Just PostReceiveR -> return False + Just (PersonOutboxR _) -> return False + Just (PersonInboxR _) -> return False + Just (GroupInboxR _) -> return False + Just (RepoInboxR _) -> return False + Just (DeckInboxR _) -> return False + Just (LoomInboxR _) -> return False + Just (GitUploadRequestR _) -> return False Just (DvaraR _) -> return False Just r -> isWriteRequest r ) @@ -245,13 +253,14 @@ instance Yesod App where mperson <- do mperson' <- maybeAuthAllowUnverified for mperson' $ \ (p@(Entity pid person), verified) -> runDB $ do - sharer <- getJust $ personIdent person + inboxID <- actorInbox <$> getJust (personActor person) unread <- do - vs <- countUnread $ personInbox person + vs <- countUnread inboxID case vs :: [E.Value Int] of [E.Value i] -> return i _ -> error $ "countUnread returned " ++ show vs - return (p, verified, sharer, unread) + hash <- encodeKeyHashid pid + return (p, hash, verified, unread) (title, bcs) <- breadcrumbs -- We break up the default layout into two components: @@ -291,24 +300,34 @@ instance Yesod App where -- Who can access which pages. isAuthorized r w = case (r, w) of + + -- Authentication + (AuthR a , True) | a == resendVerifyR -> personFromResendForm (AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u - (PublishR , True) -> personAny + -- Client - (SharerInboxR shr , False) -> person shr - (NotificationsR shr , _ ) -> person shr - (SharerOutboxR shr , True) -> person shr - (SharerFollowR shr , True) -> personAny - (SharerUnfollowR shr , True) -> personAny + (NotificationsR, _ ) -> personAny + (PublishR , True) -> personAny + -- Person + + (PersonInboxR p , False) -> person p + (PersonOutboxR p , True) -> person p + + -- Group + + {- (GroupsR , True) -> personAny (GroupNewR , _ ) -> personAny (GroupMembersR grp , True) -> groupAdmin grp (GroupMemberNewR grp , _ ) -> groupAdmin grp (GroupMemberR grp _memb , True) -> groupAdmin grp + -} + {- (KeysR , _ ) -> personAny (KeyR _key , _ ) -> personAny (KeyNewR , _ ) -> personAny @@ -320,31 +339,33 @@ instance Yesod App where (ProjectRoleR shr _rl , _ ) -> personOrGroupAdmin shr (ProjectRoleOpsR shr _rl , _ ) -> personOrGroupAdmin shr (ProjectRoleOpNewR shr _rl , _ ) -> personOrGroupAdmin shr + -} + + -- Repo + + (RepoInboxR _ , False) -> personAny + + -- Deck + + (DeckInboxR _ , False) -> personAny + + -- Loom + + (LoomInboxR _ , False) -> personAny + + + + + + - (ReposR shr , True) -> personOrGroupAdmin shr - (RepoNewR shr , _ ) -> personOrGroupAdmin shr - (RepoR shar _ , True) -> person shar - (RepoEditR shr _rp , _ ) -> person shr - (RepoFollowR _shr _rp , True) -> personAny - (RepoUnfollowR _shr _rp , True) -> personAny - (RepoDevsR shr _rp , _ ) -> person shr - (RepoDevNewR shr _rp , _ ) -> person shr - (RepoDevR shr _rp _dev , _ ) -> person shr - (ProjectsR shr , True) -> personOrGroupAdmin shr - (ProjectNewR shr , _ ) -> personOrGroupAdmin shr - (ProjectR shr _prj , True) -> person shr - (ProjectEditR shr _prj , _ ) -> person shr - (ProjectFollowR _shr _prj , _ ) -> personAny - (ProjectUnfollowR _shr _prj , _ ) -> personAny - (ProjectDevsR shr _prj , _ ) -> person shr - (ProjectDevNewR shr _prj , _ ) -> person shr - (ProjectDevR shr _prj _dev , _ ) -> person shr -- (GlobalWorkflowsR , _ ) -> serverAdmin -- (GlobalWorkflowNewR , _ ) -> serverAdmin -- (GlobalWorkflowR _wfl , _ ) -> serverAdmin + {- (WorkflowsR shr , _ ) -> personOrGroupAdmin shr (WorkflowNewR shr , _ ) -> personOrGroupAdmin shr (WorkflowR shr _wfl , _ ) -> personOrGroupAdmin shr @@ -357,7 +378,9 @@ instance Yesod App where (WorkflowEnumCtorsR shr _ _ , _ ) -> personOrGroupAdmin shr (WorkflowEnumCtorNewR shr _ _ , _ ) -> personOrGroupAdmin shr (WorkflowEnumCtorR shr _ _ _ , _ ) -> personOrGroupAdmin shr + -} + {- (ProjectTicketsR s j , True) -> projOp ProjOpOpenTicket s j (ProjectTicketNewR s j , _ ) -> projOp ProjOpOpenTicket s j (ProjectTicketR user _ _ , True) -> person user @@ -380,6 +403,8 @@ instance Yesod App where (ProjectTicketDepsR s j _ , True) -> projOp ProjOpAddTicketDep s j (ProjectTicketDepNewR s j _ , _ ) -> projOp ProjOpAddTicketDep s j (TicketDepOldR s j _ _ , True) -> projOp ProjOpRemoveTicketDep s j + -} + _ -> return Authorized where nobody :: Handler AuthResult @@ -412,11 +437,10 @@ instance Yesod App where personAny :: Handler AuthResult personAny = personAnd $ \ _p -> return Authorized - person :: ShrIdent -> Handler AuthResult - person ident = personAnd $ \ (Entity _ p) -> do - let sid = personIdent p - sharer <- runDB $ getJust sid - return $ if ident == sharerIdent sharer + person :: KeyHashid Person -> Handler AuthResult + person hash = personAnd $ \ (Entity pid _) -> do + hash' <- encodeKeyHashid pid + return $ if hash == hash' then Authorized else Unauthorized "No access to this operation" @@ -454,6 +478,7 @@ instance Yesod App where return $ Unauthorized "Requesting resend for invalid username" + {- groupRole :: (GroupRole -> Bool) -> ShrIdent -> Handler AuthResult groupRole role grp = personAnd $ \ (Entity pid _p) -> runDB $ do Entity sid _s <- getBy404 $ UniqueSharer grp @@ -507,6 +532,7 @@ instance Yesod App where _ -> Unauthorized "You need a project role with that operation enabled" + -} -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows @@ -605,38 +631,42 @@ instance AccountDB AccountPersistDB' where addNewUser name email key pwd = AccountPersistDB' $ runDB $ do now <- liftIO getCurrentTime - let sharer = Sharer - { sharerIdent = text2shr name - , sharerName = Nothing - , sharerCreated = now + ibid <- insert Inbox + obid <- insert Outbox + fsid <- insert FollowerSet + let actor = Actor + { actorName = name + , actorDesc = "" + , actorCreatedAt = now + , actorInbox = ibid + , actorOutbox = obid + , actorFollowers = fsid } - msid <- insertBy sharer - case msid of + aid <- insert actor + let defTime = UTCTime (ModifiedJulianDay 0) 0 + person = Person + { personUsername = text2username $ name + , personLogin = name + , personPassphraseHash = pwd + , personEmail = email + , personVerified = False + , personVerifiedKey = key + , personVerifiedKeyCreated = now + , personResetPassKey = "" + , personResetPassKeyCreated = defTime + , personActor = aid + -- , personReviewFollow = True + } + mpid <- insertBy person + case mpid of Left _ -> do + delete aid + delete ibid + delete obid + delete fsid mr <- getMessageRender return $ Left $ mr $ MsgUsernameExists name - Right sid -> do - ibid <- insert Inbox - obid <- insert Outbox - fsid <- insert FollowerSet - let defTime = UTCTime (ModifiedJulianDay 0) 0 - person = Person - { personIdent = sid - , personLogin = name - , personPassphraseHash = pwd - , personEmail = email - , personVerified = False - , personVerifiedKey = key - , personVerifiedKeyCreated = now - , personResetPassKey = "" - , personResetPassKeyCreated = defTime - , personAbout = "" - , personInbox = ibid - , personOutbox = obid - , personFollowers = fsid - } - pid <- insert person - return $ Right $ Entity pid person + Right pid -> return $ Right $ Entity pid person verifyAccount = morphAPDB . verifyAccount setVerifyKey = (morphAPDB .) . setVerifyKey @@ -744,7 +774,7 @@ instance YesodRemoteActorStore App where instance YesodActivityPub App where siteInstanceHost = appInstanceHost . appSettings sitePostSignedHeaders _ = - hRequestTarget :| [hHost, hDate, hDigest, hActivityPubActor] + hRequestTarget :| [hHost, hDate, hDigest, AP.hActivityPubActor] siteGetHttpSign = do (akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys renderUrl <- askUrlRender @@ -759,6 +789,7 @@ instance YesodPaginate App where instance YesodBreadcrumbs App where breadcrumb route = return $ case route of + {- StaticR _ -> ("", Nothing) FaviconSvgR -> ("", Nothing) FaviconPngR -> ("", Nothing) @@ -985,5 +1016,6 @@ instance YesodBreadcrumbs App where ) WikiPageR shr prj _page -> ("Wiki", Just $ ProjectR shr prj) + -} _ -> ("PAGE TITLE HERE", Just HomeR) diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 33ea6f6..5d549a7 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -15,13 +15,16 @@ -} module Vervis.Git - ( readSourceView + ( + {- + readSourceView , readChangesView , listRefs , readPatch , lastCommitTime - , writePostReceiveHooks - , applyGitPatches + -} + writePostReceiveHooks + --, applyGitPatches ) where @@ -53,6 +56,7 @@ import Data.Time.Clock (UTCTime (..)) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Traversable (for) import Data.Word (Word32) +import Database.Persist import System.Exit import System.Hourglass (timeCurrent) import System.Process.Typed @@ -73,6 +77,7 @@ import qualified Database.Esqueleto as E import Network.FedURI import Yesod.ActivityPub +import Yesod.Hashids import Yesod.MonadSite import Data.ByteString.Char8.Local (takeLine) @@ -95,6 +100,7 @@ import Vervis.Readme import Vervis.Settings import Vervis.SourceTree +{- matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool matchReadme (_, _, name, EntObjBlob) = isReadme name matchReadme _ = False @@ -340,19 +346,19 @@ lastCommitTime repo = utc (Elapsed (Seconds i)) = posixSecondsToUTCTime $ fromIntegral i utc0 = UTCTime (ModifiedJulianDay 0) 0 foldlM' i l f = foldlM f i l +-} writePostReceiveHooks :: WorkerDB () writePostReceiveHooks = do - repos <- E.select $ E.from $ \ (r `E.InnerJoin` s) -> do - E.on $ r E.^. RepoSharer E.==. s E.^. SharerId - E.where_ $ r E.^. RepoVcs E.==. E.val VCSGit - return (s E.^. SharerIdent, r E.^. RepoIdent) hook <- asksSite $ appPostReceiveHookFile . appSettings authority <- asksSite $ renderAuthority . siteInstanceHost - for_ repos $ \ (E.Value shr, E.Value rp) -> do - path <- askRepoDir shr rp - liftIO $ writeHookFile path hook authority (shr2text shr) (rp2text rp) + repos <- selectKeysList [RepoVcs ==. VCSGit] [] + for_ repos $ \ repoID -> do + repoHash <- encodeKeyHashid repoID + path <- askRepoDir repoHash + liftIO $ writeHookFile path hook authority (keyHashidText repoHash) +{- applyGitPatches shr rp branch patches = do path <- askRepoDir shr rp let input = BL.concat $ NE.toList $ NE.map (BL.fromStrict . TE.encodeUtf8) patches @@ -373,3 +379,4 @@ applyGitPatches shr rp branch patches = do ExitSuccess -> return () where out2text = TU.decodeLenient . BL.toStrict +-} diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 4efca13..107b25c 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -15,36 +15,27 @@ -} module Vervis.Handler.Client - ( getPublishR - , postSharerOutboxR - , postPublishR + ( getResendVerifyEmailR + , getActorKey1R + , getActorKey2R + , getHomeR , getBrowseR - - , postSharerFollowR - , postProjectFollowR - , postProjectTicketFollowR - , postRepoFollowR - - , postSharerUnfollowR - , postProjectUnfollowR - , postProjectTicketUnfollowR - , postRepoUnfollowR - , getNotificationsR , postNotificationsR - - , postProjectTicketsR - , postProjectTicketCloseR - , postProjectTicketOpenR + , getPublishR + , postPublishR + , getInboxDebugR ) where import Control.Applicative +import Control.Concurrent.STM.TVar import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.Trans.Except import Data.Bitraversable +import Data.List import Data.Maybe import Data.Text (Text) import Data.Time.Clock @@ -53,22 +44,26 @@ import Database.Persist import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import Text.HTML.SanitizeXSS +import Yesod.Auth +import Yesod.Auth.Account +import Yesod.Auth.Account.Message import Yesod.Core import Yesod.Core.Widget import Yesod.Form import Yesod.Persist.Core +import qualified Data.ByteString.Char8 as BC import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE import qualified Database.Esqueleto as E import Dvara import Database.Persist.JSON import Network.FedURI -import Web.ActivityPub hiding (Ticket) import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI @@ -84,10 +79,9 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub +import Vervis.ActorKey import Vervis.API -import Vervis.Client import Vervis.FedURI -import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -96,10 +90,111 @@ import Vervis.Path import Vervis.Settings import Vervis.Ticket -import qualified Vervis.Client as C import qualified Vervis.Darcs as D import qualified Vervis.Git as G +-- | Account verification email resend form +getResendVerifyEmailR :: Handler Html +getResendVerifyEmailR = do + person <- requireUnverifiedAuth + defaultLayout $ do + setTitleI MsgEmailUnverified + [whamlet| +

_{MsgEmailUnverified} + ^{resendVerifyEmailWidget (username person) AuthR} + |] + +getActorKey + :: ((ActorKey, ActorKey, Bool) -> ActorKey) + -> Route App + -> Handler TypedContent +getActorKey choose route = do + actorKey <- + liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<< + getsYesod appActorKeys + encodeRouteLocal <- getEncodeRouteLocal + let key = AP.PublicKey + { AP.publicKeyId = LocalRefURI $ Left $ encodeRouteLocal route + , AP.publicKeyExpires = Nothing + , AP.publicKeyOwner = AP.OwnerInstance + , AP.publicKeyMaterial = actorKey + } + provideHtmlAndAP key $ redirectToPrettyJSON route + +getActorKey1R :: Handler TypedContent +getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R + +getActorKey2R :: Handler TypedContent +getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R + +getHomeR :: Handler Html +getHomeR = do + mp <- maybeAuth + case mp of + Just p -> personalOverview p + Nothing -> redirect BrowseR + where + personalOverview :: Entity Person -> Handler Html + personalOverview (Entity _pid _person) = + defaultLayout $ do + setTitle "Vervis > Overview" + $(widgetFile "personal-overview") + +getBrowseR :: Handler Html +getBrowseR = do + (people, groups, repos, decks, looms) <- runDB $ + (,,,,) + <$> (E.select $ E.from $ \ (person `E.InnerJoin` actor) -> do + E.on $ person E.^. PersonActor E.==. actor E.^. ActorId + E.orderBy [E.asc $ person E.^. PersonId] + return (person, actor) + ) + <*> (E.select $ E.from $ \ (group `E.InnerJoin` actor) -> do + E.on $ group E.^. GroupActor E.==. actor E.^. ActorId + E.orderBy [E.asc $ group E.^. GroupId] + return (group, actor) + ) + <*> (E.select $ E.from $ \ (repo `E.InnerJoin` actor) -> do + E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId + E.orderBy [E.asc $ repo E.^. RepoId] + return (repo, actor) + ) + <*> (E.select $ E.from $ \ (deck `E.InnerJoin` actor) -> do + E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId + E.orderBy [E.asc $ deck E.^. DeckId] + return (deck, actor) + ) + <*> (E.select $ E.from $ \ (loom `E.InnerJoin` actor) -> do + E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId + E.orderBy [E.asc $ loom E.^. LoomId] + return (loom, actor) + ) + {- + now <- liftIO getCurrentTime + repoRows <- forM repos $ + \ (E.Value sharer, E.Value mproj, E.Value repo, E.Value vcs) -> do + path <- askRepoDir sharer repo + mlast <- case vcs of + VCSDarcs -> liftIO $ D.lastChange path now + VCSGit -> do + mt <- liftIO $ G.lastCommitTime path + return $ Just $ case mt of + Nothing -> Never + Just t -> + intervalToEventTime $ + FriendlyConvert $ + now `diffUTCTime` t + return (sharer, mproj, repo, vcs, mlast) + -} + hashPerson <- getEncodeKeyHashid + hashGroup <- getEncodeKeyHashid + hashRepo <- getEncodeKeyHashid + hashDeck <- getEncodeKeyHashid + hashLoom <- getEncodeKeyHashid + defaultLayout $ do + setTitle "Welcome to Vervis!" + $(widgetFile "browse") + getShowTime = showTime <$> liftIO getCurrentTime where showTime now = @@ -108,6 +203,16 @@ getShowTime = showTime <$> liftIO getCurrentTime FriendlyConvert . diffUTCTime now +notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool)) +notificationForm defs = renderDivs $ mk + <$> aopt hiddenField (name "Inbox Item ID#") (fmap fst <$> defs) + <*> aopt hiddenField (name "New unread flag") (fmap snd <$> defs) + where + name t = FieldSettings "" Nothing Nothing (Just t) [] + mk Nothing Nothing = Nothing + mk (Just ibid) (Just unread) = Just (ibid, unread) + mk _ _ = error "Missing hidden field?" + objectSummary o = case M.lookup "summary" o of Just (String t) | not (T.null t) -> Just t @@ -118,6 +223,166 @@ objectId o = Just (String t) | not (T.null t) -> t _ -> error "'id' field not found" +getNotificationsR :: Handler Html +getNotificationsR = do + Entity _ viewer <- requireVerifiedAuth + + items <- runDB $ do + inboxID <- actorInbox <$> getJust (personActor viewer) + map adaptItem <$> getItems inboxID + + notifications <- for items $ \ (ibiid, activity) -> do + ((_result, widget), enctype) <- + runFormPost $ notificationForm $ Just $ Just (ibiid, False) + return (activity, widget, enctype) + + ((_result, widgetAll), enctypeAll) <- + runFormPost $ notificationForm $ Just Nothing + + showTime <- getShowTime + defaultLayout $(widgetFile "person/notifications") + where + getItems ibid = + E.select $ E.from $ + \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do + E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId + E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem + E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId + E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem + E.where_ + $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||. + ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid) + ) + E.&&. + ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||. + ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid) + ) + E.&&. + ib E.^. InboxItemUnread E.==. E.val True + E.orderBy [E.desc $ ib E.^. InboxItemId] + return + ( ib E.^. InboxItemId + , ob E.?. OutboxItemActivity + , ob E.?. OutboxItemPublished + , ract E.?. RemoteActivityContent + , ract E.?. RemoteActivityReceived + ) + adaptItem + (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) = + case (mact, mpub, mobj, mrec) of + (Nothing, Nothing, Nothing, Nothing) -> + error $ ibiidString ++ " neither local nor remote" + (Just _, Just _, Just _, Just _) -> + error $ ibiidString ++ " both local and remote" + (Just act, Just pub, Nothing, Nothing) -> + (ibid, (persistJSONObject act, (pub, False))) + (Nothing, Nothing, Just obj, Just rec) -> + (ibid, (persistJSONObject obj, (rec, True))) + _ -> error $ "Unexpected query result for " ++ ibiidString + where + ibiidString = "InboxItem #" ++ show (E.fromSqlKey ibid) + +postNotificationsR :: Handler Html +postNotificationsR = do + Entity _ poster <- requireVerifiedAuth + + ((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing + + case result of + FormMissing -> setMessage "Field(s) missing" + FormFailure l -> + setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l) + FormSuccess mitem -> do + (multi, markedUnread) <- runDB $ do + inboxID <- actorInbox <$> getJust (personActor poster) + case mitem of + Nothing -> do + ibiids <- map E.unValue <$> getItems inboxID + updateWhere + [InboxItemId <-. ibiids] + [InboxItemUnread =. False] + return (True, False) + Just (ibiid, unread) -> do + mib <- + requireEitherAlt + (getValBy $ UniqueInboxItemLocalItem ibiid) + (getValBy $ UniqueInboxItemRemoteItem ibiid) + "Unused InboxItem" + "InboxItem used more than once" + let samePid = + case mib of + Left ibl -> + inboxItemLocalInbox ibl == inboxID + Right ibr -> + inboxItemRemoteInbox ibr == inboxID + if samePid + then do + update ibiid [InboxItemUnread =. unread] + return (False, unread) + else + permissionDenied + "Notification belongs to different user" + setMessage $ + if multi + then "Items marked as read." + else if markedUnread + then "Item marked as unread." + else "Item marked as read." + + redirect NotificationsR + where + getItems ibid = + E.select $ E.from $ + \ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do + E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem + E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem + E.where_ + $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||. + ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid) + ) + E.&&. + ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||. + ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid) + ) + E.&&. + ib E.^. InboxItemUnread E.==. E.val True + return $ ib E.^. InboxItemId + +getPublishR :: Handler Html +getPublishR = do + error "Temporarily disabled" + +postPublishR :: Handler Html +postPublishR = do + error "Temporarily disabled" + +getInboxDebugR :: Handler Html +getInboxDebugR = do + acts <- + liftIO . readTVarIO . snd =<< maybe notFound return =<< getsYesod appActivities + defaultLayout + [whamlet| +

+ Welcome to the ActivityPub inbox test page! Activities received + by this Vervis instance are listed here for testing and + debugging. To test, go to another Vervis instance and publish + something that supports federation, either through the regular UI + or via the /publish page, and then come back here to see the + result. Activities that aren't understood or their processing + fails get listed here too, with a report of what exactly + happened. +

Last 10 activities posted: +