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

@@ -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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

migrations/386_2022-08-04_assignee.model

@@ -0,0 +1,5 @@
+TicketAssignee
+    ticket TicketId
+    person PersonId
+
+    UniqueTicketAssignee ticket person

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

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

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

migrations/408_2022-08-04_collab_loom.model

@@ -0,0 +1,5 @@
+CollabTopicLocalLoom
+    collab CollabId
+    loom   LoomId
+
+    UniqueCollabTopicLocalLoom collab

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

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

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

src/Darcs/Local/Repository.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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 :: FilePath -> FilePath -> Text -> Text -> IO ()
-writeDefaultsFile path cmd authority sharer repo = do
+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 :: FilePath -> Text -> Text -> Text
-    defaultsContent hook authority sharer repo =
+    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
+    -- ^ Repo key hashid
-    -> Text
-    -- ^ Repo textual ID
     -> 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)

src/Data/Git/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -54,21 +54,21 @@ instance SpecToEventTime GitTime where
     specToEventTime = specToEventTime . gitTimeUTC
     specsToEventTimes = specsToEventTimes . fmap gitTimeUTC
 
-hookContent :: FilePath -> Text -> Text -> Text -> Text
+hookContent :: FilePath -> Text -> Text -> Text
-hookContent hook authority sharer repo =
+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 :: FilePath -> FilePath -> Text -> Text -> IO ()
-writeHookFile path cmd authority sharer repo = do
+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 :: FilePath -> Text -> Text -> FileName -> DirTree Text
-initialRepoTree hook authority sharer repo dir =
+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
+    -- ^ Repo hashid
-    -> Text
-    -- ^ Repo textual ID
     -> IO ()
-createRepo path name cmd authority sharer repo = do
+createRepo path name cmd authority repo = do
-    let tree = path :/ initialRepoTree cmd authority sharer repo name
+    let tree = path :/ initialRepoTree cmd authority repo name
     result <- writeDirectoryWith TIO.writeFile tree
     let errs = failures $ dirTree result
     when (not . null $ errs) $

src/Database/Persist/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -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

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
+    -> RepoId
-    -> RpIdent
     -> 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
+        repo <- MaybeT $ get repoID
-        MaybeT $ getBy $ UniqueRepo rp sid
+        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
+    -> KeyHashid Deck
-    -> PrjIdent
     -> 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
+        deckID <- decodeKeyHashidM deckHash
-        MaybeT $ getBy $ UniqueProject prj sid
+        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 $ E.just (topic E.^. CollabTopicLocalDeckCollab) E.==. role E.?. CollabRoleLocalCollab
-                E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab
+                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
+    asUser = fmap RoleID . deckCollabUser
-    asAnon = fmap RoleID . projectCollabAnon
+    asAnon = fmap RoleID . deckCollabAnon

src/Vervis/ActivityPub/Recipient.hs

@@ -1,654 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ 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
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
-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)

src/Vervis/Actor.hs

@@ -0,0 +1,399 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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] []

src/Vervis/Application.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020, 2022
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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.Key
-import Vervis.Handler.Inbox
+import Vervis.Handler.Loom
-import Vervis.Handler.Key
-import Vervis.Handler.Patch
 import Vervis.Handler.Person
-import Vervis.Handler.Project
 import Vervis.Handler.Repo
-import Vervis.Handler.Role
+--import Vervis.Handler.Role
-import Vervis.Handler.Sharer
+--import Vervis.Handler.Sharer
 import Vervis.Handler.Ticket
-import Vervis.Handler.Wiki
+--import Vervis.Handler.Wiki
-import Vervis.Handler.Workflow
+--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 <- lift reposFromDir
-        repos' <- repoTreeFromDB
+        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) ->
+        printRepos = traverse_ $ \ (rp, vcs) ->
-            for_ rps $ \ (rp, vcs) ->
+            putStrLn $
-                putStrLn $
+                "Found repo " ++ rp ++
-                    "Found repo " ++
+                " [" ++ T.unpack (versionControlSystemName vcs) ++ "]"
-                    shr ++ " / " ++ rp ++
+    reposFromDir = do
-                    " [" ++ T.unpack (versionControlSystemName vcs) ++ "]"
-    repoTreeFromDir = do
         dir <- askRepoRootDir
-        outers <- liftIO $ sort <$> listDirectory dir
+        subdirs <- liftIO $ sort <$> listDirectory dir
-        repos <- for outers $ \ outer -> do
+        for subdirs $ \ subdir -> do
-            let path = dir </> outer
+            checkDir $ dir </> subdir
-            checkDir path
+            vcs <- do
-            inners <- liftIO $ sort <$> listDirectory path
+                mvcs <- detectVcs $ dir </> subdir
-            inners' <- for inners $ \ inner -> do
+                let ref = dir ++ "/" ++ subdir
-                checkDir $ path </> inner
+                case mvcs of
-                vcs <- do
+                    Left False -> error $ "Failed to detect VCS: " ++ ref
-                    mvcs <- detectVcs $ path </> inner
+                    Left True -> error $ "Detected both VCSs: " ++ ref
-                    let ref = outer ++ "/" ++ inner
+                    Right v -> return v
-                    case mvcs of
+            return (subdir, vcs)
-                        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
         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 =
+    reposFromDB = do
-        fmap adapt $ E.select $ E.from $ \ (s `E.InnerJoin` r) -> do
+        hashRepo <- getEncodeKeyHashid
-            E.on $ s E.^. SharerId E.==. r E.^. RepoSharer
+        sortOn fst . map (adapt hashRepo) <$> selectList [] []
-            E.orderBy [E.asc $ s E.^. SharerIdent, E.asc $ r E.^. RepoIdent]
-            return (s E.^. SharerIdent, (r E.^. RepoIdent, r E.^. RepoVcs))
         where
-        adapt =
+        adapt hashRepo (Entity repoID repo) =
-            groupWithExtract
+            (T.unpack $ keyHashidText $ hashRepo repoID, repoVcs repo)
-                (lower . unShrIdent . E.unValue . fst)
-                (first (lower . unRpIdent) . bimap E.unValue E.unValue . snd)
-            where
-            lower = T.unpack . CI.foldedCase
     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)
 

src/Vervis/ChangeFeed.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2018, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2018, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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 :: KeyHashid Repo -> LogEntry -> FeedEntry (Route App)
-changeEntry shr rp le = FeedEntry
+changeEntry rp le = FeedEntry
-    { feedEntryLink      = RepoCommitR shr rp $ leHash le
+    { 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
+    :: KeyHashid Repo       -- ^ Repo key
-    -> RpIdent              -- ^ Repo name
     -> 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
+            Nothing -> RepoCommitsR repo
-            Just b  -> RepoChangesR shr repo b
+            Just b  -> RepoBranchCommitsR repo b
     , feedLinkHome =
         case mbranch of
-            Nothing -> RepoHeadChangesR shr repo
+            Nothing -> RepoCommitsR repo
-            Just b  -> RepoChangesR shr repo b
+            Just b  -> RepoBranchCommitsR repo b
-    , feedAuthor      = shr2text shr
+    , 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
     }

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|
-                  <p>
-                    <a href=@{SharerR shrAuthor}>
-                      #{shr2text shrAuthor}
-                    \ opened a ticket on project #
-                    <a href="#{renderObjURI context}"}>
-                      #{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)
+    -}

src/Vervis/Cloth.hs

@@ -0,0 +1,133 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

src/Vervis/Darcs.hs

@@ -15,13 +15,13 @@
  -}
 
 module Vervis.Darcs
-    ( readSourceView
+    ( --readSourceView
-    , readWikiView
+    --, readWikiView
-    , readChangesView
+    --, readChangesView
-    , lastChange
+    --, lastChange
-    , readPatch
+    --, readPatch
-    , writePostApplyHooks
+      writePostApplyHooks
-    , applyDarcsPatch
+    --, 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
+    repos <- selectKeysList [RepoVcs ==. VCSDarcs] []
-        path <- askRepoDir shr rp
+    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 ()
+-}

src/Vervis/Delivery.hs

@@ -0,0 +1,807 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

src/Vervis/Discussion.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -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
+    l <- select $ from $ \ (lm `InnerJoin` m) -> do
-        on $ p ^. PersonIdent ==. s ^. SharerId
-        on $ lm ^. LocalMessageAuthor ==. p ^. PersonId
         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) =
+    mklocal (Entity mid m, Value lmid, Value pid) =
-        MessageTreeNode mid m $ MessageTreeNodeLocal lmid s
+        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
+            \ (m `E.InnerJoin` lm) -> do
-                E.on $ p E.^. PersonIdent E.==. s E.^. SharerId
-                E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId
                 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) =
+    localUri hashPerson encR encH (E.Value pid, E.Value lmid) =
-        encR $ MessageR shrAuthor (encH 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

src/Vervis/Federation.hs

@@ -13,11 +13,21 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+-- 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
+handlePersonInbox
-    r <- lift $ runExceptT a
+    :: KeyHashid Person
-    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
     -> 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
+data ForwarderBy f
-    = FwderProject ForwarderProjectId
+    = FwderPerson (f ForwarderPerson)
-    | FwderSharer ForwarderSharerId
+    | FwderGroup  (f ForwarderGroup)
-    | FwderRepo ForwarderRepoId
+    | FwderRepo   (f ForwarderRepo)
+    | FwderDeck   (f ForwarderDeck)
+    | FwderLoom   (f ForwarderLoom)
+    deriving (Generic, FunctorB, ConstraintsB)
 
-partitionFwders :: [Fwder] -> ([ForwarderProjectId], [ForwarderSharerId], [ForwarderRepoId])
+partitionFwders
-partitionFwders = foldl' f ([], [], [])
+    :: [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 (ps, gs, rs, ds, ls) = \ fwder ->
-    f (js, ss, rs) (FwderSharer s)  = (js    , s : ss, rs)
+        case fwder of
-    f (js, ss, rs) (FwderRepo r)    = (js    , ss    , r : rs)
+            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
+        forwarding <- E.select $ E.from $
-            E.on $ r E.?. RepoSharer E.==. s3 E.?. SharerId
+            \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i
-            E.on $ fwr E.?. ForwarderRepoSender E.==. r E.?. RepoId
+              `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 $ E.just (fw E.^. ForwardingId) E.==. fwg E.?. ForwarderGroupTask
-            E.on $ fws E.?. ForwarderSharerSender E.==. s2 E.?. SharerId
+            E.on $ E.just (fw E.^. ForwardingId) E.==. fwp E.?. ForwarderPersonTask
-            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 $ 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
+            return (i, ra, fw, fwp, fwg, fwr, fwd, fwl)
-                ( i E.^. InstanceId
+        let (forwardingOld, forwardingNew) =
-                , i E.^. InstanceHost
+                partitionEithers $
-                , ra E.^. RemoteActorId
+                    map (decideBySinceFW dropAfter now . adaptForwarding)
-                , ra E.^. RemoteActorInbox
+                        forwarding
-                , 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
             (fwidsOld, fwdersOld) = unzip forwardingOld
-            (fwjidsOld, fwsidsOld, fwridsOld) = partitionFwders fwdersOld
+            (fwpidsOld, fwgidsOld, fwridsOld, fwdidsOld, fwlidsOld) =
-        deleteWhere [ForwarderProjectId <-. fwjidsOld]
+                partitionFwders fwdersOld
-        deleteWhere [ForwarderSharerId <-. fwsidsOld]
+        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)
+        T.pack (show $ map (renderAuthority . snd . fst) linkedHttp)
-    waitsDL <- traverse (fork . deliverLinked deliver now) dls
+    waitsDL <- traverse (fork . deliverLinked deliver now) linkedHttp
 
     logDebug $
         "Periodic delivery forking forwarding " <>
-        T.pack (show $ map (renderAuthority . snd . fst) fws)
+        T.pack (show $ map (renderAuthority . snd . fst) forwardingHttp)
-    waitsFW <- traverse (fork . deliverForwarding now) fws
+    waitsFW <- traverse (fork . deliverForwarding now) forwardingHttp
 
     logDebug $
         "Periodic delivery forking unlinked " <>
-        T.pack (show $ map (renderAuthority . snd . fst) udls)
+        T.pack (show $ map (renderAuthority . snd . fst) unlinkedHttp)
-    waitsUDL <- traverse (fork . deliverUnlinked deliver now) udls
+    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
+        ( Entity iid (Instance h)
-        , E.Value fwid, E.Value body
+        , Entity raid (RemoteActor _ _ inbox _ since)
-        , E.Value mfwjid, E.Value mprj, E.Value mshr
+        , Entity fwid (Forwarding _ _ body sig _)
-        , E.Value mfwsid, E.Value mshr2
+        , mfwp, mfwg, mfwr, mfwd, mfwl
-        , E.Value mfwrid, E.Value mrp, E.Value mshr3
-        , E.Value sig
         ) =
             ( ( (iid, h)
               , ( (raid, inbox)
                 , ( fwid
                   , BL.fromStrict body
-                  , let project = together3 mfwjid mprj mshr
+                  , case (mfwp, mfwg, mfwr, mfwd, mfwl) of
-                        sharer = together2 mfwsid mshr2
+                        (Nothing, Nothing, Nothing, Nothing, Nothing) ->
-                        repo = together3 mfwrid mrp mshr3
+                            error "Found fwid without a Forwarder* record"
-                    in  case (project, sharer, repo) of
+                        (Just fwp, Nothing, Nothing, Nothing, Nothing) ->
-                            (Just (fwjid, shr, prj), Nothing, Nothing) ->
+                            FwderPerson fwp
-                                (FwderProject fwjid, ProjectR shr prj)
+                        (Nothing, Just fwg, Nothing, Nothing, Nothing) ->
-                            (Nothing, Just (fwsid, shr), Nothing) ->
+                            FwderGroup fwg
-                                (FwderSharer fwsid, SharerR shr)
+                        (Nothing, Nothing, Just fwr, Nothing, Nothing) ->
-                            (Nothing, Nothing, Just (fwrid, shr, rp)) ->
+                            FwderRepo fwr
-                                (FwderRepo fwrid, RepoR shr rp)
+                        (Nothing, Nothing, Nothing, Just fwd, Nothing) ->
-                            _ -> error $ "Non-single fwder for fw#" ++ show fwid
+                            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)
+    decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, fwder, _))), msince) =
-        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) =
         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
+                            case fwderK of
-                                FwderProject k -> delete k
+                                FwderPerson k -> delete k
-                                FwderSharer 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)

src/Vervis/Federation/Auth.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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
+    localAuth <- unhashLocalActorE author "No such actor"
-        mauthorId <- runMaybeT $ getLocalActor author
+    withExceptT T.unpack $ runDBExcept $ findLocalAuthInDB localAuth
-        return $
+    return localAuth
-            case mauthorId of
-                Nothing -> Left "Local author: No such user/project"
-                Just id_ -> Right id_
     where
-    getLocalActor (LocalActorSharer shr) = do
+    findLocalAuthInDB (LocalActorPerson pid) = do
-        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+        mp <- lift $ get pid
-        ActivityAuthLocalPerson <$> MaybeT (getKeyBy $ UniquePersonIdent sid)
+        when (isNothing mp) $ throwE "No such person"
-    getLocalActor (LocalActorProject shr prj) = do
+    findLocalAuthInDB (LocalActorGroup gid) = do
-        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+        mg <- lift $ get gid
-        ActivityAuthLocalProject <$> MaybeT (getKeyBy $ UniqueProject prj sid)
+        when (isNothing mg) $ throwE "No such group"
-    getLocalActor (LocalActorRepo shr rp) = do
+    findLocalAuthInDB (LocalActorRepo rid) = do
-        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+        mr <- lift $ get rid
-        ActivityAuthLocalRepo <$> MaybeT (getKeyBy $ UniqueRepo rp sid)
+        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

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
+    -> KeyHashid Project
-    -> PrjIdent
     -> 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
+    -> KeyHashid Repo
-    -> RpIdent
     -> 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)
+-}

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
+    :: KeyHashid Project
-    -> PrjIdent
     -> 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
+    :: KeyHashid Repo
-    -> RpIdent
     -> 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
+    :: KeyHashid Project
-    -> PrjIdent
     -> 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
+    :: KeyHashid Repo
-    -> RpIdent
     -> 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])
+-}

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
+-}

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
+                    Nothing                    -> return False
-                    Just PostReceiveR            -> return False
+                    Just PostReceiveR          -> return False
-                    Just (SharerOutboxR _)       -> return False
+                    Just (PersonOutboxR _)     -> return False
-                    Just (SharerInboxR _)        -> return False
+                    Just (PersonInboxR _)      -> return False
-                    Just (ProjectInboxR _ _)     -> return False
+                    Just (GroupInboxR _)       -> return False
-                    Just (RepoInboxR _ _)        -> return False
+                    Just (RepoInboxR _)        -> return False
-                    Just (GitUploadRequestR _ _) -> 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, _   ) -> personAny
-        (NotificationsR shr        , _   ) -> person shr
+        (PublishR      , True) -> personAny
-        (SharerOutboxR shr         , True) -> person shr
-        (SharerFollowR shr         , True) -> personAny
-        (SharerUnfollowR shr       , 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 :: KeyHashid Person -> Handler AuthResult
-        person ident = personAnd $ \ (Entity _ p) -> do
+        person hash = personAnd $ \ (Entity pid _) -> do
-            let sid = personIdent p
+            hash' <- encodeKeyHashid pid
-            sharer <- runDB $ getJust sid
+            return $ if hash == hash'
-            return $ if ident == sharerIdent sharer
                 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
+        ibid <- insert Inbox
-                { sharerIdent   = text2shr name
+        obid <- insert Outbox
-                , sharerName    = Nothing
+        fsid <- insert FollowerSet
-                , sharerCreated = now
+        let actor = Actor
+                { actorName      = name
+                , actorDesc      = ""
+                , actorCreatedAt = now
+                , actorInbox     = ibid
+                , actorOutbox    = obid
+                , actorFollowers = fsid
                 }
-        msid <- insertBy sharer
+        aid <- insert actor
-        case msid of
+        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
+            Right pid -> return $ Right $ Entity pid person
-                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
 
     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)

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
+    repos <- selectKeysList [RepoVcs ==. VCSGit] []
-        path <- askRepoDir shr rp
+    for_ repos $ \ repoID -> do
-        liftIO $ writeHookFile path hook authority (shr2text shr) (rp2text rp)
+        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
+-}

src/Vervis/Handler/Client.hs

@@ -15,36 +15,27 @@
  -}
 
 module Vervis.Handler.Client
-    ( getPublishR
+    ( getResendVerifyEmailR
-    , postSharerOutboxR
+    , getActorKey1R
-    , postPublishR
+    , getActorKey2R
 
+    , getHomeR
     , getBrowseR
-
-    , postSharerFollowR
-    , postProjectFollowR
-    , postProjectTicketFollowR
-    , postRepoFollowR
-
-    , postSharerUnfollowR
-    , postProjectUnfollowR
-    , postProjectTicketUnfollowR
-    , postRepoUnfollowR
-
     , getNotificationsR
     , postNotificationsR
-
+    , getPublishR
-    , postProjectTicketsR
+    , postPublishR
-    , postProjectTicketCloseR
+    , getInboxDebugR
-    , postProjectTicketOpenR
     )
 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|
+            <p>_{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|
+            <p>
+              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.
+            <p>Last 10 activities posted:
+            <ul>
+              $forall ActivityReport time msg ctypes body <- acts
+                <li>
+                  <div>#{show time}
+                  <div>#{msg}
+                  <div><code>#{intercalate " | " $ map BC.unpack ctypes}
+                  <div><pre>#{TLE.decodeUtf8 body}
+        |]
+
+{-
+
 fedUriField
     :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
 fedUriField = Field
@@ -348,63 +613,6 @@ getPublishR = do
             widget7 enctype7
             widget8 enctype8
 
-postSharerOutboxR :: ShrIdent -> Handler Text
-postSharerOutboxR shr = do
-    federation <- getsYesod $ appFederation . appSettings
-    unless federation badMethod
-    (ep@(Entity pid person), sharer) <- runDB $ do
-        Entity sid s <- getBy404 $ UniqueSharer shr
-        (,s) <$> getBy404 (UniquePersonIdent sid)
-    (_app, mpid, _scopes) <- maybe notAuthenticated return =<< getDvaraAuth
-    pid' <-
-        maybe (permissionDenied "Not authorized to post as a user") return mpid
-    unless (pid == pid') $
-        permissionDenied "Can't post as other users"
-    verifyContentTypeAP
-    Doc h activity <- requireInsecureJsonBody
-    hl <- hostIsLocal h
-    unless hl $ invalidArgs ["Activity host isn't the instance host"]
-    result <- runExceptT $ handle ep sharer activity
-    case result of
-        Left err -> invalidArgs [err]
-        Right obiid -> do
-            obikhid <- encodeKeyHashid obiid
-            sendResponseCreated $ SharerOutboxItemR shr obikhid
-    where
-    handle eperson sharer (Activity _mid actor mcap summary audience specific) = do
-        case decodeRouteLocal actor of
-            Just (SharerR shr') | shr' == shr -> return ()
-            _ -> throwE "Can't post activity sttributed to someone else"
-        case specific of
-            AddActivity (AP.Add obj target) ->
-                case obj of
-                    Right (AddBundle patches) ->
-                        addBundleC eperson sharer summary audience patches target
-                    _ -> throwE "Unsupported Add 'object' type"
-            ApplyActivity apply ->
-                applyC eperson sharer summary audience mcap apply
-            CreateActivity (Create obj mtarget) ->
-                case obj of
-                    CreateNote _ note ->
-                        createNoteC eperson sharer summary audience note mtarget
-                    CreateTicket _ ticket ->
-                        createTicketC eperson sharer summary audience ticket mtarget
-                    _ -> throwE "Unsupported Create 'object' type"
-            FollowActivity follow ->
-                followC shr summary audience follow
-            OfferActivity (Offer obj target) ->
-                case obj of
-                    OfferTicket ticket ->
-                        offerTicketC eperson sharer summary audience ticket target
-                    OfferDep dep ->
-                        offerDepC eperson sharer summary audience dep target
-                    _ -> throwE "Unsupported Offer 'object' type"
-            ResolveActivity resolve ->
-                resolveC eperson sharer summary audience resolve
-            UndoActivity undo ->
-                undoC eperson sharer summary audience undo
-            _ -> throwE "Unsupported activity type"
-
 data Result
     = ResultPublishComment ((Host, ShrIdent, PrjIdent, KeyHashid LocalTicket), Maybe FedURI, Text)
     | ResultCreateTicket (FedURI, FedURI, TextHtml, TextPandocMarkdown)
@@ -587,54 +795,6 @@ postPublishR = do
             C.follow shrAuthor uObject uRecip False
         followC shrAuthor (Just summary) audience followAP
 
-getBrowseR :: Handler Html
-getBrowseR = do
-    (rowsRepo, rowsProject) <- do
-        (repos, projects) <- runDB $ do
-            rs <- E.select $ E.from $
-                \ (repo `E.LeftOuterJoin` project `E.InnerJoin` sharer) -> do
-                    E.on $ repo E.^. RepoSharer E.==. sharer E.^. SharerId
-                    E.on $ repo E.^. RepoProject E.==. project E.?. ProjectId
-                    E.orderBy
-                        [ E.asc $ sharer E.^. SharerIdent
-                        , E.asc $ project E.?. ProjectIdent
-                        , E.asc $ repo E.^. RepoIdent
-                        ]
-                    return
-                        ( sharer E.^. SharerIdent
-                        , project E.?. ProjectIdent
-                        , repo E.^. RepoIdent
-                        , repo E.^. RepoVcs
-                        )
-            js <- E.select $ E.from $ \ (j `E.InnerJoin` s `E.LeftOuterJoin` r) -> do
-                E.on $ E.just (j E.^. ProjectId) E.==. E.joinV (r E.?. RepoProject)
-                E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId
-                E.where_ $ E.isNothing $ r E.?. RepoId
-                return
-                    ( s E.^. SharerIdent
-                    , j E.^. ProjectIdent
-                    )
-            return (rs, js)
-        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)
-        return (repoRows, projects)
-    defaultLayout $ do
-        setTitle "Welcome to Vervis!"
-        $(widgetFile "homepage")
-
 setFollowMessage :: ShrIdent -> Either Text OutboxItemId -> Handler ()
 setFollowMessage _   (Left err)    = setMessage $ toHtml err
 setFollowMessage shr (Right obiid) = do
@@ -733,146 +893,6 @@ postRepoUnfollowR shrFollowee rpFollowee = do
     setUnfollowMessage shrAuthor eid
     redirect $ RepoR shrFollowee rpFollowee
 
-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?"
-
-getNotificationsR :: ShrIdent -> Handler Html
-getNotificationsR shr = do
-    items <- runDB $ do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        p <- getValBy404 $ UniquePersonIdent sid
-        let ibid = personInbox p
-        map adaptItem <$> getItems ibid
-    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 :: ShrIdent -> Handler Html
-postNotificationsR shr = do
-    ((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing
-    case result of
-        FormSuccess mitem -> do
-            (multi, markedUnread) <- runDB $ do
-                sid <- getKeyBy404 $ UniqueSharer shr
-                p <- getValBy404 $ UniquePersonIdent sid
-                let ibid = personInbox p
-                case mitem of
-                    Nothing -> do
-                        ibiids <- map E.unValue <$> getItems ibid
-                        updateWhere
-                            [InboxItemId <-. ibiids]
-                            [InboxItemUnread =. False]
-                        return (True, False)
-                    Just (ibiid, unread) -> do
-                        mibl <- getValBy $ UniqueInboxItemLocalItem ibiid
-                        mibr <- getValBy $ UniqueInboxItemRemoteItem ibiid
-                        mib <-
-                            requireEitherM
-                                mibl
-                                mibr
-                                "Unused InboxItem"
-                                "InboxItem used more than once"
-                        let samePid =
-                                case mib of
-                                    Left ibl ->
-                                        inboxItemLocalInbox ibl == ibid
-                                    Right ibr ->
-                                        inboxItemRemoteInbox ibr == ibid
-                        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."
-        FormMissing -> do
-            setMessage "Field(s) missing"
-        FormFailure l -> do
-            setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l)
-    redirect $ NotificationsR shr
-    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
-    -- TODO copied from Vervis.Federation, put this in 1 place
-    requireEitherM
-        :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
-    requireEitherM mx my f t =
-        case requireEither mx my of
-            Left b    -> liftIO $ throwIO $ userError $ if b then t else f
-            Right exy -> return exy
-
 postProjectTicketsR :: ShrIdent -> PrjIdent -> Handler Html
 postProjectTicketsR shr prj = do
     wid <- runDB $ do
@@ -989,3 +1009,4 @@ postProjectTicketOpenR shr prj ltkhid = do
         Left e -> setMessage $ toHtml $ "Error: " <> e
         Right _obiid -> setMessage "Ticket reopened"
     redirect $ ProjectTicketR shr prj ltkhid
+-}

src/Vervis/Handler/Cloth.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -13,8 +13,28 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-module Vervis.Handler.Patch
+module Vervis.Handler.Cloth
-    ( getSharerProposalsR
+    ( getClothR
+    , getClothDiscussionR
+    , getClothEventsR
+    , getClothFollowersR
+    , getClothDepsR
+    , getClothReverseDepsR
+
+    , getBundleR
+    , getPatchR
+
+    , getClothDepR
+
+
+
+
+
+
+
+
+    {-
+    , getSharerProposalsR
     , getSharerProposalR
     , getSharerProposalDiscussionR
     , getSharerProposalDepsR
@@ -33,6 +53,7 @@ module Vervis.Handler.Patch
     , getRepoProposalEventsR
     , getRepoProposalBundleR
     , getRepoProposalBundlePatchR
+    -}
     )
 where
 
@@ -51,6 +72,7 @@ import qualified Data.List.NonEmpty as NE
 import qualified Data.List.Ordered as LO
 import qualified Database.Esqueleto as E
 
+import Development.PatchMediaType
 import Network.FedURI
 import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..), Repo (..))
 import Yesod.ActivityPub
@@ -60,21 +82,432 @@ import Yesod.Hashids
 import qualified Web.ActivityPub as AP
 
 import Data.Paginate.Local
+import Database.Persist.Local
 import Yesod.Persist.Local
 
 import Vervis.ActivityPub
+import Vervis.Actor
 import Vervis.API
+import Vervis.Cloth
 import Vervis.Discussion
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Development.PatchMediaType
 import Vervis.Model.Ticket
 import Vervis.Paginate
-import Vervis.Patch
 import Vervis.Ticket
 
+getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
+getClothR loomHash clothHash = do
+    (repoID, mbranch, ticket, author, resolve, bundleID) <- runDB $ do
+        (Entity _ loom, Entity _ cloth, Entity _ ticket', author', resolve', bundleID' :| _) <-
+            getCloth404 loomHash clothHash
+        (,,,,,)
+            (loomRepo loom)
+            (ticketLoomBranch cloth)
+            ticket'
+            <$> (case author' of
+                    Left (Entity _ tal) ->
+                        return $ Left $ ticketAuthorLocalAuthor tal
+                    Right (Entity _ tar) -> Right <$> do
+                        ra <- getJust $ ticketAuthorRemoteAuthor tar
+                        ro <- getJust $ remoteActorIdent ra
+                        i <- getJust $ remoteObjectInstance ro
+                        return (i, ro)
+                )
+            <*> (for resolve' $ \ (_, etrx) ->
+                    bitraverse
+                        (\ (Entity _ trl) -> do
+                            let obiid = ticketResolveLocalActivity trl
+                            obid <- outboxItemOutbox <$> getJust obiid
+                            actorID <- do
+                                maybeActorID <- getKeyBy $ UniqueActorOutbox obid
+                                case maybeActorID of
+                                    Nothing -> error "Found outbox not used by any actor"
+                                    Just a -> return a
+                            actor <- getLocalActor actorID
+                            return (actor, obiid)
+                        )
+                        (\ (Entity _ trr) -> do
+                            roid <-
+                                remoteActivityIdent <$>
+                                    getJust (ticketResolveRemoteActivity trr)
+                            ro <- getJust roid
+                            i <- getJust $ remoteObjectInstance ro
+                            return (i, ro)
+                        )
+                        etrx
+                )
+            <*> pure bundleID'
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashPerson <- getEncodeKeyHashid
+    hashItem <- getEncodeKeyHashid
+    hLocal <- getsYesod siteInstanceHost
+    repoHash <- encodeKeyHashid repoID
+    bundleHash <- encodeKeyHashid bundleID
+    let route mk = encodeRouteLocal $ mk loomHash clothHash
+        authorHost =
+            case author of
+                Left _       -> hLocal
+                Right (i, _) -> instanceHost i
+        ticketLocalAP = AP.TicketLocal
+            { AP.ticketId           = route ClothR
+            , AP.ticketReplies      = route ClothDiscussionR
+            , AP.ticketParticipants = route ClothFollowersR
+            , AP.ticketTeam         = Nothing
+            , AP.ticketEvents       = route ClothEventsR
+            , AP.ticketDeps         = route ClothDepsR
+            , AP.ticketReverseDeps  = route ClothReverseDepsR
+            }
+        mergeRequestAP = AP.MergeRequest
+            { AP.mrOrigin = Nothing
+            , AP.mrTarget =
+                case mbranch of
+                    Nothing -> Left $ encodeRouteLocal $ RepoR repoHash
+                    Just b -> Right AP.Branch
+                        { AP.branchName = b
+                        , AP.branchRef  = "refs/heads/" <> b
+                        , AP.branchRepo = encodeRouteLocal $ RepoR repoHash
+                        }
+            , AP.mrBundle =
+                Left $ encodeRouteHome $ BundleR loomHash clothHash bundleHash
+            }
+        ticketAP = AP.Ticket
+            { AP.ticketLocal        = Just (hLocal, ticketLocalAP)
+            , AP.ticketAttributedTo =
+                case author of
+                    Left authorID ->
+                        encodeRouteLocal $ PersonR $ hashPerson authorID
+                    Right (_instance, object) ->
+                        remoteObjectIdent object
+            , AP.ticketPublished    = Just $ ticketCreated ticket
+            , AP.ticketUpdated      = Nothing
+            , AP.ticketContext      = Just $ encodeRouteHome $ LoomR loomHash
+            -- , AP.ticketName         = Just $ "#" <> T.pack (show num)
+            , AP.ticketSummary      = TextHtml $ ticketTitle ticket
+            , AP.ticketContent      = TextHtml $ ticketDescription ticket
+            , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
+            , AP.ticketAssignedTo   = Nothing
+            , AP.ticketResolved     =
+                let u (Left (actor, obiid)) =
+                        encodeRouteHome $
+                            outboxItemRoute actor $ hashItem obiid
+                    u (Right (i, ro)) =
+                        ObjURI (instanceHost i) (remoteObjectIdent ro)
+                in  (,Nothing) . Just . u <$> resolve
+            , AP.ticketAttachment = Just (hLocal, mergeRequestAP)
+            }
+
+    provideHtmlAndAP' authorHost ticketAP $ redirectToPrettyJSON here
+    where
+    here = ClothR loomHash clothHash
+
+    {-
+    mpid <- maybeAuthId
+    ( wshr, wfl,
+      author, massignee, mresolved, cloth, lcloth, tparams, eparams, cparams) <-
+        runDB $ do
+            (Entity sid sharer, Entity jid project, Entity tid cloth, Entity _ lcloth, _etcl, _etpl, author, resolved) <- getProjectCloth404 shar proj ltkhid
+            tparams <- getClothTextParams tid wid
+            eparams <- getClothEnumParams tid wid
+            cparams <- getClothClasses tid wid
+            return
+                ( wshr, wfl
+                , author', massignee, mresolved, cloth, lcloth
+                , tparams, eparams, cparams
+                )
+    let desc :: Widget
+        desc = toWidget $ preEscapedToMarkup $ clothDescription cloth
+        discuss =
+            discussionW
+                (return $ localClothDiscuss lcloth)
+                (ProjectClothTopReplyR shar proj ltkhid)
+                (ProjectClothReplyR shar proj ltkhid . encodeHid)
+    cRelevant <- newIdent
+    cIrrelevant <- newIdent
+    let relevant filt =
+            bool cIrrelevant cRelevant $
+            case clothStatus cloth of
+                TSNew    -> wffNew filt
+                TSTodo   -> wffTodo filt
+                TSClosed -> wffClosed filt
+    provideHtmlAndAP' host clothAP $
+        let followButton =
+                followW
+                    (ProjectClothFollowR shar proj ltkhid)
+                    (ProjectClothUnfollowR shar proj ltkhid)
+                    (return $ localClothFollowers lcloth)
+        in  $(widgetFile "cloth/one")
+    -}
+
+getClothDiscussionR
+    :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
+getClothDiscussionR _ _ = do
+    error "Temporarily disabled"
+    {-
+    encodeHid <- getEncodeKeyHashid
+    getDiscussion
+        (ProjectClothReplyR shar proj ltkhid . encodeHid)
+        (ProjectClothTopReplyR shar proj ltkhid)
+        (selectDiscussionId shar proj ltkhid)
+    -}
+
+getClothEventsR
+    :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
+getClothEventsR _ _ = do
+    error "Not implemented yet"
+
+getClothFollowersR
+    :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
+getClothFollowersR loomHash clothHash = getFollowersCollection here getFsid
+    where
+    here = ClothFollowersR loomHash clothHash
+    getFsid = do
+        (_, _, Entity _ t, _, _, _) <- getCloth404 loomHash clothHash
+        return $ ticketFollowers t
+
+getClothDepsR
+    :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
+getClothDepsR loomHash clothHash =
+    error "Temporarily disabled"
+    {-
+    getDependencyCollection here dep getLocalClothId404
+    where
+    here = ClothDepsR loomHash clothHash
+    dep = ClothDepR loomHash clothHash
+    getLocalClothId404 = do
+        (_, _, Entity ltid _, _, _, _, _) <- getCloth404 dkhid ltkhid
+        return ltid
+    -}
+
+getClothReverseDepsR
+    :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
+getClothReverseDepsR loomHash clothHash =
+    error "Temporarily disabled"
+    {-
+    getReverseDependencyCollection here getLocalClothId404
+    where
+    here = ClothReverseDepsR loomhash clothHash
+    getLocalClothId404 = do
+        (_, _, _, Entity ltid _, _, _, _, _) <- getCloth404 loomHash clothHash
+        return ltid
+    -}
+
+getBundleR
+    :: KeyHashid Loom
+    -> KeyHashid TicketLoom
+    -> KeyHashid Bundle
+    -> Handler TypedContent
+getBundleR loomHash clothHash bundleHash = do
+    (patchIDs, previousBundles, maybeCurrentBundle) <- runDB $ do
+        (_, Entity clothID _, _, _, _, latest :| prevs) <-
+            getCloth404 loomHash clothHash
+        bundleID <- decodeKeyHashid404 bundleHash
+        bundle <- get404 bundleID
+        unless (bundleTicket bundle == clothID) notFound
+        patches <- do
+            ids <- selectKeysList [PatchBundle ==. bundleID] [Desc PatchId]
+            case nonEmpty ids of
+                Nothing -> error "Bundle without any Patches in DB"
+                Just ne -> return ne
+        let (prevs, mcurr) =
+                if bundleID == latest
+                    then (prevs, Nothing)
+                    else ([]   , Just latest)
+        return (patches, prevs, mcurr)
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    hashBundle <- getEncodeKeyHashid
+    hashPatch <- getEncodeKeyHashid
+
+    let versionRoute = BundleR loomHash clothHash . hashBundle
+        bundleLocalAP = AP.BundleLocal
+            { AP.bundleId = encodeRouteLocal here
+            , AP.bundleContext =
+                encodeRouteLocal $ ClothR loomHash clothHash
+            , AP.bundlePrevVersions =
+                map (encodeRouteLocal . versionRoute) previousBundles
+            , AP.bundleCurrentVersion =
+                encodeRouteLocal . versionRoute <$> maybeCurrentBundle
+            }
+        bundleAP =
+            AP.BundleHosted
+                (Just bundleLocalAP)
+                (NE.map
+                    ( encodeRouteLocal
+                    . PatchR loomHash clothHash bundleHash
+                    . hashPatch
+                    )
+                    patchIDs
+                )
+
+    provideHtmlAndAP bundleAP $ redirectToPrettyJSON here
+    where
+    here = BundleR loomHash clothHash bundleHash
+
+getPatchR
+    :: KeyHashid Loom
+    -> KeyHashid TicketLoom
+    -> KeyHashid Bundle
+    -> KeyHashid Patch
+    -> Handler TypedContent
+getPatchR loomHash clothHash bundleHash patchHash = do
+    (patch, author) <- runDB $ do
+        (_, _, _, author', _, versions) <- getCloth404 loomHash clothHash
+        (,) <$> do  bundleID <- decodeKeyHashid404 bundleHash
+                    unless (bundleID `elem` versions) notFound
+                    patchID <- decodeKeyHashid404 patchHash
+                    patch' <- get404 patchID
+                    unless (patchBundle patch' == bundleID) notFound
+                    return patch'
+            <*> bitraverse
+                    (\ (Entity _ tal) -> return $ ticketAuthorLocalAuthor tal)
+                    (\ (Entity _ tar) -> do
+                        ra <- getJust $ ticketAuthorRemoteAuthor tar
+                        ro <- getJust $ remoteActorIdent ra
+                        i <- getJust $ remoteObjectInstance ro
+                        return (i, ro)
+                    )
+                    author'
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    hashPerson <- getEncodeKeyHashid
+    hLocal <- getsYesod siteInstanceHost
+
+    let host =
+            case author of
+                Left _       -> hLocal
+                Right (i, _) -> instanceHost i
+        patchLocalAP = AP.PatchLocal
+            { AP.patchId      = encodeRouteLocal here
+            , AP.patchContext =
+                encodeRouteLocal $ BundleR loomHash clothHash bundleHash
+            }
+        patchAP = AP.Patch
+            { AP.patchLocal = Just (hLocal, patchLocalAP)
+            , AP.patchAttributedTo =
+                case author of
+                    Left authorID ->
+                        encodeRouteLocal $ PersonR $ hashPerson authorID
+                    Right (_, object) -> remoteObjectIdent object
+            , AP.patchPublished    = Just $ patchCreated patch
+            , AP.patchType         = patchType patch
+            , AP.patchContent      = patchContent patch
+            }
+    provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here
+    where
+    here = PatchR loomHash clothHash bundleHash patchHash
+
+getClothDepR
+    :: KeyHashid Loom
+    -> KeyHashid TicketLoom
+    -> KeyHashid LocalTicketDependency
+    -> Handler TypedContent
+getClothDepR _ _ _ = do
+    error "Temporarily disabled"
+    {-
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    wiRoute <- askWorkItemRoute
+    hLocal <- asksSite siteInstanceHost
+
+    tdid <- decodeKeyHashid404 tdkhid
+    (td, author, parent, child) <- runDB $ do
+        td <- get404 tdid
+        (td,,,)
+            <$> getAuthor tdid
+            <*> getWorkItem ( localTicketDependencyParent td)
+            <*> getChild tdid
+    let host =
+            case author of
+                Left _ -> hLocal
+                Right (h, _) -> h
+        tdepAP = AP.TicketDependency
+            { ticketDepId           = Just $ encodeRouteHome here
+            , ticketDepParent       = encodeRouteHome $ wiRoute parent
+            , ticketDepChild        =
+                case child of
+                    Left wi -> encodeRouteHome $ wiRoute wi
+                    Right (h, lu) -> ObjURI h lu
+            , ticketDepAttributedTo =
+                case author of
+                    Left shr -> encodeRouteLocal $ SharerR shr
+                    Right (_h, lu) -> lu
+            , ticketDepPublished    = Just $ localTicketDependencyCreated td
+            , ticketDepUpdated      = Nothing
+            }
+    provideHtmlAndAP' host tdepAP $ redirectToPrettyJSON here
+    where
+    here = TicketDepR tdkhid
+    getAuthor tdid = do
+        tda <- requireEitherAlt
+            (getValBy $ UniqueTicketDependencyAuthorLocal tdid)
+            (getValBy $ UniqueTicketDependencyAuthorRemote tdid)
+            "No TDA"
+            "Both TDAL and TDAR"
+        bitraverse
+            (\ tdal -> do
+                p <- getJust $ ticketDependencyAuthorLocalAuthor tdal
+                s <- getJust $ personIdent p
+                return $ sharerIdent s
+            )
+            (\ tdar -> do
+                ra <- getJust $ ticketDependencyAuthorRemoteAuthor tdar
+                ro <- getJust $ remoteActorIdent ra
+                i <- getJust $ remoteObjectInstance ro
+                return (instanceHost i, remoteObjectIdent ro)
+            )
+            tda
+    getChild tdid = do
+        tdc <- requireEitherAlt
+            (getValBy $ UniqueTicketDependencyChildLocal tdid)
+            (getValBy $ UniqueTicketDependencyChildRemote tdid)
+            "No TDC"
+            "Both TDCL and TDCR"
+        bitraverse
+            (getWorkItem . ticketDependencyChildLocalChild)
+            (\ tdcr -> do
+                ro <- getJust $ ticketDependencyChildRemoteChild tdcr
+                i <- getJust $ remoteObjectInstance ro
+                return (instanceHost i, remoteObjectIdent ro)
+            )
+            tdc
+    -}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-
 getSharerProposalsR :: ShrIdent -> Handler TypedContent
 getSharerProposalsR =
     getSharerWorkItems SharerProposalsR SharerProposalR countPatches selectPatches
@@ -595,112 +1028,4 @@ getRepoProposalEventsR shr rp ltkhid = do
     provideEmptyCollection
         CollectionTypeOrdered
         (RepoProposalEventsR shr rp ltkhid)
-
+-}
-getRepoProposalBundleR
-    :: ShrIdent
-    -> RpIdent
-    -> KeyHashid LocalTicket
-    -> KeyHashid Bundle
-    -> Handler TypedContent
-getRepoProposalBundleR shr rp ltkhid bnkhid = do
-    (ptids, prevs, mcurr) <- runDB $ do
-        (_, _, Entity tid _, _, _, _, _, _, v :| vs) <- getRepoProposal404 shr rp ltkhid
-        bnid <- decodeKeyHashid404 bnkhid
-        bn <- get404 bnid
-        unless (bundleTicket bn == tid) notFound
-        ptids <- selectKeysList [PatchBundle ==. bnid] [Desc PatchId]
-        ptidsNE <-
-            case nonEmpty ptids of
-                Nothing -> error "Bundle without any Patches in DB"
-                Just ne -> return ne
-        let (prevs, mcurr) =
-                if bnid == v
-                    then (vs, Nothing)
-                    else ([], Just v)
-        return (ptidsNE, prevs, mcurr)
-
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeBNID <- getEncodeKeyHashid
-    encodePTID <- getEncodeKeyHashid
-
-    let versionRoute = RepoProposalBundleR shr rp ltkhid . encodeBNID
-        local = BundleLocal
-            { bundleId             = encodeRouteLocal here
-            , bundleContext        =
-                encodeRouteLocal $ RepoProposalR shr rp ltkhid
-            , bundlePrevVersions   =
-                map (encodeRouteLocal . versionRoute) prevs
-            , bundleCurrentVersion = encodeRouteLocal . versionRoute <$> mcurr
-            }
-        bundleAP =
-            AP.BundleHosted
-                (Just local)
-                (NE.map
-                    ( encodeRouteLocal
-                    . RepoProposalBundlePatchR shr rp ltkhid bnkhid
-                    . encodePTID
-                    )
-                    ptids
-                )
-    provideHtmlAndAP bundleAP $ redirectToPrettyJSON here
-    where
-    here = RepoProposalBundleR shr rp ltkhid bnkhid
-
-getRepoProposalBundlePatchR
-    :: ShrIdent
-    -> RpIdent
-    -> KeyHashid LocalTicket
-    -> KeyHashid Bundle
-    -> KeyHashid Patch
-    -> Handler TypedContent
-getRepoProposalBundlePatchR shr rp ltkhid bnkhid ptkhid = do
-    (patch, author) <- runDB $ do
-        (_, _, _, _, _, _, ta, _, vers) <- getRepoProposal404 shr rp ltkhid
-        (,) <$> do  bnid <- decodeKeyHashid404 bnkhid
-                    unless (bnid `elem` vers) notFound
-                    ptid <- decodeKeyHashid404 ptkhid
-                    pt <- get404 ptid
-                    unless (patchBundle pt == bnid) notFound
-                    return pt
-            <*> bitraverse
-                    (\ (Entity _ tal, _) -> do
-                        p <- getJust $ ticketAuthorLocalAuthor tal
-                        getJust $ personIdent p
-                    )
-                    (\ (Entity _ tar) -> do
-                        ra <- getJust $ ticketAuthorRemoteAuthor tar
-                        ro <- getJust $ remoteActorIdent ra
-                        i <- getJust $ remoteObjectInstance ro
-                        return (i, ro)
-                    )
-                    ta
-
-    encodeRouteLocal <- getEncodeRouteLocal
-    hLocal <- getsYesod siteInstanceHost
-
-    let host =
-            case author of
-                Left _       -> hLocal
-                Right (i, _) -> instanceHost i
-        patchAP = AP.Patch
-            { AP.patchLocal        = Just
-                ( hLocal
-                , AP.PatchLocal
-                    { AP.patchId             = encodeRouteLocal here
-                    , AP.patchContext        =
-                        encodeRouteLocal $
-                            RepoProposalBundleR shr rp ltkhid bnkhid
-                    }
-                )
-            , AP.patchAttributedTo =
-                case author of
-                    Left sharer ->
-                        encodeRouteLocal $ SharerR $ sharerIdent sharer
-                    Right (_, object) -> remoteObjectIdent object
-            , AP.patchPublished    = Just $ patchCreated patch
-            , AP.patchType         = patchType patch
-            , AP.patchContent      = patchContent patch
-            }
-    provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here
-    where
-    here = RepoProposalBundlePatchR shr rp ltkhid bnkhid ptkhid

src/Vervis/Handler/Deck.hs

@@ -13,14 +13,35 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-module Vervis.Handler.Project
+module Vervis.Handler.Deck
-    ( getProjectsR
+    ( getDeckR
-    , postProjectsR
+    , getDeckInboxR
-    , getProjectNewR
+    , postDeckInboxR
+    , getDeckOutboxR
+    , getDeckOutboxItemR
+    , getDeckFollowersR
+    , getDeckTicketsR
+
+    , getDeckTreeR
+
+    , getDeckNewR
+    , postDeckNewR
+    , postDeckDeleteR
+    , getDeckEditR
+    , postDeckEditR
+    , postDeckFollowR
+    , postDeckUnfollowR
+
+
+
+
+
+
+
+    {-
+    , getProjectsR
     , getProjectR
     , putProjectR
-    , postProjectR
-    , getProjectEditR
     , getProjectDevsR
     , postProjectDevsR
     , getProjectDevNewR
@@ -28,19 +49,19 @@ module Vervis.Handler.Project
     , deleteProjectDevR
     , postProjectDevR
     , getProjectTeamR
-    , getProjectFollowersR
+    -}
     )
 where
 
 import Control.Monad
 import Control.Monad.Trans.Except
+import Data.Aeson
 import Data.Foldable
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
-import Database.Esqueleto hiding (delete, (%), (==.))
 import Text.Blaze.Html (Html)
 import Yesod.Auth (requireAuth)
 import Yesod.Core
@@ -49,47 +70,198 @@ import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, get404, getBy404)
 
+import qualified Data.ByteString.Lazy as BL
 import qualified Database.Esqueleto as E
 
 import Database.Persist.JSON
+import Development.PatchMediaType
 import Network.FedURI
 import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
+import Yesod.Hashids
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
+import Data.Paginate.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.Actor
 import Vervis.API
-import Vervis.Client
 import Vervis.Federation
-import Vervis.Form.Project
 import Vervis.Foundation
 import Vervis.Model
-import Vervis.Model.Ident
+import Vervis.Paginate
-import Development.PatchMediaType
 import Vervis.Settings
-import Vervis.Widget.Project
+import Vervis.Widget.Person
-import Vervis.Widget.Sharer
-import Vervis.Widget.Workflow
 
-getProjectsR :: ShrIdent -> Handler Html
+getDeckR :: KeyHashid Deck -> Handler TypedContent
-getProjectsR ident = do
+getDeckR deckHash = do
-    projects <- runDB $ select $ from $ \ (sharer, project) -> do
+    deckID <- decodeKeyHashid404 deckHash
-        where_ $
+    (deck, repoIDs, actor) <- runDB $ do
-            sharer ^. SharerIdent E.==. val ident                &&.
+        d <- get404 deckID
-            sharer ^. SharerId    E.==. project ^. ProjectSharer
+        rs <- selectKeysList [RepoProject ==. Just deckID] [Asc RepoId]
-        orderBy [asc $ project ^. ProjectIdent]
+        (d,rs,) <$> getJust (deckActor d)
-        return $ project ^. ProjectIdent
-    defaultLayout $(widgetFile "project/list")
 
-postProjectsR :: ShrIdent -> Handler Html
+    encodeRouteLocal <- getEncodeRouteLocal
-postProjectsR shr = do
+    let deckAP = AP.TicketTracker
+            { AP.ticketTrackerActor = AP.Actor
+                { AP.actorLocal = AP.ActorLocal
+                    { AP.actorId         = encodeRouteLocal $ DeckR deckHash
+                    , AP.actorInbox      = encodeRouteLocal $ DeckInboxR deckHash
+                    , AP.actorOutbox     =
+                        Just $ encodeRouteLocal $ DeckOutboxR deckHash
+                    , AP.actorFollowers  =
+                        Just $ encodeRouteLocal $ DeckFollowersR deckHash
+                    , AP.actorFollowing  = Nothing
+                    , AP.actorPublicKeys =
+                        [ Left $ encodeRouteLocal ActorKey1R
+                        , Left $ encodeRouteLocal ActorKey2R
+                        ]
+                    , AP.actorSshKeys    = []
+                    }
+                , AP.actorDetail = AP.ActorDetail
+                    { AP.actorType       = ActorTypeTicketTracker
+                    , AP.actorUsername   = Nothing
+                    , AP.actorName       = Just $ actorName actor
+                    , AP.actorSummary    = Just $ actorDesc actor
+                    }
+                }
+            , AP.ticketTrackerTeam = Nothing
+            }
+        followButton =
+            followW
+                (DeckFollowR deckHash)
+                (DeckUnfollowR deckHash)
+                (actorFollowers actor)
+
+    provideHtmlAndAP deckAP $ redirectToPrettyJSON $ DeckR deckHash
+
+getDeckInboxR :: KeyHashid Deck -> Handler TypedContent
+getDeckInboxR = getInbox DeckInboxR deckActor
+
+postDeckInboxR :: KeyHashid Deck -> Handler TypedContent
+postDeckInboxR _ = error "Temporarily disabled"
+
+getDeckOutboxR :: KeyHashid Deck -> Handler TypedContent
+getDeckOutboxR = getOutbox DeckOutboxR deckActor
+
+getDeckOutboxItemR
+    :: KeyHashid Deck -> KeyHashid OutboxItem -> Handler TypedContent
+getDeckOutboxItemR = getOutboxItem DeckOutboxItemR deckActor
+
+getDeckFollowersR :: KeyHashid Deck -> Handler TypedContent
+getDeckFollowersR = getActorFollowersCollection DeckFollowersR deckActor
+
+getDeckTicketsR :: KeyHashid Deck -> Handler TypedContent
+getDeckTicketsR deckHash = selectRep $ do
+    {-
+    provideRep $ do
+        ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
+        let tf =
+                case filtResult of
+                    FormSuccess filt -> filt
+                    FormMissing      -> def
+                    FormFailure l    ->
+                        error $ "Ticket filter form failed: " ++ show l
+        (total, pages, mpage) <- runDB $ do
+            Entity sid _ <- getBy404 $ UniqueSharer shr
+            Entity jid _ <- getBy404 $ UniqueProject prj sid
+            let countAllTickets = count [TicketProjectLocalProject ==. jid]
+                selectTickets off lim =
+                    getTicketSummaries
+                        (filterTickets tf)
+                        (Just $ \ t -> [E.asc $ t E.^. TicketId])
+                        (Just (off, lim))
+                        jid
+            getPageAndNavCount countAllTickets selectTickets
+        case mpage of
+            Nothing -> redirectFirstPage here
+            Just (rows, navModel) ->
+                let pageNav = navWidget navModel
+                in  defaultLayout $(widgetFile "ticket/list")
+    -}
+    provideAP' $ do
+        deckID <- decodeKeyHashid404 deckHash
+        (total, pages, mpage) <- runDB $ do
+            let countAllTickets = count [TicketDeckDeck ==. deckID]
+                selectTickets off lim =
+                    selectKeysList
+                        [TicketDeckDeck ==. deckID]
+                        [OffsetBy off, LimitTo lim, Desc TicketDeckTicket]
+            getPageAndNavCount countAllTickets selectTickets
+
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+        hashTicket <- getEncodeKeyHashid
+        encodeRoutePageLocal <- getEncodeRoutePageLocal
+        let pageUrl = encodeRoutePageLocal here
+        host <- asksSite siteInstanceHost
+        return $
+            case mpage of
+                Nothing -> encodeStrict $ Doc host $ Collection
+                    { collectionId         = encodeRouteLocal here
+                    , collectionType       = CollectionTypeOrdered
+                    , collectionTotalItems = Just total
+                    , collectionCurrent    = Nothing
+                    , collectionFirst      = Just $ pageUrl 1
+                    , collectionLast       = Just $ pageUrl pages
+                    , collectionItems      = [] :: [Text]
+                    }
+                Just (tickets, navModel) ->
+                    let current = nmCurrent navModel
+                    in  encodeStrict $ 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      =
+                                encodeRouteHome . TicketR deckHash . hashTicket <$> tickets
+                            }
+    where
+    here = DeckTicketsR deckHash
+    encodeStrict = BL.toStrict . encode
+
+getDeckTreeR :: KeyHashid Deck -> Handler Html
+getDeckTreeR _ = error "Temporarily disabled"
+    {-
+    (summaries, deps) <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shr
+        Entity jid _ <- getBy404 $ UniqueProject prj sid
+        (,) <$> getTicketSummaries Nothing Nothing Nothing jid
+            <*> getTicketDepEdges jid
+    defaultLayout $ ticketTreeDW shr prj summaries deps
+    -}
+
+getDeckNewR :: Handler Html
+getDeckNewR = do
+    error "Temporarily disabled"
+    {-
+    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
+    ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
+    defaultLayout $(widgetFile "project/new")
+    -}
+
+postDeckNewR :: Handler Html
+postDeckNewR = do
+    error "Temporarily disabled"
+    {-
     ep@(Entity _ p) <- requireAuth
     Entity sid s <- runDB $ do
         _ <- getBy404 $ UniqueSharer shr
@@ -115,64 +287,27 @@ postProjectsR shr = do
         Right prj -> do
             setMessage "Project created!"
             redirect $ ProjectR shr prj
+    -}
 
-getProjectNewR :: ShrIdent -> Handler Html
+postDeckDeleteR :: KeyHashid Deck -> Handler Html
-getProjectNewR shr = do
+postDeckDeleteR _ = error "Temporarily disabled"
-    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
-    ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
-    defaultLayout $(widgetFile "project/new")
 
-getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent
+getDeckEditR :: KeyHashid Deck -> Handler Html
-getProjectR shar proj = do
+getDeckEditR _ = do
-    (actor, project, workflow, wsharer, repos) <- runDB $ do
+    error "Temporarily disabled"
-        Entity sid s <- getBy404 $ UniqueSharer shar
+    {-
-        Entity pid p <- getBy404 $ UniqueProject proj sid
+    (sid, ep) <- runDB $ do
-        w <- get404 $ projectWorkflow p
+        Entity sid _sharer <- getBy404 $ UniqueSharer shr
-        sw <-
+        ep <- getBy404 $ UniqueProject prj sid
-            if workflowSharer w == sid
+        return (sid, ep)
-                then return s
+    ((_result, widget), enctype) <- runFormPost $ editProjectForm sid ep
-                else get404 $ workflowSharer w
+    defaultLayout $(widgetFile "project/edit")
-        rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
+    -}
-        a <- getJust $ projectActor p
-        return (a, p, w, sw, rs)
 
-    route2fed <- getEncodeRouteHome
+postDeckEditR :: KeyHashid Deck -> Handler Html
-    route2local <- getEncodeRouteLocal
+postDeckEditR _ = do
-    let projectAP = AP.TicketTracker
+    error "Temporarily disabled"
-            { AP.ticketTrackerActor = AP.Actor
+    {-
-                { AP.actorLocal = AP.ActorLocal
-                    { AP.actorId         = route2local $ ProjectR shar proj
-                    , AP.actorInbox      = route2local $ ProjectInboxR shar proj
-                    , AP.actorOutbox     =
-                        Just $ route2local $ ProjectOutboxR shar proj
-                    , AP.actorFollowers  =
-                        Just $ route2local $ ProjectFollowersR shar proj
-                    , AP.actorFollowing  = Nothing
-                    , AP.actorPublicKeys =
-                        [ Left $ route2local ActorKey1R
-                        , Left $ route2local ActorKey2R
-                        ]
-                    , AP.actorSshKeys    = []
-                    }
-                , AP.actorDetail = AP.ActorDetail
-                    { AP.actorType       = ActorTypeTicketTracker
-                    , AP.actorUsername   = Nothing
-                    , AP.actorName       =
-                        Just $ fromMaybe (prj2text proj) $ projectName project
-                    , AP.actorSummary    = projectDesc project
-                    }
-                }
-            , AP.ticketTrackerTeam = route2local $ ProjectTeamR shar proj
-            }
-        followButton =
-            followW
-                (ProjectFollowR shar proj)
-                (ProjectUnfollowR shar proj)
-                (return $ actorFollowers actor)
-    provideHtmlAndAP projectAP $(widgetFile "project/one")
-
-putProjectR :: ShrIdent -> PrjIdent -> Handler Html
-putProjectR shr prj = do
     (sid, ep@(Entity jid _)) <- runDB $ do
         Entity sid _sharer <- getBy404 $ UniqueSharer shr
         eproj <- getBy404 $ UniqueProject prj sid
@@ -189,22 +324,50 @@ putProjectR shr prj = do
         FormFailure _l -> do
             setMessage "Project update failed, see errors below."
             defaultLayout $(widgetFile "project/edit")
+    -}
 
-postProjectR :: ShrIdent -> PrjIdent -> Handler Html
+postDeckFollowR :: KeyHashid Deck -> Handler ()
-postProjectR shr prj = do
+postDeckFollowR _ = error "Temporarily disabled"
-    mmethod <- lookupPostParam "_method"
-    case mmethod of
-        Just "PUT" -> putProjectR shr prj
-        _          -> notFound
 
-getProjectEditR :: ShrIdent -> PrjIdent -> Handler Html
+postDeckUnfollowR :: KeyHashid Deck -> Handler ()
-getProjectEditR shr prj = do
+postDeckUnfollowR _ = error "Temporarily disabled"
-    (sid, ep) <- runDB $ do
+
-        Entity sid _sharer <- getBy404 $ UniqueSharer shr
+
-        ep <- getBy404 $ UniqueProject prj sid
+
-        return (sid, ep)
+
-    ((_result, widget), enctype) <- runFormPost $ editProjectForm sid ep
+
-    defaultLayout $(widgetFile "project/edit")
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-
+getProjectsR :: ShrIdent -> Handler Html
+getProjectsR ident = do
+    projects <- runDB $ select $ from $ \ (sharer, project) -> do
+        where_ $
+            sharer ^. SharerIdent E.==. val ident                &&.
+            sharer ^. SharerId    E.==. project ^. ProjectSharer
+        orderBy [asc $ project ^. ProjectIdent]
+        return $ project ^. ProjectIdent
+    defaultLayout $(widgetFile "project/list")
 
 getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
 getProjectDevsR shr prj = do
@@ -371,13 +534,4 @@ getProjectTeamR shr prj = do
             , collectionItems      = map (encodeRouteHome . SharerR) memberShrs
             }
     provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
-
+-}
-getProjectFollowersR :: ShrIdent -> PrjIdent -> Handler TypedContent
-getProjectFollowersR shr prj = getFollowersCollection here getFsid
-    where
-    here = ProjectFollowersR shr prj
-    getFsid = do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        j <- getValBy404 $ UniqueProject prj sid
-        a <- getJust $ projectActor j
-        return $ actorFollowers a

src/Vervis/Handler/Discussion.hs

@@ -15,11 +15,10 @@
 
 module Vervis.Handler.Discussion
     ( getDiscussion
-    , getDiscussionMessage
+    --, getTopReply
-    , getTopReply
+    --, postTopReply
-    , postTopReply
+    --, getReply
-    , getReply
+    --, postReply
-    , postReply
     )
 where
 
@@ -57,7 +56,6 @@ import Database.Persist.Local
 import Yesod.Persist.Local
 
 import Vervis.API
-import Vervis.Client
 import Vervis.Discussion
 import Vervis.Federation
 import Vervis.FedURI
@@ -69,8 +67,6 @@ import Yesod.RenderSource
 import Vervis.Settings
 import Vervis.Widget.Discussion
 
-import qualified Vervis.Client as C
-
 getDiscussion
     :: (MessageId -> Route App)
     -> Route App
@@ -79,6 +75,7 @@ getDiscussion
 getDiscussion reply topic getdid =
     defaultLayout $ discussionW getdid topic reply
 
+{-
 getNode :: AppDB DiscussionId -> MessageId -> AppDB MessageTreeNode
 getNode getdid mid = do
     did <- getdid
@@ -119,83 +116,6 @@ getNodeL getdid lmid = do
     return $ MessageTreeNode mid m $ MessageTreeNodeLocal lmid s
 -}
 
-getDiscussionMessage :: ShrIdent -> LocalMessageId -> Handler TypedContent
-getDiscussionMessage shr lmid = do
-    doc <- runDB $ do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        pid <- getKeyBy404 $ UniquePersonIdent sid
-        lm <- get404 lmid
-        unless (localMessageAuthor lm == pid) notFound
-        m <- getJust $ localMessageRest lm
-        route2fed <- getEncodeRouteHome
-        uContext <- do
-            let did = messageRoot m
-            mlt <- getBy $ UniqueLocalTicketDiscussion did
-            mrd <- getValBy $ UniqueRemoteDiscussion did
-            case (mlt, mrd) of
-                (Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context"
-                (Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts"
-                (Just (Entity ltid lt), Nothing) -> do
-                    tpl <- do
-                        mtpl <- runMaybeT $ do
-                            tclid <- MaybeT $ getKeyBy $ UniqueTicketContextLocal $ localTicketTicket lt
-                            MaybeT $ getValBy $ UniqueTicketProjectLocal tclid
-                        case mtpl of
-                            Nothing -> error "No TPL"
-                            Just v -> return v
-                    j <- getJust $ ticketProjectLocalProject tpl
-                    s <- getJust $ projectSharer j
-                    let shr = sharerIdent s
-                        prj = projectIdent j
-                    ltkhid <- encodeKeyHashid ltid
-                    return $ route2fed $ ProjectTicketR shr prj ltkhid
-                (Nothing, Just rd) -> do
-                    ro <- getJust $ remoteDiscussionIdent rd
-                    i <- getJust $ remoteObjectInstance ro
-                    return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
-        muParent <- for (messageParent m) $ \ midParent -> do
-            mlocal <- getBy $ UniqueLocalMessage midParent
-            mremote <- getValBy $ UniqueRemoteMessage midParent
-            case (mlocal, mremote) of
-                (Nothing, Nothing) -> fail "Message with no author"
-                (Just _, Just _) -> fail "Message used as both local and remote"
-                (Just (Entity lmidParent lmParent), Nothing) -> do
-                    p <- getJust $ localMessageAuthor lmParent
-                    s <- getJust $ personIdent p
-                    lmhidParent <- encodeKeyHashid lmidParent
-                    return $ route2fed $ MessageR (sharerIdent s) lmhidParent
-                (Nothing, Just rmParent) -> do
-                    rs <- getJust $ remoteMessageAuthor rmParent
-                    ro <- getJust $ remoteActorIdent rs
-                    i <- getJust $ remoteObjectInstance ro
-                    return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
-        --ob <- getJust $ localMessageCreate lm
-        --let activity = docValue $ persistJSONValue $ outboxItemActivity ob
-
-        host <- getsYesod $ appInstanceHost . appSettings
-        route2local <- getEncodeRouteLocal
-        lmhid <- encodeKeyHashid lmid
-        return $ Doc host Note
-            { noteId        = Just $ route2local $ MessageR shr lmhid
-            , noteAttrib    = route2local $ SharerR shr
-            , noteAudience  = Audience [] [] [] [] [] []
-                --case activitySpecific activity of
-                --    CreateActivity (Create note) -> noteAudience note
-                --    _ -> error $ "lmid#" ++ show (fromSqlKey lmid) ++ "'s create isn't a Create activity!"
-            , noteReplyTo   = Just $ fromMaybe uContext muParent
-            , noteContext   = Just uContext
-            , notePublished = Just $ messageCreated m
-            , noteSource    = messageSource m
-            , noteContent   = messageContent m
-            }
-    selectRep $ do
-        provideAP $ pure doc
-        provideRep $
-            defaultLayout
-                [whamlet|
-                    <div><pre>#{encodePrettyToLazyText doc}
-                |]
-
 getTopReply :: Route App -> Handler Html
 getTopReply replyP = do
     ((_result, widget), enctype) <- runFormPost newMessageForm
@@ -305,3 +225,4 @@ postReply hDest recipsA recipsC context recipF replyG replyP after getdid midPar
             case mlmid of
                 Nothing -> error "noteC succeeded but no lmid found for obiid"
                 Just lmid -> redirect $ after lmid
+-}

src/Vervis/Handler/Git.hs

@@ -14,8 +14,7 @@
  -}
 
 module Vervis.Handler.Git
-    ( getGitRefDiscoverR
+    (
-    , postGitUploadRequestR
     )
 where
 
@@ -50,42 +49,6 @@ import Vervis.Foundation (Handler)
 import Vervis.Model.Ident
 import Vervis.Path (askRepoDir)
 
-getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler TypedContent
-getGitRefDiscoverR shr rp = do
-    let typ = "application/x-git-upload-pack-advertisement"
-    path <- askRepoDir shr rp
-    let pathG = fromString path
-    seemsThere <- liftIO $ isRepo pathG
-    if seemsThere
-        then do
-            rq <- getRequest
-            case reqGetParams rq of
-                [("service", serv)] ->
-                    if serv == "git-upload-pack"
-                        then do
-                            let settings =
-                                    ( proc "git"
-                                        [ "upload-pack"
-                                        , "--stateless-rpc"
-                                        , "--advertise-refs"
-                                        , path
-                                        ]
-                                    )
-                                    { std_out = CreatePipe
-                                    }
-                            (_, mh, _, _) <-
-                                liftIO $ createProcess settings
-                            let h = fromJust mh
-                            refs <- liftIO $ B.hGetContents h
-                            let content = runPut $ do
-                                    putService UploadPack
-                                    putByteString refs
-                            setHeader "Cache-Control" "no-cache"
-                            return $ TypedContent typ $ toContent content
-                        else permissionDenied "Service not supported"
-                _ -> notFound
-        else notFound
-
 {-
 getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler GitRefDiscovery
 getGitRefDiscoverR shar repo = do
@@ -108,39 +71,6 @@ getGitRefDiscoverR shar repo = do
         else notFound
 -}
 
-postGitUploadRequestR :: ShrIdent -> RpIdent -> Handler TypedContent
-postGitUploadRequestR shr rp = do
-    let typ = "application/x-git-upload-pack-result"
-    path <- askRepoDir shr rp
-    let pathG = fromString path
-    seemsThere <- liftIO $ isRepo pathG
-    if seemsThere
-        then do
-            getBody <- strictRequestBody <$> waiRequest
-            body <- liftIO getBody
-            let settings =
-                    ( proc "git"
-                        [ "upload-pack"
-                        , "--stateless-rpc"
-                        , path
-                        ]
-                    )
-                    { std_in  = CreatePipe
-                    , std_out = CreatePipe
-                    }
-            (mhin, mhout, _, _) <- liftIO $ createProcess settings
-            let hin = fromJust mhin
-                hout = fromJust mhout
-            liftIO $ BL.hPut hin body >> hClose hin
-            setHeader "Cache-Control" "no-cache"
-            let loop = do
-                    b <- liftIO $ B.hGet hout BLI.defaultChunkSize
-                    unless (B.null b) $ do
-                        sendChunkBS b
-                        loop
-            respondSource typ loop
-        else notFound
-
 {- This is commented out for now because it doesn't work. The 'collectObjIds'
  - function file descriptor exhaustion. I don't know whether and how I can fix
  - that. Maybe dive deep into what happens under the hood in 'hit', or make a

src/Vervis/Handler/Group.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -14,16 +14,32 @@
  -}
 
 module Vervis.Handler.Group
-    ( getGroupsR
+    ( getGroupR
+    , getGroupInboxR
+    , postGroupInboxR
+    , getGroupOutboxR
+    , getGroupOutboxItemR
+    , getGroupFollowersR
+
+
+
+
+
+
+
+
+
+    {-
+    , getGroupsR
     , postGroupsR
     , getGroupNewR
-    , getGroup
     , getGroupMembersR
     , postGroupMembersR
     , getGroupMemberNewR
     , getGroupMemberR
     , deleteGroupMemberR
     , postGroupMemberR
+    -}
     )
 where
 
@@ -39,19 +55,95 @@ import Yesod.Core.Content (TypedContent)
 import Yesod.Core.Handler
 import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
-import Yesod.Persist.Core (runDB, getBy404)
+import Yesod.Persist.Core
 
 import qualified Database.Esqueleto as E
 
-import Vervis.Form.Group
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+
+import qualified Web.ActivityPub as AP
+
+import Vervis.Actor
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Group
-import Vervis.Model.Ident (ShrIdent, shr2text)
 import Vervis.Settings (widgetFile)
 import Vervis.Time (showDate)
-import Vervis.Widget.Sharer
 
+getGroupR :: KeyHashid Group -> Handler TypedContent
+getGroupR groupHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    (group, actor) <- runDB $ do
+        g <- get404 groupID
+        (g,) <$> getJust (groupActor g)
+
+    encodeRouteLocal <- getEncodeRouteLocal
+
+    let route mk = encodeRouteLocal $ mk groupHash
+        groupAP = AP.Actor
+            { AP.actorLocal = AP.ActorLocal
+                { AP.actorId         = route GroupR
+                , AP.actorInbox      = route GroupInboxR
+                , AP.actorOutbox     = Just $ route GroupOutboxR
+                , AP.actorFollowers  = Just $ route GroupFollowersR
+                , AP.actorFollowing  = Nothing
+                , AP.actorPublicKeys =
+                    [ Left $ encodeRouteLocal ActorKey1R
+                    , Left $ encodeRouteLocal ActorKey2R
+                    ]
+                , AP.actorSshKeys    = []
+                }
+            , AP.actorDetail = AP.ActorDetail
+                { AP.actorType       = AP.ActorTypeOther "Group"
+                , AP.actorUsername   = Nothing
+                , AP.actorName       = Just $ actorName actor
+                , AP.actorSummary    = Just $ actorDesc actor
+                }
+            }
+
+    provideHtmlAndAP groupAP $ redirectToPrettyJSON here
+    where
+    here = GroupR groupHash
+
+getGroupInboxR :: KeyHashid Group -> Handler TypedContent
+getGroupInboxR = getInbox GroupInboxR groupActor
+
+postGroupInboxR :: KeyHashid Group -> Handler TypedContent
+postGroupInboxR _ = error "Temporarily disabled"
+
+getGroupOutboxR :: KeyHashid Group -> Handler TypedContent
+getGroupOutboxR = getOutbox GroupOutboxR groupActor
+
+getGroupOutboxItemR
+    :: KeyHashid Group -> KeyHashid OutboxItem -> Handler TypedContent
+getGroupOutboxItemR = getOutboxItem GroupOutboxItemR groupActor
+
+getGroupFollowersR :: KeyHashid Group -> Handler TypedContent
+getGroupFollowersR = getActorFollowersCollection GroupFollowersR groupActor
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-
 getGroupsR :: Handler Html
 getGroupsR = do
     groups <- runDB $ select $ from $ \ (sharer, group) -> do
@@ -98,10 +190,6 @@ getGroupNewR = do
     ((_result, widget), enctype) <- runFormPost newGroupForm
     defaultLayout $(widgetFile "group/new")
 
-getGroup :: ShrIdent -> Group -> Handler TypedContent
-getGroup shar group = selectRep $ provideRep $
-    defaultLayout $(widgetFile "group/one")
-
 getGroupMembersR :: ShrIdent -> Handler Html
 getGroupMembersR shar = do
     (group, members) <- runDB $ do
@@ -211,3 +299,4 @@ postGroupMemberR grp memb = do
     case mmethod of
         Just "DELETE" -> deleteGroupMemberR grp memb
         _             -> notFound
+-}

src/Vervis/Handler/Home.hs

@@ -1,70 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ 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
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
-module Vervis.Handler.Home
-    ( getHomeR
-    )
-where
-
-import Database.Esqueleto hiding ((==.))
-import Yesod.Auth.Account (newAccountR)
-import Data.Time.Clock
-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import Data.Traversable
-import Database.Persist
-import Time.Types (Elapsed (..), Seconds (..))
-import Yesod.Auth
-import Yesod.Core
-import Yesod.Persist.Core
-
-import qualified Database.Esqueleto as E ((==.))
-
-import Data.EventTime.Local
-
-import Vervis.Darcs
-import Vervis.Foundation
-import Vervis.Model
-import Vervis.Model.Ident
-import Development.PatchMediaType
-import Vervis.Path
-import Vervis.Settings
-
-import qualified Vervis.Git as G
-import qualified Vervis.Darcs as D
-
-personalOverview :: Entity Person -> Handler Html
-personalOverview (Entity _pid person) = do
-    (ident, projects, repos) <- runDB $ do
-        let sid = personIdent person
-        sharer <- get404 sid
-        prjs <-
-            map (projectIdent . entityVal) <$>
-                selectList [ProjectSharer ==. sid] [Asc ProjectIdent]
-        rps <-
-            map (repoIdent . entityVal) <$>
-                selectList
-                    [RepoSharer ==. sid, RepoProject ==. Nothing]
-                    [Asc RepoIdent]
-        return (sharerIdent sharer, prjs, rps)
-    defaultLayout $ do
-        setTitle "Vervis > Overview"
-        $(widgetFile "personal-overview")
-
-getHomeR :: Handler Html
-getHomeR = do
-    mp <- maybeAuth
-    case mp of
-        Just p  -> personalOverview p
-        Nothing -> redirect BrowseR

src/Vervis/Handler/Inbox.hs

@@ -14,21 +14,22 @@
  -}
 
 module Vervis.Handler.Inbox
-    ( getInboxDebugR
+    ( getSharerInboxR
-    , getSharerInboxR
     , getProjectInboxR
+    , getDeckInboxR
     , getRepoInboxR
     , postSharerInboxR
     , postProjectInboxR
+    , postDeckInboxR
     , postRepoInboxR
     , getSharerOutboxR
     , getSharerOutboxItemR
     , getProjectOutboxR
     , getProjectOutboxItemR
+    , getDeckOutboxR
+    , getDeckOutboxItemR
     , getRepoOutboxR
     , getRepoOutboxItemR
-    , getActorKey1R
-    , getActorKey2R
     )
 where
 
@@ -103,8 +104,6 @@ import Vervis.Model.Ident
 import Vervis.Paginate
 import Vervis.Settings
 
-import qualified Vervis.Client as C
-
 getShowTime = showTime <$> liftIO getCurrentTime
     where
     showTime now =
@@ -123,124 +122,6 @@ objectId o =
         Just (String t) | not (T.null t) -> t
         _ -> error "'id' field not found"
 
-getInboxDebugR :: Handler Html
-getInboxDebugR = do
-    acts <-
-        liftIO . readTVarIO . snd =<< maybe notFound return =<< getsYesod appActivities
-    defaultLayout
-        [whamlet|
-            <p>
-              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 (currently, only ticket
-              comments), 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.
-            <p>Last 10 activities posted:
-            <ul>
-              $forall ActivityReport time msg ctypes body <- acts
-                <li>
-                  <div>#{show time}
-                  <div>#{msg}
-                  <div><code>#{intercalate " | " $ map BC.unpack ctypes}
-                  <div><pre>#{decodeUtf8 body}
-        |]
-
-getInbox :: Route App -> AppDB InboxId -> Handler TypedContent
-getInbox here getInboxId = do
-    (total, pages, mpage) <- runDB $ do
-        ibid <- getInboxId
-        getPageAndNavCount
-            (countItems ibid)
-            (\ off lim -> map adaptItem <$> getItems ibid off lim)
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRoutePageLocal <- getEncodeRoutePageLocal
-    let 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)
-
 getSharerInboxR :: ShrIdent -> Handler TypedContent
 getSharerInboxR shr = getInbox here getInboxId
     where
@@ -260,6 +141,16 @@ getProjectInboxR shr prj = getInbox here getInboxId
         a <- getJust $ projectActor j
         return $ actorInbox a
 
+getDeckInboxR :: KeyHashid Project -> Handler TypedContent
+getDeckInboxR dkkhid = do
+    dkid <- decodeKeyHashid404 dkkhid
+    getInbox here (getInboxId dkid)
+    where
+    here = ProjectInboxR dkkhid
+    getInboxId dkid = do
+        dk <- get404 dkid
+        actorInbox <$> getJust (projectActor dk)
+
 getRepoInboxR :: ShrIdent -> RpIdent -> Handler TypedContent
 getRepoInboxR shr rp = getInbox here getInboxId
     where
@@ -330,6 +221,9 @@ postSharerInboxR shrRecip = handleInbox $ handleSharerInbox shrRecip
 postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
 postProjectInboxR shr prj = handleInbox $ handleProjectInbox shr prj
 
+postDeckInboxR :: KeyHashid Project -> Handler ()
+postDeckInboxR dkkhid = handleInbox $ handleDeckInbox dkkhid
+
 postRepoInboxR :: ShrIdent -> RpIdent -> Handler ()
 postRepoInboxR shr rp = handleInbox $ handleRepoInbox shr rp
 
@@ -342,70 +236,6 @@ jsonField = checkMMap fromTextarea toTextarea textareaField
 -}
 
 
-getOutbox :: Route App -> AppDB OutboxId -> Handler TypedContent
-getOutbox here getObid = do
-    (total, pages, mpage) <- runDB $ do
-        obid <- getObid
-        let countAllItems = count [OutboxItemOutbox ==. obid]
-            selectItems off lim = selectList [OutboxItemOutbox ==. obid] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
-        getPageAndNavCount countAllItems selectItems
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRoutePageLocal <- getEncodeRoutePageLocal
-    let 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
-    :: Route App
-    -> AppDB OutboxId
-    -> KeyHashid OutboxItem
-    -> Handler TypedContent
-getOutboxItem here getObid obikhid = do
-    obiid <- decodeKeyHashid404 obikhid
-    body <- runDB $ do
-        obid <- getObid
-        obi <- get404 obiid
-        unless (outboxItemOutbox obi == obid) notFound
-        return $ outboxItemActivity obi
-    provideHtmlAndAP'' body $ redirect (here, [("prettyjson", "true")])
-
 getSharerOutboxR :: ShrIdent -> Handler TypedContent
 getSharerOutboxR shr = getOutbox here getObid
     where
@@ -445,6 +275,27 @@ getProjectOutboxItemR shr prj obikhid = getOutboxItem here getObid obikhid
         a <- getJust $ projectActor j
         return $ actorOutbox a
 
+getDeckOutboxR :: KeyHashid Project -> Handler TypedContent
+getDeckOutboxR dkkhid = do
+    dkid <- decodeKeyHashid404 dkkhid
+    getOutbox here (getObid dkid)
+    where
+    here = DeckOutboxR dkkhid
+    getObid dkid = do
+        dk <- get404 dkid
+        actorOutbox <$> getJust (projectActor dk)
+
+getDeckOutboxItemR
+    :: KeyHashid Project -> KeyHashid OutboxItem -> Handler TypedContent
+getDeckOutboxItemR dkkhid obikhid = do
+    dkid <- decodeKeyHashid404 dkkhid
+    getOutboxItem here (getObid dkid) obikhid
+    where
+    here = DeckOutboxItemR dkkhid obikhid
+    getObid dkid = do
+        dk <- get404 dkid
+        actorOutbox <$> getJust (projectActor dk)
+
 getRepoOutboxR :: ShrIdent -> RpIdent -> Handler TypedContent
 getRepoOutboxR shr rp = getOutbox here getObid
     where
@@ -463,23 +314,3 @@ getRepoOutboxItemR shr rp obikhid = getOutboxItem here getObid obikhid
         sid <- getKeyBy404 $ UniqueSharer shr
         r <- getValBy404 $ UniqueRepo rp sid
         return $ repoOutbox r
-
-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 = PublicKey
-            { publicKeyId       = LocalRefURI $ Left $ encodeRouteLocal route
-            , publicKeyExpires  = Nothing
-            , publicKeyOwner    = OwnerInstance
-            , publicKeyMaterial = actorKey
-            }
-    provideHtmlAndAP key $ redirect (route, [("prettyjson", "true")])
-
-getActorKey1R :: Handler TypedContent
-getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R
-
-getActorKey2R :: Handler TypedContent
-getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R

src/Vervis/Handler/Key.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -18,7 +18,6 @@ module Vervis.Handler.Key
     , postKeysR
     , getKeyNewR
     , getKeyR
-    , getSshKeyR
     , deleteKeyR
     , postKeyR
     )
@@ -55,6 +54,7 @@ import Vervis.Model.Ident
 import Vervis.Settings
 import Vervis.Widget (buttonW)
 
+{-
 getKeysR :: Handler Html
 getKeysR = do
     pid <- requireAuthId
@@ -92,30 +92,9 @@ getKeyR tag = do
     let toText = decodeUtf8With lenientDecode
         content = toText $ encode $ sshKeyContent key
     defaultLayout $(widgetFile "key/one")
+-}
 
-getSshKeyR :: ShrIdent -> KeyHashid SshKey -> Handler TypedContent
+{-
-getSshKeyR shr skkhid = do
-    skid <- decodeKeyHashid404 skkhid
-    key <- runDB $ do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        pid <- getKeyBy404 $ UniquePersonIdent sid
-        sk <- get404 skid
-        unless (sshKeyPerson sk == pid) notFound
-        return sk
-    encodeRouteLocal <- getEncodeRouteLocal
-    let here = SshKeyR shr skkhid
-        keyAP = SshPublicKey
-            { sshPublicKeyId        = encodeRouteLocal here
-            , sshPublicKeyExpires   = Nothing
-            , sshPublicKeyOwner     = encodeRouteLocal $ SharerR shr
-            , sshPublicKeyAlgorithm =
-                case sshKeyAlgo key of
-                    "ssh-rsa" -> SshKeyAlgorithmRSA
-                    _         -> error "Unexpected sshKeyAlgo in DB"
-            , sshPublicKeyMaterial  = sshKeyContent key
-            }
-    provideHtmlAndAP keyAP $ redirectToPrettyJSON here
-
 deleteKeyR :: KyIdent -> Handler Html
 deleteKeyR tag = do
     pid <- requireAuthId
@@ -131,3 +110,4 @@ postKeyR tag = do
     case mmethod of
         Just "DELETE" -> deleteKeyR tag
         _             -> notFound
+-}

src/Vervis/Handler/Loom.hs

@@ -0,0 +1,200 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Handler.Loom
+    ( getLoomR
+    , getLoomInboxR
+    , postLoomInboxR
+    , getLoomOutboxR
+    , getLoomOutboxItemR
+    , getLoomFollowersR
+    , getLoomClothsR
+    )
+where
+
+import Control.Monad
+import Control.Monad.Trans.Except
+import Data.Aeson
+import Data.Foldable
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist
+import Text.Blaze.Html (Html)
+import Yesod.Auth (requireAuth)
+import Yesod.Core
+import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
+import Yesod.Form.Functions (runFormPost)
+import Yesod.Form.Types (FormResult (..))
+import Yesod.Persist.Core (runDB, get404, getBy404)
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Database.Esqueleto as E
+
+import Database.Persist.JSON
+import Development.PatchMediaType
+import Network.FedURI
+import Yesod.ActivityPub
+import Yesod.Hashids
+import Yesod.FedURI
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Data.Paginate.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.Actor
+import Vervis.API
+import Vervis.Federation
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Paginate
+import Vervis.Settings
+
+getLoomR :: KeyHashid Loom -> Handler TypedContent
+getLoomR loomHash = do
+    loomID <- decodeKeyHashid404 loomHash
+    (loom, actor) <- runDB $ do
+        l <- get404 loomID
+        (l,) <$> getJust (loomActor l)
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    let route mk = encodeRouteLocal $ mk loomHash
+        loomAP = AP.Actor
+            { AP.actorLocal = AP.ActorLocal
+                { AP.actorId         = route LoomR
+                , AP.actorInbox      = route LoomInboxR
+                , AP.actorOutbox     = Just $ route LoomOutboxR
+                , AP.actorFollowers  = Just $ route LoomFollowersR
+                , AP.actorFollowing  = Nothing
+                , AP.actorPublicKeys =
+                    [ Left $ encodeRouteLocal ActorKey1R
+                    , Left $ encodeRouteLocal ActorKey2R
+                    ]
+                , AP.actorSshKeys    = []
+                }
+            , AP.actorDetail = AP.ActorDetail
+                { AP.actorType       = AP.ActorTypeOther "PatchTracker"
+                , AP.actorUsername   = Nothing
+                , AP.actorName       = Just $ actorName actor
+                , AP.actorSummary    = Just $ actorDesc actor
+                }
+            }
+
+    provideHtmlAndAP loomAP $ redirectToPrettyJSON here
+    where
+    here = LoomR loomHash
+
+getLoomInboxR :: KeyHashid Loom -> Handler TypedContent
+getLoomInboxR = getInbox LoomInboxR loomActor
+
+postLoomInboxR :: KeyHashid Loom -> Handler TypedContent
+postLoomInboxR _ = error "Temporarily disabled"
+
+getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent
+getLoomOutboxR = getOutbox LoomOutboxR loomActor
+
+getLoomOutboxItemR
+    :: KeyHashid Loom -> KeyHashid OutboxItem -> Handler TypedContent
+getLoomOutboxItemR = getOutboxItem LoomOutboxItemR loomActor
+
+getLoomFollowersR :: KeyHashid Loom -> Handler TypedContent
+getLoomFollowersR = getActorFollowersCollection LoomFollowersR loomActor
+
+getLoomClothsR :: KeyHashid Loom -> Handler TypedContent
+getLoomClothsR loomHash = selectRep $ do
+    {-
+    provideRep $ do
+        ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
+        let tf =
+                case filtResult of
+                    FormSuccess filt -> filt
+                    FormMissing      -> def
+                    FormFailure l    ->
+                        error $ "Ticket filter form failed: " ++ show l
+        (total, pages, mpage) <- runDB $ do
+            Entity sid _ <- getBy404 $ UniqueSharer shr
+            Entity jid _ <- getBy404 $ UniqueProject prj sid
+            let countAllTickets = count [TicketProjectLocalProject ==. jid]
+                selectTickets off lim =
+                    getTicketSummaries
+                        (filterTickets tf)
+                        (Just $ \ t -> [E.asc $ t E.^. TicketId])
+                        (Just (off, lim))
+                        jid
+            getPageAndNavCount countAllTickets selectTickets
+        case mpage of
+            Nothing -> redirectFirstPage here
+            Just (rows, navModel) ->
+                let pageNav = navWidget navModel
+                in  defaultLayout $(widgetFile "ticket/list")
+    -}
+    AP.provideAP' $ do
+        loomID <- decodeKeyHashid404 loomHash
+        (total, pages, mpage) <- runDB $ do
+            let countAllTickets = count [TicketLoomLoom ==. loomID]
+                selectTickets off lim =
+                    selectKeysList
+                        [TicketLoomLoom ==. loomID]
+                        [OffsetBy off, LimitTo lim, Desc TicketLoomTicket]
+            getPageAndNavCount countAllTickets selectTickets
+
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+        hashTicket <- getEncodeKeyHashid
+        encodeRoutePageLocal <- getEncodeRoutePageLocal
+        let pageUrl = encodeRoutePageLocal here
+        host <- asksSite siteInstanceHost
+        return $
+            case mpage of
+                Nothing -> encodeStrict $ AP.Doc host $ AP.Collection
+                    { AP.collectionId         = encodeRouteLocal here
+                    , AP.collectionType       = AP.CollectionTypeOrdered
+                    , AP.collectionTotalItems = Just total
+                    , AP.collectionCurrent    = Nothing
+                    , AP.collectionFirst      = Just $ pageUrl 1
+                    , AP.collectionLast       = Just $ pageUrl pages
+                    , AP.collectionItems      = [] :: [Text]
+                    }
+                Just (tickets, navModel) ->
+                    let current = nmCurrent navModel
+                    in  encodeStrict $ AP.Doc host $ AP.CollectionPage
+                            { AP.collectionPageId         = pageUrl current
+                            , AP.collectionPageType       = AP.CollectionPageTypeOrdered
+                            , AP.collectionPageTotalItems = Nothing
+                            , AP.collectionPageCurrent    = Just $ pageUrl current
+                            , AP.collectionPageFirst      = Just $ pageUrl 1
+                            , AP.collectionPageLast       = Just $ pageUrl pages
+                            , AP.collectionPagePartOf     = encodeRouteLocal here
+                            , AP.collectionPagePrev       =
+                                if current > 1
+                                    then Just $ pageUrl $ current - 1
+                                    else Nothing
+                            , AP.collectionPageNext       =
+                                if current < pages
+                                    then Just $ pageUrl $ current + 1
+                                    else Nothing
+                            , AP.collectionPageStartIndex = Nothing
+                            , AP.collectionPageItems      =
+                                encodeRouteHome . ClothR loomHash . hashTicket <$> tickets
+                            }
+    where
+    here = LoomClothsR loomHash
+    encodeStrict = BL.toStrict . encode

src/Vervis/Handler/Person.hs

@@ -14,13 +14,28 @@
  -}
 
 module Vervis.Handler.Person
-    ( getResendVerifyEmailR
+    ( getPersonR
-    , getPeopleR
+    , getPersonInboxR
-    , getPerson
+    , postPersonInboxR
+    , getPersonOutboxR
+    , postPersonOutboxR
+    , getPersonOutboxItemR
+    , getPersonFollowersR
+    , getPersonFollowingR
+    , getSshKeyR
+    , getPersonMessageR
+
+    , postPersonFollowR
+    , postPersonUnfollowR
     )
 where
 
-import Database.Esqueleto hiding (isNothing, count)
+import Control.Monad
+import Control.Monad.Trans.Except
+import Data.Maybe
+import Data.Traversable
+import Database.Persist
+import Dvara
 import Text.Blaze.Html (toHtml)
 import Yesod.Core
 import Yesod.Auth.Account (newAccountR, resendVerifyEmailWidget, username)
@@ -28,138 +43,254 @@ import Yesod.Auth.Account.Message (AccountMsg (MsgEmailUnverified))
 import Yesod.Persist.Core
 
 import qualified Data.Text as T (unpack)
-import qualified Database.Persist as P
 
 import Yesod.Auth.Unverified (requireUnverifiedAuth)
 
 import Text.Email.Local
 
 import Network.FedURI
-import Web.ActivityPub
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
 
+import qualified Web.ActivityPub as AP
+
+import Data.Either.Local
+import Database.Persist.Local
+
+import Vervis.ActivityPub
+import Vervis.Actor
 import Vervis.ActorKey
 import Vervis.Foundation
-import Vervis.Model hiding (Actor (..))
+import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Secure
 import Vervis.Settings
-import Vervis.Widget (avatarW)
+import Vervis.Ticket
-import Vervis.Widget.Sharer
+import Vervis.Widget
+import Vervis.Widget.Person
 
--- | Account verification email resend form
+getPersonR :: KeyHashid Person -> Handler TypedContent
-getResendVerifyEmailR :: Handler Html
+getPersonR personHash = do
-getResendVerifyEmailR = do
+    personID <- decodeKeyHashid404 personHash
-    person <- requireUnverifiedAuth
+    (person, actor, sshKeyIDs) <- runDB $ do
-    defaultLayout $ do
+        p <- get404 personID
-        setTitleI MsgEmailUnverified
+        a <- getJust $ personActor p
-        [whamlet|
+        ks <- selectKeysList [SshKeyPerson ==. personID] [Asc SshKeyId]
-            <p>_{MsgEmailUnverified}
+        return (p, a, ks)
-            ^{resendVerifyEmailWidget (username person) AuthR}
-        |]
-
--- | Get list of users
-getPeopleR :: Handler Html
-getPeopleR = do
-    people <- runDB $ select $ from $ \ (sharer, person) -> do
-        where_ $ sharer ^. SharerId ==. person ^. PersonIdent
-        orderBy [asc $ sharer ^. SharerIdent]
-        return $ sharer ^. SharerIdent
-    defaultLayout $(widgetFile "people")
-
-{-
--- | Create new user
-postPeopleR :: Handler Html
-postPeopleR = redirect $ AuthR newAccountR
-    settings <- getsYesod appSettings
-    if appRegister settings
-        then do
-            room <- case appAccounts settings of
-                Nothing -> return True
-                Just cap -> do
-                    current <- runDB $ count ([] :: [Filter Person])
-                    return $ current < cap
-            if room
-                then do
-                    ((result, widget), enctype) <- runFormPost newPersonForm
-                    case result of
-                        FormSuccess np -> do
-                            now <- liftIO getCurrentTime
-                            runDB $ do
-                                let sharer = Sharer
-                                        { sharerIdent   = npLogin np
-                                        , sharerName    = npName np
-                                        , sharerCreated = now
-                                        }
-                                sid <- insert sharer
-                                let person = Person
-                                        { personIdent = sid
-                                        , personLogin = shr2text $ npLogin np
-                                        , personHash  = Nothing
-                                        , personEmail = npEmail np
-                                        }
-                                person' <- setPassword (npPass np) person
-                                insert_ person'
-                            redirectUltDest HomeR
-                        FormMissing -> do
-                            setMessage "Field(s) missing"
-                            defaultLayout $(widgetFile "person-new")
-                        FormFailure _l -> do
-                            setMessage
-                                "User registration failed, see errors below"
-                            defaultLayout $(widgetFile "person-new")
-                else do
-                    setMessage "Maximal number of registered users reached"
-                    redirect PeopleR
-        else do
-            setMessage "User registration disabled"
-            redirect PeopleR
--}
-
-{-
-getPersonNewR :: Handler Html
-getPersonNewR = redirect $ AuthR newAccountR
-    regEnabled <- getsYesod $ appRegister . appSettings
-    if regEnabled
-        then do
-            ((_result, widget), enctype) <- runFormPost newPersonForm
-            defaultLayout $(widgetFile "person-new")
-        else notFound
--}
-
-getPerson :: ShrIdent -> Sharer -> Entity Person -> Handler TypedContent
-getPerson shr sharer (Entity pid person) = do
     encodeRouteLocal <- getEncodeRouteLocal
-    encodeKeyHashid <- getEncodeKeyHashid
+    hashSshKey <- getEncodeKeyHashid
-    skids <- runDB $ P.selectKeysList [SshKeyPerson P.==. pid] [P.Asc SshKeyId]
+
-    let personAP = Actor
+    let personAP = AP.Actor
-            { actorLocal = ActorLocal
+            { AP.actorLocal = AP.ActorLocal
-                { actorId         = encodeRouteLocal $ SharerR shr
+                { AP.actorId         = encodeRouteLocal $ PersonR personHash
-                , actorInbox      = encodeRouteLocal $ SharerInboxR shr
+                , AP.actorInbox      = encodeRouteLocal $ PersonInboxR personHash
-                , actorOutbox     = Just $ encodeRouteLocal $ SharerOutboxR shr
+                , AP.actorOutbox     = Just $ encodeRouteLocal $ PersonOutboxR personHash
-                , actorFollowers  = Just $ encodeRouteLocal $ SharerFollowersR shr
+                , AP.actorFollowers  = Just $ encodeRouteLocal $ PersonFollowersR personHash
-                , actorFollowing  = Just $ encodeRouteLocal $ SharerFollowingR shr
+                , AP.actorFollowing  = Just $ encodeRouteLocal $ PersonFollowingR personHash
-                , actorPublicKeys =
+                , AP.actorPublicKeys =
                     [ Left $ encodeRouteLocal ActorKey1R
                     , Left $ encodeRouteLocal ActorKey2R
                     ]
-                , actorSshKeys    =
+                , AP.actorSshKeys    =
-                    map (encodeRouteLocal . SshKeyR shr . encodeKeyHashid) skids
+                    map (encodeRouteLocal . SshKeyR personHash . hashSshKey) sshKeyIDs
                 }
-            , actorDetail = ActorDetail
+            , AP.actorDetail = AP.ActorDetail
-                { actorType       = ActorTypePerson
+                { AP.actorType       = AP.ActorTypePerson
-                , actorUsername   = Just $ shr2text shr
+                , AP.actorUsername   = Just $ username2text $ personUsername person
-                , actorName       = sharerName sharer
+                , AP.actorName       = Just $ actorName actor
-                , actorSummary    = Nothing
+                , AP.actorSummary    = Just $ actorDesc actor
                 }
             }
+        followButton =
+            followW
+                (PersonFollowR personHash)
+                (PersonUnfollowR personHash)
+                (actorFollowers actor)
+
+    let ep = Entity personID person
     secure <- getSecure
     provideHtmlAndAP personAP $(widgetFile "person")
+
+getPersonInboxR :: KeyHashid Person -> Handler TypedContent
+getPersonInboxR = getInbox PersonInboxR personActor
+
+postPersonInboxR :: KeyHashid Person -> Handler TypedContent
+postPersonInboxR _ = error "Temporarily disabled"
+
+getPersonOutboxR :: KeyHashid Person -> Handler TypedContent
+getPersonOutboxR = getOutbox PersonOutboxR personActor
+
+postPersonOutboxR :: KeyHashid Person -> Handler TypedContent
+postPersonOutboxR personHash = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+
+    personID <- decodeKeyHashid404 personHash
+    person <- runDB $ get404 personID
+
+    verifyPermission personID
+    verifyContentTypeAP
+
+    AP.Doc h activity <- requireInsecureJsonBody
+    hl <- hostIsLocal h
+    unless hl $ invalidArgs ["Activity host isn't the instance host"]
+
+    result <- runExceptT $ do
+        verifyAttribution $ AP.activityActor activity
+        handle (Entity personID person) activity
+    case result of
+        Left err -> invalidArgs [err]
+        Right outboxItemID -> do
+            outboxItemHash <- encodeKeyHashid outboxItemID
+            sendResponseCreated $ PersonOutboxItemR personHash outboxItemHash
     where
-    followButton =
+    verifyPermission recipientID = do
-        followW
+        (_app, mpid, _scopes) <- maybe notAuthenticated return =<< getDvaraAuth
-            (SharerFollowR shr)
+        senderID <-
-            (SharerUnfollowR shr)
+            maybe (permissionDenied "Not authorized to post as a user") return mpid
-            (return $ personFollowers person)
+        unless (recipientID == senderID) $
+            permissionDenied "Can't post as other users"
+
+    verifyAttribution actor =
+        case decodeRouteLocal actor of
+            Just (PersonR actorHash) | actorHash == personHash -> return ()
+            _ -> throwE "Can't post activity attributed to someone else"
+
+    handle eperson (AP.Activity _mid actor mcap summary audience specific) =
+        case specific of
+            {-
+            AddActivity (AP.Add obj target) ->
+                case obj of
+                    Right (AddBundle patches) ->
+                        addBundleC eperson sharer summary audience patches target
+                    _ -> throwE "Unsupported Add 'object' type"
+            ApplyActivity apply ->
+                applyC eperson sharer summary audience mcap apply
+            CreateActivity (Create obj mtarget) ->
+                case obj of
+                    CreateNote _ note ->
+                        createNoteC eperson sharer summary audience note mtarget
+                    CreateTicket _ ticket ->
+                        createTicketC eperson sharer summary audience ticket mtarget
+                    _ -> throwE "Unsupported Create 'object' type"
+            FollowActivity follow ->
+                followC shr summary audience follow
+            OfferActivity (Offer obj target) ->
+                case obj of
+                    OfferTicket ticket ->
+                        offerTicketC eperson sharer summary audience ticket target
+                    OfferDep dep ->
+                        offerDepC eperson sharer summary audience dep target
+                    _ -> throwE "Unsupported Offer 'object' type"
+            ResolveActivity resolve ->
+                resolveC eperson sharer summary audience resolve
+            UndoActivity undo ->
+                undoC eperson sharer summary audience undo
+            -}
+            _ -> throwE "Unsupported activity type"
+
+getPersonOutboxItemR
+    :: KeyHashid Person -> KeyHashid OutboxItem -> Handler TypedContent
+getPersonOutboxItemR = getOutboxItem PersonOutboxItemR personActor
+
+getPersonFollowersR :: KeyHashid Person -> Handler TypedContent
+getPersonFollowersR = getActorFollowersCollection PersonFollowersR personActor
+
+getPersonFollowingR :: KeyHashid Person -> Handler TypedContent
+getPersonFollowingR = getFollowingCollection PersonFollowingR personActor
+
+getSshKeyR :: KeyHashid Person -> KeyHashid SshKey -> Handler TypedContent
+getSshKeyR personHash keyHash = do
+    personID <- decodeKeyHashid404 personHash
+    keyID <- decodeKeyHashid404 keyHash
+    key <- runDB $ do
+        _ <- get404 personID
+        k <- get404 keyID
+        unless (sshKeyPerson k == personID) notFound
+        return k
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    let here = SshKeyR personHash keyHash
+        keyAP = AP.SshPublicKey
+            { AP.sshPublicKeyId        = encodeRouteLocal here
+            , AP.sshPublicKeyExpires   = Nothing
+            , AP.sshPublicKeyOwner     = encodeRouteLocal $ PersonR personHash
+            , AP.sshPublicKeyAlgorithm =
+                case sshKeyAlgo key of
+                    "ssh-rsa" -> AP.SshKeyAlgorithmRSA
+                    _         -> error "Unexpected sshKeyAlgo in DB"
+            , AP.sshPublicKeyMaterial  = sshKeyContent key
+            }
+    provideHtmlAndAP keyAP $ redirectToPrettyJSON here
+
+getPersonMessageR
+    :: KeyHashid Person -> KeyHashid LocalMessage -> Handler TypedContent
+getPersonMessageR personHash localMessageHash = do
+    personID <- decodeKeyHashid404 personHash
+    localMessageID <- decodeKeyHashid404 localMessageHash
+
+    encodeRouteHome <- getEncodeRouteHome
+    workItemRoute <- askWorkItemRoute
+    note <- runDB $ do
+        _ <- get404 personID
+        localMessage <- get404 localMessageID
+        unless (localMessageAuthor localMessage == personID) notFound
+        message <- getJust $ localMessageRest localMessage
+
+        uContext <- do
+            let discussionID = messageRoot message
+            topic <-
+                requireEitherAlt
+                    (getKeyBy $ UniqueTicketDiscuss discussionID)
+                    (getValBy $ UniqueRemoteDiscussion discussionID)
+                    "Neither T nor RD found"
+                    "Both T and RD found"
+            case topic of
+                Left ticketID ->
+                    encodeRouteHome . workItemRoute <$> getWorkItem ticketID
+                Right rd -> do
+                    ro <- getJust $ remoteDiscussionIdent rd
+                    i <- getJust $ remoteObjectInstance ro
+                    return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
+
+        muParent <- for (messageParent message) $ \ parentID -> do
+            parent <-
+                requireEitherAlt
+                    (getBy $ UniqueLocalMessage parentID)
+                    (getValBy $ UniqueRemoteMessage parentID)
+                    "Message with no author"
+                    "Message used as both local and remote"
+            case parent of
+                Left (Entity localParentID localParent) -> do
+                    authorHash <-
+                        encodeKeyHashid $ localMessageAuthor localParent
+                    localParentHash <- encodeKeyHashid localParentID
+                    return $ encodeRouteHome $
+                        PersonMessageR authorHash localParentHash
+                Right remoteParent -> do
+                    rs <- getJust $ remoteMessageAuthor remoteParent
+                    ro <- getJust $ remoteActorIdent rs
+                    i <- getJust $ remoteObjectInstance ro
+                    return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
+
+        encodeRouteLocal <- getEncodeRouteLocal
+        return AP.Note
+            { AP.noteId        = Just $ encodeRouteLocal here
+            , AP.noteAttrib    = encodeRouteLocal $ PersonR personHash
+            , AP.noteAudience  = AP.Audience [] [] [] [] [] []
+            , AP.noteReplyTo   = Just $ fromMaybe uContext muParent
+            , AP.noteContext   = Just uContext
+            , AP.notePublished = Just $ messageCreated message
+            , AP.noteSource    = messageSource message
+            , AP.noteContent   = messageContent message
+            }
+    provideHtmlAndAP note $ redirectToPrettyJSON here
+    where
+    here = PersonMessageR personHash localMessageHash
+
+postPersonFollowR :: KeyHashid Person -> Handler ()
+postPersonFollowR _ = error "Temporarily disabled"
+
+postPersonUnfollowR :: KeyHashid Person -> Handler ()
+postPersonUnfollowR _ = error "Temporarily disabled"

src/Vervis/Handler/Repo.hs

@@ -15,42 +15,67 @@
  -}
 
 module Vervis.Handler.Repo
-    ( getReposR
+    ( getRepoR
-    , postReposR
+    , getRepoInboxR
-    , getRepoNewR
+    , postRepoInboxR
-    , getRepoR
+    , getRepoOutboxR
-    , putRepoR
+    , getRepoOutboxItemR
-    , deleteRepoR
+    , getRepoFollowersR
-    , postRepoR
+
-    , getRepoEditR
+    , getDarcsDownloadR
+    , getGitRefDiscoverR
+    , postGitUploadRequestR
+
     , getRepoSourceR
-    , getRepoHeadChangesR
+    , getRepoBranchSourceR
-    , getRepoBranchR
+    , getRepoCommitsR
-    , getRepoChangesR
+    , getRepoBranchCommitsR
     , getRepoCommitR
+
+    , getRepoNewR
+    , postRepoNewR
+    , postRepoDeleteR
+    , getRepoEditR
+    , postRepoEditR
+    , postRepoFollowR
+    , postRepoUnfollowR
+
+    , postPostReceiveR
+
+
+
+
+
+
+    {-
+    , getReposR
+    , putRepoR
+    , postRepoR
+    , getRepoBranchR
     , getRepoDevsR
     , postRepoDevsR
     , getRepoDevNewR
     , getRepoDevR
     , deleteRepoDevR
     , postRepoDevR
-    , getDarcsDownloadR
     , getRepoTeamR
-    , getRepoFollowersR
 
     , getHighlightStyleR
-    , postPostReceiveR
+    -}
     )
 where
 
 import Control.Exception hiding (Handler)
+import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger (logWarn)
 import Control.Monad.Trans.Except
 import Data.Bifunctor
+import Data.Binary.Put
 import Data.Foldable
 import Data.Git.Graph
 import Data.Git.Harder
+import Data.Git.Harder.Pack
 import Data.Git.Named (RefName (..))
 import Data.Git.Ref (toHex)
 import Data.Git.Repository
@@ -60,6 +85,8 @@ import Data.Git.Types (Blob (..), Person (..), entName)
 import Data.Graph.Inductive.Graph (noNodes)
 import Data.Graph.Inductive.Query.Topsort
 import Data.List (inits)
+import Data.Maybe
+import Data.String
 import Data.Text (Text, unpack)
 import Data.Text.Encoding
 import Data.Text.Encoding.Error (lenientDecode)
@@ -69,19 +96,28 @@ import Database.Persist
 import Database.Persist.Sql
 import Data.Hourglass (timeConvert)
 import Formatting (sformat, stext, (%))
+import Network.Git.Transport.HTTP.Fetch.RefDiscovery
+import Network.Git.Transport.HTTP.Fetch.UploadRequest
+import Network.Git.Types
+import Network.Wai (strictRequestBody)
 import System.Directory
+import System.FilePath
 import System.Hourglass (dateCurrent)
+import System.IO
+import System.Process
 import Text.Blaze.Html (Html)
 import Text.Pandoc.Highlighting
 import Yesod.Auth (requireAuthId)
-import Yesod.Core
+import Yesod.Core hiding (joinPath)
 import Yesod.Core.Content
 import Yesod.Core.Handler (lookupPostParam, redirect, notFound)
 import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core
 
-import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Internal as BLI
 import qualified Data.CaseInsensitive as CI (foldedCase)
 import qualified Data.DList as D
 import qualified Data.Set as S (member)
@@ -91,8 +127,8 @@ import qualified Database.Esqueleto as E
 
 import Data.MediaType
 import Database.Persist.JSON
+import Development.PatchMediaType
 import Network.FedURI
-import Web.ActivityPub hiding (Repo (..), Project)
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@@ -111,38 +147,220 @@ import Yesod.Persist.Local
 import qualified Data.Git.Local as G (createRepo)
 import qualified Darcs.Local.Repository as D (createRepo)
 
+import Vervis.Actor
 import Vervis.API
-import Vervis.Form.Repo
 import Vervis.Foundation
-import Vervis.Handler.Repo.Darcs
-import Vervis.Handler.Repo.Git
 import Vervis.Path
-import Vervis.Model hiding (Actor (..))
+import Vervis.Model
 import Vervis.Model.Ident
-import Development.PatchMediaType
 import Vervis.Paginate
 import Vervis.Readme
 import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
-import Vervis.Widget.Repo
-import Vervis.Widget.Sharer
 
 import qualified Vervis.Formatting as F
 import qualified Vervis.Hook as H
 
-getReposR :: ShrIdent -> Handler Html
+getRepoR :: KeyHashid Repo -> Handler TypedContent
-getReposR user = do
+getRepoR repoHash = do
-    repos <- runDB $ E.select $ E.from $ \ (sharer, repo) -> do
+    repoID <- decodeKeyHashid404 repoHash
-        E.where_ $
+    (repo, actor) <- runDB $ do
-            sharer E.^. SharerIdent E.==. E.val user E.&&.
+        r <- get404 repoID
-            sharer E.^. SharerId E.==. repo E.^. RepoSharer
+        (r,) <$> getJust (repoActor r)
-        E.orderBy [E.asc $ repo E.^. RepoIdent]
-        return $ repo E.^. RepoIdent
-    defaultLayout $(widgetFile "repo/list")
 
-postReposR :: ShrIdent -> Handler Html
+    encodeRouteLocal <- getEncodeRouteLocal
-postReposR user = do
+    let repoAP = AP.Repo
+            { AP.repoActor = AP.Actor
+                { AP.actorLocal = AP.ActorLocal
+                    { AP.actorId         = encodeRouteLocal $ RepoR repoHash
+                    , AP.actorInbox      = encodeRouteLocal $ RepoInboxR repoHash
+                    , AP.actorOutbox     =
+                        Just $ encodeRouteLocal $ RepoOutboxR repoHash
+                    , AP.actorFollowers  =
+                        Just $ encodeRouteLocal $ RepoFollowersR repoHash
+                    , AP.actorFollowing  = Nothing
+                    , AP.actorPublicKeys =
+                        [ Left $ encodeRouteLocal ActorKey1R
+                        , Left $ encodeRouteLocal ActorKey2R
+                        ]
+                    , AP.actorSshKeys    = []
+                    }
+                , AP.actorDetail = AP.ActorDetail
+                    { AP.actorType       = AP.ActorTypeRepo
+                    , AP.actorUsername   = Nothing
+                    , AP.actorName       = Just $ actorName actor
+                    , AP.actorSummary    = Just $ actorDesc actor
+                    }
+                }
+            , AP.repoTeam = Nothing
+            , AP.repoVcs  = repoVcs repo
+            }
+
+        next =
+            case repoVcs repo of
+                VCSDarcs -> RepoSourceR repoHash
+                VCSGit -> RepoBranchSourceR repoHash $ repoMainBranch repo
+    provideHtmlAndAP repoAP $ redirect $ next []
+
+getRepoInboxR :: KeyHashid Repo -> Handler TypedContent
+getRepoInboxR = getInbox RepoInboxR repoActor
+
+postRepoInboxR :: KeyHashid Repo -> Handler TypedContent
+postRepoInboxR _ = error "Temporarily disabled"
+
+getRepoOutboxR :: KeyHashid Repo -> Handler TypedContent
+getRepoOutboxR = getOutbox RepoOutboxR repoActor
+
+getRepoOutboxItemR
+    :: KeyHashid Repo -> KeyHashid OutboxItem -> Handler TypedContent
+getRepoOutboxItemR = getOutboxItem RepoOutboxItemR repoActor
+
+getRepoFollowersR :: KeyHashid Repo -> Handler TypedContent
+getRepoFollowersR = getActorFollowersCollection RepoFollowersR repoActor
+
+getDarcsDownloadR :: KeyHashid Repo -> [Text] -> Handler TypedContent
+getDarcsDownloadR repoHash dir = do
+    repoPath <- askRepoDir repoHash
+    let filePath = repoPath </> "_darcs" </> joinPath (map T.unpack dir)
+    exists <- liftIO $ doesFileExist filePath
+    if exists
+        then sendFile typeOctet filePath
+        else notFound
+
+getGitRefDiscoverR :: KeyHashid Repo -> Handler TypedContent
+getGitRefDiscoverR repoHash = do
+    let typ = "application/x-git-upload-pack-advertisement"
+    path <- askRepoDir repoHash
+    let pathG = fromString path
+    seemsThere <- liftIO $ isRepo pathG
+    if seemsThere
+        then do
+            rq <- getRequest
+            case reqGetParams rq of
+                [("service", serv)] ->
+                    if serv == "git-upload-pack"
+                        then do
+                            let settings =
+                                    ( proc "git"
+                                        [ "upload-pack"
+                                        , "--stateless-rpc"
+                                        , "--advertise-refs"
+                                        , path
+                                        ]
+                                    )
+                                    { std_out = CreatePipe
+                                    }
+                            (_, mh, _, _) <-
+                                liftIO $ createProcess settings
+                            let h = fromJust mh
+                            refs <- liftIO $ B.hGetContents h
+                            let content = runPut $ do
+                                    putService UploadPack
+                                    putByteString refs
+                            setHeader "Cache-Control" "no-cache"
+                            return $ TypedContent typ $ toContent content
+                        else permissionDenied "Service not supported"
+                _ -> notFound
+        else notFound
+
+postGitUploadRequestR :: KeyHashid Repo -> Handler TypedContent
+postGitUploadRequestR repoHash = do
+    let typ = "application/x-git-upload-pack-result"
+    path <- askRepoDir repoHash
+    let pathG = fromString path
+    seemsThere <- liftIO $ isRepo pathG
+    if seemsThere
+        then do
+            getBody <- strictRequestBody <$> waiRequest
+            body <- liftIO getBody
+            let settings =
+                    ( proc "git"
+                        [ "upload-pack"
+                        , "--stateless-rpc"
+                        , path
+                        ]
+                    )
+                    { std_in  = CreatePipe
+                    , std_out = CreatePipe
+                    }
+            (mhin, mhout, _, _) <- liftIO $ createProcess settings
+            let hin = fromJust mhin
+                hout = fromJust mhout
+            liftIO $ BL.hPut hin body >> hClose hin
+            setHeader "Cache-Control" "no-cache"
+            let loop = do
+                    b <- liftIO $ B.hGet hout BLI.defaultChunkSize
+                    unless (B.null b) $ do
+                        sendChunkBS b
+                        loop
+            respondSource typ loop
+        else notFound
+
+getRepoSourceR :: KeyHashid Repo -> [Text] -> Handler Html
+getRepoSourceR repoHash path = do
+    repoID <- decodeKeyHashid404 repoHash
+    repo <- runDB $ get404 repoID
+    case repoVcs repo of
+        VCSDarcs -> error "Temporarily disabled"
+            --getDarcsRepoSource repo repoHash path
+        VCSGit -> notFound
+
+getRepoBranchSourceR :: KeyHashid Repo -> Text -> [Text] -> Handler Html
+getRepoBranchSourceR repoHash branch path = do
+    repoID <- decodeKeyHashid404 repoHash
+    repo <- runDB $ get404 repoID
+    case repoVcs repo of
+        VCSDarcs -> notFound
+        VCSGit -> error "Temporarily disabled"
+            --getGitRepoSource repo repoHash branch dir
+
+getRepoCommitsR :: KeyHashid Repo -> Handler TypedContent
+getRepoCommitsR repoHash = do
+    repoID <- decodeKeyHashid404 repoHash
+    repo <- runDB $ get404 repoID
+    case repoVcs repo of
+        VCSDarcs ->
+            error "Temporarily disabled"
+            --getDarcsRepoHeadChanges repoHash
+        VCSGit ->
+            error "Temporarily disabled"
+            --getGitRepoHeadChanges repo repoHash
+
+getRepoBranchCommitsR :: KeyHashid Repo -> Text -> Handler TypedContent
+getRepoBranchCommitsR repoHash branch = do
+    repoID <- decodeKeyHashid404 repoHash
+    repo <- runDB $ get404 repoID
+    case repoVcs repo of
+        VCSDarcs ->
+            error "Temporarily disabled"
+            --getDarcsRepoChanges repoHash branch
+        VCSGit ->
+            error "Temporarily disabled"
+            --getGitRepoChanges repoHash branch
+
+getRepoCommitR :: KeyHashid Repo -> Text -> Handler TypedContent
+getRepoCommitR repoHash ref = do
+    error "Temporarily disabled"
+    {-
+    repoID <- decodeKeyHashid404 repoHash
+    repo <- runDB $ get404 repoID
+    case repoVcs repo of
+        VCSDarcs -> getDarcsPatch repoHash ref
+        VCSGit -> getGitPatch repoHash ref
+    -}
+
+getRepoNewR :: Handler Html
+getRepoNewR = do
+    error "Temporarily disabled"
+    --Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
+    --((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
+    --defaultLayout $(widgetFile "repo/new")
+
+postRepoNewR :: Handler Html
+postRepoNewR = do
+    error "Temporarily disabled"
+    {-
     Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
     ((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
     case result of
@@ -213,63 +431,46 @@ postReposR user = do
         FormFailure _l -> do
             setMessage "Repo creation failed, see errors below"
             defaultLayout $(widgetFile "repo/new")
+    -}
 
-getRepoNewR :: ShrIdent -> Handler Html
+postRepoDeleteR :: KeyHashid Repo -> Handler Html
-getRepoNewR user = do
+postRepoDeleteR repoHash = do
-    Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
+    error "Temporarily disabled"
-    ((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
+    {-
-    defaultLayout $(widgetFile "repo/new")
+    runDB $ do
+        Entity sid _s <- getBy404 $ UniqueSharer shar
+        Entity rid _r <- getBy404 $ UniqueRepo repo sid
+        delete rid
+    path <- askRepoDir shar repo
+    exists <- liftIO $ doesDirectoryExist path
+    if exists
+        then liftIO $ removeDirectoryRecursive path
+        else
+            $logWarn $ sformat
+                ( "Deleted repo " % F.sharer % "/" % F.repo
+                % " from DB but repo dir doesn't exist"
+                )
+                shar repo
+    setMessage "Repo deleted."
+    redirect HomeR
+    -}
 
-selectRepo :: ShrIdent -> RpIdent -> AppDB (Maybe (Sharer, Project, Workflow, Sharer), Repo)
+getRepoEditR :: KeyHashid Repo -> Handler Html
-selectRepo shar repo = do
+getRepoEditR repoHash = do
-    Entity sid _s <- getBy404 $ UniqueSharer shar
+    error "Temporarily disabled"
-    Entity _rid r <- getBy404 $ UniqueRepo repo sid
+    {-
-    mj <- for (repoProject r) $ \ jid -> do
+    (sid, er) <- runDB $ do
-        j <- get404 jid
+        Entity sid _ <- getBy404 $ UniqueSharer shr
-        s <- get404 $ projectSharer j
+        er <- getBy404 $ UniqueRepo rp sid
-        w <- get404 $ projectWorkflow j
+        return (sid, er)
-        sw <- get404 $ workflowSharer w
+    ((_result, widget), enctype) <- runFormPost $ editRepoForm sid er
-        return (s, j, w, sw)
+    defaultLayout $(widgetFile "repo/edit")
-    return (mj, r)
+    -}
 
-getRepoR :: ShrIdent -> RpIdent -> Handler TypedContent
+postRepoEditR :: KeyHashid Repo -> Handler Html
-getRepoR shr rp = do
+postRepoEditR repoHash = do
-    (_, repo) <- runDB $ selectRepo shr rp
+    error "Temporarily disabled"
-    encodeRouteLocal <- getEncodeRouteLocal
+    {-
-    encodeRouteHome <- getEncodeRouteHome
-    let repoAP = AP.Repo
-            { AP.repoActor = Actor
-                { actorLocal = ActorLocal
-                    { actorId         = encodeRouteLocal $ RepoR shr rp
-                    , actorInbox      = encodeRouteLocal $ RepoInboxR shr rp
-                    , actorOutbox     =
-                        Just $ encodeRouteLocal $ RepoOutboxR shr rp
-                    , actorFollowers  =
-                        Just $ encodeRouteLocal $ RepoFollowersR shr rp
-                    , actorFollowing  = Nothing
-                    , actorPublicKeys =
-                        [ Left $ encodeRouteLocal ActorKey1R
-                        , Left $ encodeRouteLocal ActorKey2R
-                        ]
-                    , actorSshKeys    = []
-                    }
-                , actorDetail = ActorDetail
-                    { actorType       = ActorTypeRepo
-                    , actorUsername   = Nothing
-                    , actorName       = Just $ rp2text rp
-                    , actorSummary    = repoDesc repo
-                    }
-                }
-            , AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
-            , AP.repoVcs  = repoVcs repo
-            }
-        dir = case repoVcs repo of
-                VCSDarcs -> []
-                VCSGit -> [repoMainBranch repo]
-    provideHtmlAndAP repoAP $ redirect $ RepoSourceR shr rp dir
-
-putRepoR :: ShrIdent -> RpIdent -> Handler Html
-putRepoR shr rp = do
     mer <- runDB $ do
         Entity sid _ <- getBy404 $ UniqueSharer shr
         er@(Entity rid r) <- getBy404 $ UniqueRepo rp sid
@@ -296,58 +497,184 @@ putRepoR shr rp = do
                 FormFailure _l -> do
                     setMessage "Repository update failed, see errors below."
                     defaultLayout $(widgetFile "repo/edit")
+    -}
 
-deleteRepoR :: ShrIdent -> RpIdent -> Handler Html
+postRepoFollowR :: KeyHashid Repo -> Handler ()
-deleteRepoR shar repo = do
+postRepoFollowR _ = error "Temporarily disabled"
-    runDB $ do
-        Entity sid _s <- getBy404 $ UniqueSharer shar
-        Entity rid _r <- getBy404 $ UniqueRepo repo sid
-        delete rid
-    path <- askRepoDir shar repo
-    exists <- liftIO $ doesDirectoryExist path
-    if exists
-        then liftIO $ removeDirectoryRecursive path
-        else
-            $logWarn $ sformat
-                ( "Deleted repo " % F.sharer % "/" % F.repo
-                % " from DB but repo dir doesn't exist"
-                )
-                shar repo
-    setMessage "Repo deleted."
-    redirect HomeR
 
-postRepoR :: ShrIdent -> RpIdent -> Handler Html
+postRepoUnfollowR :: KeyHashid Repo -> Handler ()
-postRepoR shar repo = do
+postRepoUnfollowR _ = error "Temporarily disabled"
-    mmethod <- lookupPostParam "_method"
-    case mmethod of
-        Just "PUT"    -> putRepoR shar repo
-        Just "DELETE" -> deleteRepoR shar repo
-        _             -> notFound
 
-getRepoEditR :: ShrIdent -> RpIdent -> Handler Html
+postPostReceiveR :: Handler Text
-getRepoEditR shr rp = do
+postPostReceiveR = do
-    (sid, er) <- runDB $ do
+    error "Temporarily disabled"
-        Entity sid _ <- getBy404 $ UniqueSharer shr
+    {-
-        er <- getBy404 $ UniqueRepo rp sid
+    push <- requireCheckJsonBody
-        return (sid, er)
+    (pushAP, shr, rp) <- push2ap push
-    ((_result, widget), enctype) <- runFormPost $ editRepoForm sid er
+    user <- runDB $ do
-    defaultLayout $(widgetFile "repo/edit")
+        p <- getJustEntity $ toSqlKey $ H.pushUser push
+        s <- getJust $ personIdent $ entityVal p
+        return (p, s)
+    let shrUser = sharerIdent $ snd user
+    summary <- do
+        let mbranch = H.pushBranch push
+            total = pushCommitsTotal pushAP
+            lasts = pushCommitsLast pushAP
+            rest firsts = total - length firsts - length lasts
+            hashText (Hash b) = decodeUtf8 b
+            commitW c =
+                [hamlet|
+                    <a href=@{RepoCommitR shr rp $ hashText $ commitHash c}>
+                      #{commitTitle c}
+                |]
+        withUrlRenderer
+            [hamlet|
+                <p>
+                  <a href=@{SharerR shrUser}>#{shr2text shrUser}
+                  \ pushed #{total} #
+                  \ #{commitsText mbranch total} to repo #
+                  <a href=@{RepoR shr rp}>#{rp2text rp}</a>^{branchText shr rp mbranch}:
+                <ul>
+                  $maybe firsts <- pushCommitsFirst pushAP
+                    $forall c <- firsts
+                      <li>^{commitW c}
+                    <li>#{rest firsts}
+                  $forall c <- lasts
+                    <li>^{commitW c}
+            |]
+    eid <- runExceptT $ pushCommitsC user summary pushAP shr rp
+    case eid of
+        Left e -> liftIO $ throwIO $ userError $ T.unpack e
+        Right obiid -> do
+            renderUrl <- askUrlRender
+            obikhid <- encodeKeyHashid obiid
+            return $
+                "Push activity published: " <>
+                renderUrl (SharerOutboxItemR shrUser obikhid)
+    where
+    push2ap (H.Push secret _ sharer repo mbranch mbefore after early mlate) = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        let shr = text2shr sharer
+            rp = text2rp repo
+            commit2ap' = commit2ap shr rp
+        (commitsLast, commitsFirst) <-
+            runDB $ case mlate of
+                Nothing -> (,) <$> traverse commit2ap' early <*> pure Nothing
+                Just (_omitted, late) ->
+                    (,) <$> traverse commit2ap' late
+                        <*> (Just <$> traverse commit2ap' early)
+        return
+            ( Push
+                { pushCommitsLast  = commitsLast
+                , pushCommitsFirst = commitsFirst
+                , pushCommitsTotal =
+                    case mlate of
+                        Nothing -> length early
+                        Just (omitted, late) ->
+                            length early + omitted + length late
+                , pushTarget       =
+                    encodeRouteLocal $
+                        case mbranch of
+                            Nothing -> RepoR shr rp
+                            Just b -> RepoBranchR shr rp b
+                , pushContext      = encodeRouteLocal $ RepoR shr rp
+                , pushHashBefore   = mbefore
+                , pushHashAfter    = after
+                }
+            , shr
+            , rp
+            )
+        where
+        commit2ap shr rp (H.Commit (wauthor, wtime) mcommitted hash title desc) = do
+            encodeRouteLocal <- getEncodeRouteLocal
+            encodeRouteHome <- getEncodeRouteHome
+            author <- authorByEmail wauthor
+            mcommitter <- traverse (authorByEmail . fst) mcommitted
+            return Commit
+                { commitId          = encodeRouteLocal $ RepoCommitR shr rp hash
+                , commitRepository  = encodeRouteLocal $ RepoR shr rp
+                , commitAuthor      = second (encodeRouteHome . SharerR) author
+                , commitCommitter   =
+                    second (encodeRouteHome . SharerR) <$> mcommitter
+                , commitTitle       = title
+                , commitHash        = Hash $ encodeUtf8 hash
+                , commitDescription =
+                    if T.null desc
+                        then Nothing
+                        else Just desc
+                , commitWritten     = wtime
+                , commitCommitted   = snd <$> mcommitted
+                }
+            where
+            authorByEmail (H.Author name email) = do
+                mperson <- getValBy $ UniquePersonEmail email
+                case mperson of
+                    Nothing -> return $ Left $ Author name email
+                    Just person ->
+                        Right . sharerIdent <$> getJust (personIdent person)
+    commitsText :: Maybe a -> Int -> Text
+    commitsText Nothing n =
+        if n > 1
+            then "patches"
+            else "patch"
+    commitsText (Just _) n =
+        if n > 1
+            then "commits"
+            else "commit"
+    --branchText :: ShrIdent -> RpIdent -> Maybe Text -> HtmlUrl (Route App)
+    branchText _   _  Nothing       = const mempty
+    branchText shr rp (Just branch) =
+        [hamlet|
+            , branch #
+            <a href=@{RepoBranchR shr rp branch}>#{branch}
+        |]
+    -}
 
-getRepoSourceR :: ShrIdent -> RpIdent -> [Text] -> Handler Html
-getRepoSourceR shar repo refdir = do
-    repository <- runDB $ selectRepo shar repo
-    case repoVcs $ snd repository of
-        VCSDarcs -> getDarcsRepoSource repository shar repo refdir
-        VCSGit -> case refdir of
-            []           -> notFound
-            (ref:dir) -> getGitRepoSource repository shar repo ref dir
 
-getRepoHeadChangesR :: ShrIdent -> RpIdent -> Handler TypedContent
+
-getRepoHeadChangesR user repo = do
+
-    (_, repository) <- runDB $ selectRepo user repo
+
-    case repoVcs repository of
+
-        VCSDarcs -> getDarcsRepoHeadChanges user repo
+
-        VCSGit -> getGitRepoHeadChanges repository user repo
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-
+getReposR :: ShrIdent -> Handler Html
+getReposR user = do
+    repos <- runDB $ E.select $ E.from $ \ (sharer, repo) -> do
+        E.where_ $
+            sharer E.^. SharerIdent E.==. E.val user E.&&.
+            sharer E.^. SharerId E.==. repo E.^. RepoSharer
+        E.orderBy [E.asc $ repo E.^. RepoIdent]
+        return $ repo E.^. RepoIdent
+    defaultLayout $(widgetFile "repo/list")
+
+selectRepo :: ShrIdent -> RpIdent -> AppDB (Maybe (Sharer, Project, Workflow, Sharer), Repo)
+selectRepo shar repo = do
+    Entity sid _s <- getBy404 $ UniqueSharer shar
+    Entity _rid r <- getBy404 $ UniqueRepo repo sid
+    mj <- for (repoProject r) $ \ jid -> do
+        j <- get404 jid
+        s <- get404 $ projectSharer j
+        w <- get404 $ projectWorkflow j
+        sw <- get404 $ workflowSharer w
+        return (s, j, w, sw)
+    return (mj, r)
 
 getRepoBranchR :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getRepoBranchR shar repo ref = do
@@ -356,20 +683,6 @@ getRepoBranchR shar repo ref = do
         VCSDarcs -> notFound
         VCSGit -> getGitRepoBranch shar repo ref
 
-getRepoChangesR :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
-getRepoChangesR shar repo ref = do
-    (_, repository) <- runDB $ selectRepo shar repo
-    case repoVcs repository of
-        VCSDarcs -> getDarcsRepoChanges shar repo ref
-        VCSGit -> getGitRepoChanges shar repo ref
-
-getRepoCommitR :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
-getRepoCommitR shr rp ref = do
-    (_, repository) <- runDB $ selectRepo shr rp
-    case repoVcs repository of
-        VCSDarcs -> getDarcsPatch shr rp ref
-        VCSGit -> getGitPatch shr rp ref
-
 getRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
 getRepoDevsR shr rp = do
     devs <- runDB $ do
@@ -551,125 +864,4 @@ getHighlightStyleR styleName =
         Nothing -> notFound
         Just style ->
             return $ TypedContent typeCss $ toContent $ styleToCss style
-
+-}
-postPostReceiveR :: Handler Text
-postPostReceiveR = do
-    push <- requireCheckJsonBody
-    (pushAP, shr, rp) <- push2ap push
-    user <- runDB $ do
-        p <- getJustEntity $ toSqlKey $ H.pushUser push
-        s <- getJust $ personIdent $ entityVal p
-        return (p, s)
-    let shrUser = sharerIdent $ snd user
-    summary <- do
-        let mbranch = H.pushBranch push
-            total = pushCommitsTotal pushAP
-            lasts = pushCommitsLast pushAP
-            rest firsts = total - length firsts - length lasts
-            hashText (Hash b) = decodeUtf8 b
-            commitW c =
-                [hamlet|
-                    <a href=@{RepoCommitR shr rp $ hashText $ commitHash c}>
-                      #{commitTitle c}
-                |]
-        withUrlRenderer
-            [hamlet|
-                <p>
-                  <a href=@{SharerR shrUser}>#{shr2text shrUser}
-                  \ pushed #{total} #
-                  \ #{commitsText mbranch total} to repo #
-                  <a href=@{RepoR shr rp}>#{rp2text rp}</a>^{branchText shr rp mbranch}:
-                <ul>
-                  $maybe firsts <- pushCommitsFirst pushAP
-                    $forall c <- firsts
-                      <li>^{commitW c}
-                    <li>#{rest firsts}
-                  $forall c <- lasts
-                    <li>^{commitW c}
-            |]
-    eid <- runExceptT $ pushCommitsC user summary pushAP shr rp
-    case eid of
-        Left e -> liftIO $ throwIO $ userError $ T.unpack e
-        Right obiid -> do
-            renderUrl <- askUrlRender
-            obikhid <- encodeKeyHashid obiid
-            return $
-                "Push activity published: " <>
-                renderUrl (SharerOutboxItemR shrUser obikhid)
-    where
-    push2ap (H.Push secret _ sharer repo mbranch mbefore after early mlate) = do
-        encodeRouteLocal <- getEncodeRouteLocal
-        let shr = text2shr sharer
-            rp = text2rp repo
-            commit2ap' = commit2ap shr rp
-        (commitsLast, commitsFirst) <-
-            runDB $ case mlate of
-                Nothing -> (,) <$> traverse commit2ap' early <*> pure Nothing
-                Just (_omitted, late) ->
-                    (,) <$> traverse commit2ap' late
-                        <*> (Just <$> traverse commit2ap' early)
-        return
-            ( Push
-                { pushCommitsLast  = commitsLast
-                , pushCommitsFirst = commitsFirst
-                , pushCommitsTotal =
-                    case mlate of
-                        Nothing -> length early
-                        Just (omitted, late) ->
-                            length early + omitted + length late
-                , pushTarget       =
-                    encodeRouteLocal $
-                        case mbranch of
-                            Nothing -> RepoR shr rp
-                            Just b -> RepoBranchR shr rp b
-                , pushContext      = encodeRouteLocal $ RepoR shr rp
-                , pushHashBefore   = mbefore
-                , pushHashAfter    = after
-                }
-            , shr
-            , rp
-            )
-        where
-        commit2ap shr rp (H.Commit (wauthor, wtime) mcommitted hash title desc) = do
-            encodeRouteLocal <- getEncodeRouteLocal
-            encodeRouteHome <- getEncodeRouteHome
-            author <- authorByEmail wauthor
-            mcommitter <- traverse (authorByEmail . fst) mcommitted
-            return Commit
-                { commitId          = encodeRouteLocal $ RepoCommitR shr rp hash
-                , commitRepository  = encodeRouteLocal $ RepoR shr rp
-                , commitAuthor      = second (encodeRouteHome . SharerR) author
-                , commitCommitter   =
-                    second (encodeRouteHome . SharerR) <$> mcommitter
-                , commitTitle       = title
-                , commitHash        = Hash $ encodeUtf8 hash
-                , commitDescription =
-                    if T.null desc
-                        then Nothing
-                        else Just desc
-                , commitWritten     = wtime
-                , commitCommitted   = snd <$> mcommitted
-                }
-            where
-            authorByEmail (H.Author name email) = do
-                mperson <- getValBy $ UniquePersonEmail email
-                case mperson of
-                    Nothing -> return $ Left $ Author name email
-                    Just person ->
-                        Right . sharerIdent <$> getJust (personIdent person)
-    commitsText :: Maybe a -> Int -> Text
-    commitsText Nothing n =
-        if n > 1
-            then "patches"
-            else "patch"
-    commitsText (Just _) n =
-        if n > 1
-            then "commits"
-            else "commit"
-    --branchText :: ShrIdent -> RpIdent -> Maybe Text -> HtmlUrl (Route App)
-    branchText _   _  Nothing       = const mempty
-    branchText shr rp (Just branch) =
-        [hamlet|
-            , branch #
-            <a href=@{RepoBranchR shr rp branch}>#{branch}
-        |]

src/Vervis/Handler/Repo/Darcs.hs

@@ -17,7 +17,6 @@ module Vervis.Handler.Repo.Darcs
     ( getDarcsRepoSource
     , getDarcsRepoHeadChanges
     , getDarcsRepoChanges
-    , getDarcsDownloadR
     , getDarcsPatch
     )
 where
@@ -61,7 +60,6 @@ import Text.FilePath.Local (breakExt)
 import Vervis.ActivityPub
 import Vervis.ChangeFeed (changeFeed)
 import Vervis.Changes
-import Vervis.Form.Repo
 import Vervis.Foundation
 import Vervis.Path
 import Vervis.Model
@@ -73,10 +71,6 @@ import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
 import Vervis.Time
-import Vervis.Widget (buttonW)
-import Vervis.Widget.Project
-import Vervis.Widget.Repo
-import Vervis.Widget.Sharer
 
 import qualified Vervis.Darcs as D (readSourceView, readChangesView, readPatch)
 
@@ -163,16 +157,6 @@ getDarcsRepoHeadChanges shar repo = do
 getDarcsRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getDarcsRepoChanges shar repo tag = notFound
 
-getDarcsDownloadR :: ShrIdent -> RpIdent -> [Text] -> Handler TypedContent
-getDarcsDownloadR shar repo dir = do
-    path <- askRepoDir shar repo
-    let darcsDir = path </> "_darcs"
-        filePath = darcsDir </> joinPath (map T.unpack dir)
-    exists <- liftIO $ doesFileExist filePath
-    if exists
-        then sendFile typeOctet filePath
-        else notFound
-
 getDarcsPatch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
 getDarcsPatch shr rp ref = do
     path <- askRepoDir shr rp

src/Vervis/Handler/Repo/Git.hs

@@ -75,7 +75,6 @@ import Text.FilePath.Local (breakExt)
 import Vervis.ActivityPub
 import Vervis.ChangeFeed (changeFeed)
 import Vervis.Changes
-import Vervis.Form.Repo
 import Vervis.Foundation
 import Vervis.Path
 import Vervis.Model
@@ -87,10 +86,6 @@ import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
 import Vervis.Time (showDate)
-import Vervis.Widget (buttonW)
-import Vervis.Widget.Project
-import Vervis.Widget.Repo
-import Vervis.Widget.Sharer
 
 import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs, readPatch)

src/Vervis/Handler/Sharer.hs

@@ -15,7 +15,6 @@
 
 module Vervis.Handler.Sharer
     ( getSharersR
-    , getSharerR
     , getSharerFollowersR
     , getSharerFollowingR
     )
@@ -65,22 +64,6 @@ getSharersR = do
     let pageNav = navWidget navModel
     defaultLayout $(widgetFile "sharer/list")
 
-getSharerR :: ShrIdent -> Handler TypedContent
-getSharerR shr = do
-    ment <- runDB $ do
-        Entity sid sharer <- getBy404 $ UniqueSharer shr
-        runMaybeT . fmap (sharer,)
-            $   Left  <$> MaybeT (getBy $ UniquePersonIdent sid)
-            <|> Right <$> MaybeT (getBy $ UniqueGroup sid)
-    case ment of
-        Nothing -> do
-            $logWarn $ "Found non-person non-group sharer: " <> shr2text shr
-            notFound
-        Just (s, ent) ->
-            case ent of
-                Left ep -> getPerson shr s ep
-                Right (Entity _ g) -> getGroup shr g
-
 getSharerFollowersR :: ShrIdent -> Handler TypedContent
 getSharerFollowersR shr = getFollowersCollection here getFsid
     where
@@ -98,84 +81,3 @@ getSharerFollowersR shr = getFollowersCollection here getFsid
                 case val of
                     Left person -> return $ personFollowers person
                     Right _group -> notFound
-
-getSharerFollowingR :: ShrIdent -> Handler TypedContent
-getSharerFollowingR shr = do
-    (localTotal, sharers, projects, tickets, repos, remotes) <- runDB $ do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        pid <- getKeyBy404 $ UniquePersonIdent sid
-        fsids <-
-            map (followTarget . entityVal) <$>
-                selectList [FollowPerson ==. pid] []
-        (,,,,,) (length fsids)
-            <$> getSharers fsids
-            <*> getProjects fsids
-            <*> getTickets fsids
-            <*> getRepos fsids
-            <*> getRemotes pid
-    let locals = sharers ++ projects ++ tickets ++ repos
-    unless (length locals == localTotal) $
-        liftIO $ throwIO $ userError "Bug! List length mismatch"
-
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRouteHome <- getEncodeRouteHome
-    let here = SharerFollowingR shr
-        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
-    getSharers fsids = do
-        sids <-
-            map (personIdent . entityVal) <$>
-                selectList [PersonFollowers <-. fsids] []
-        map (SharerR . sharerIdent . entityVal) <$>
-            selectList [SharerId <-. sids] []
-    getProjects fsids =
-        fmap (map $ \ (E.Value shr, E.Value prj) -> ProjectR shr prj) $
-        E.select $ E.from $ \ (a `E.InnerJoin` j `E.InnerJoin` s) -> do
-            E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId
-            E.on $ a E.^. ActorId E.==. j E.^. ProjectActor
-            E.where_ $ a E.^. ActorFollowers `E.in_` E.valList fsids
-            return (s E.^. SharerIdent, j E.^. ProjectIdent)
-    getTickets fsids = do
-        ltids <- selectKeysList [LocalTicketFollowers <-. fsids] []
-        triples <-
-            E.select $ E.from $
-                \ (lt  `E.InnerJoin`
-                   t   `E.InnerJoin`
-                   tcl `E.InnerJoin`
-                   tpl `E.InnerJoin`
-                   j   `E.InnerJoin`
-                   s) -> do
-                    E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId
-                    E.on $ tpl E.^. TicketProjectLocalProject E.==. j E.^. ProjectId
-                    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_ $ lt E.^. LocalTicketId `E.in_` E.valList ltids
-                    return
-                        ( s E.^. SharerIdent
-                        , j E.^. ProjectIdent
-                        , lt E.^. LocalTicketId
-                        )
-        encodeHid <- getEncodeKeyHashid
-        return $
-            map (\ (E.Value shr, E.Value prj, E.Value tid) -> ProjectTicketR shr prj $ encodeHid tid)
-                triples
-    getRepos fsids = do
-        rids <- selectKeysList [RepoFollowers <-. fsids] []
-        pairs <- E.select $ E.from $ \ (r `E.InnerJoin` s) -> do
-            E.on $ r E.^. RepoSharer E.==. s E.^. SharerId
-            E.where_ $ r E.^. RepoId `E.in_` E.valList rids
-            return (s E.^. SharerIdent, r E.^. RepoIdent)
-        return $ map (\ (E.Value shr, E.Value rp) -> RepoR shr rp) pairs
-    getRemotes pid =
-        map (followRemoteTarget . entityVal) <$>
-            selectList [FollowRemotePerson ==. pid] []

src/Vervis/Handler/Ticket.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020, 2022
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -14,10 +15,25 @@
  -}
 
 module Vervis.Handler.Ticket
-    ( getProjectTicketsR
+    ( getTicketR
+    , getTicketDiscussionR
+    , getTicketEventsR
+    , getTicketFollowersR
+    , getTicketDepsR
+    , getTicketReverseDepsR
+
+    , getTicketDepR
+
+
+
+
+
+
+
+    {-
+    , getProjectTicketsR
     , getProjectTicketTreeR
     , getProjectTicketNewR
-    , getProjectTicketR
     , putProjectTicketR
     , deleteProjectTicketR
     , postProjectTicketR
@@ -33,31 +49,26 @@ module Vervis.Handler.Ticket
     , getClaimRequestsTicketR
     , postClaimRequestsTicketR
     , getClaimRequestNewR
-    , getProjectTicketDiscussionR
     , postProjectTicketDiscussionR
     , getMessageR
     , postProjectTicketMessageR
     , getProjectTicketTopReplyR
     , getProjectTicketReplyR
-    , getProjectTicketDepsR
     , postProjectTicketDepsR
     , getProjectTicketDepNewR
     , postTicketDepOldR
     , deleteTicketDepOldR
-    , getProjectTicketReverseDepsR
-    , getTicketDepR
     , getProjectTicketParticipantsR
     , getProjectTicketTeamR
-    , getProjectTicketEventsR
 
     , getSharerTicketsR
     , getSharerTicketR
     , getSharerTicketDiscussionR
     , getSharerTicketDepsR
     , getSharerTicketReverseDepsR
-    , getSharerTicketFollowersR
     , getSharerTicketTeamR
     , getSharerTicketEventsR
+    -}
     )
 where
 
@@ -120,11 +131,11 @@ import Database.Persist.Local
 import Yesod.Persist.Local
 
 import Vervis.ActivityPub
+import Vervis.Actor
 import Vervis.API
 import Vervis.Discussion
 import Vervis.Federation
 import Vervis.FedURI
-import Vervis.Form.Ticket
 import Vervis.Foundation
 import Vervis.Handler.Discussion
 --import Vervis.GraphProxy (ticketDepGraph)
@@ -138,211 +149,101 @@ import Vervis.Style
 import Vervis.Ticket
 import Vervis.TicketFilter (filterTickets)
 import Vervis.Time (showDate)
-import Vervis.Widget (buttonW)
-import Vervis.Widget.Discussion (discussionW)
-import Vervis.Widget.Sharer
-import Vervis.Widget.Ticket
 
-getProjectTicketsR :: ShrIdent -> PrjIdent -> Handler TypedContent
+getTicketR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
-getProjectTicketsR shr prj = selectRep $ do
+getTicketR deckHash ticketHash = do
-    provideRep $ do
+    (ticket, author, resolve) <- runDB $ do
-        ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
+        (_, _, Entity _ ticket', author', resolve') <-
-        let tf =
+            getTicket404 deckHash ticketHash
-                case filtResult of
+        (,,) ticket'
-                    FormSuccess filt -> filt
+            <$> (case author' of
-                    FormMissing      -> def
+                    Left (Entity _ tal) ->
-                    FormFailure l    ->
+                        return $ Left $ ticketAuthorLocalAuthor tal
-                        error $ "Ticket filter form failed: " ++ show l
+                    Right (Entity _ tar) -> Right <$> do
-        (total, pages, mpage) <- runDB $ do
+                        ra <- getJust $ ticketAuthorRemoteAuthor tar
-            Entity sid _ <- getBy404 $ UniqueSharer shr
+                        ro <- getJust $ remoteActorIdent ra
-            Entity jid _ <- getBy404 $ UniqueProject prj sid
+                        i <- getJust $ remoteObjectInstance ro
-            let countAllTickets = count [TicketProjectLocalProject ==. jid]
+                        return (i, ro)
-                selectTickets off lim =
+                )
-                    getTicketSummaries
+            <*> (for resolve' $ \ (_, etrx) ->
-                        (filterTickets tf)
+                    bitraverse
-                        (Just $ \ t -> [E.asc $ t E.^. TicketId])
+                        (\ (Entity _ trl) -> do
-                        (Just (off, lim))
+                            let obiid = ticketResolveLocalActivity trl
-                        jid
+                            obid <- outboxItemOutbox <$> getJust obiid
-            getPageAndNavCount countAllTickets selectTickets
+                            actorID <- do
-        case mpage of
+                                maybeActorID <- getKeyBy $ UniqueActorOutbox obid
-            Nothing -> redirectFirstPage here
+                                case maybeActorID of
-            Just (rows, navModel) ->
+                                    Nothing -> error "Found outbox not used by any actor"
-                let pageNav = navWidget navModel
+                                    Just a -> return a
-                in  defaultLayout $(widgetFile "ticket/list")
+                            actor <- getLocalActor actorID
-    provideAP' $ do
+                            return (actor, obiid)
-        (total, pages, mpage) <- runDB $ do
+                        )
-            Entity sid _ <- getBy404 $ UniqueSharer shr
+                        (\ (Entity _ trr) -> do
-            Entity jid _ <- getBy404 $ UniqueProject prj sid
+                            roid <-
-            let countAllTickets = count [TicketProjectLocalProject ==. jid]
+                                remoteActivityIdent <$>
-                selectTickets off lim = do
+                                    getJust (ticketResolveRemoteActivity trr)
-                    tids <- E.select $ E.from $ \ (tcl `E.InnerJoin` tpl) -> do
+                            ro <- getJust roid
-                        E.on $ tcl E.^. TicketContextLocalId E.==. tpl E.^. TicketProjectLocalContext
+                            i <- getJust $ remoteObjectInstance ro
-                        E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid
+                            return (i, ro)
-                        E.orderBy [E.desc $ tcl E.^. TicketContextLocalTicket]
+                        )
-                        E.offset $ fromIntegral off
+                        etrx
-                        E.limit $ fromIntegral lim
+                )
-                        return $ tcl E.^. TicketContextLocalTicket
-                    let tids' = map E.unValue tids
-                    locals <- E.select $ E.from $ \ (lt `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s `E.LeftOuterJoin` tup)) -> do
-                        E.on $ tal E.?. TicketAuthorLocalId E.==. tup E.?. TicketUnderProjectAuthor
-                        E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
-                        E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
-                        E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket
-                        E.where_ $ lt E.^. LocalTicketTicket `E.in_` E.valList tids'
-                        E.orderBy [E.desc $ lt E.^. LocalTicketTicket]
-                        return
-                            ( lt E.^. LocalTicketTicket
-                            , ( lt E.^. LocalTicketId
-                              , tal E.?. TicketAuthorLocalId
-                              , s E.?. SharerIdent
-                              , tup E.?. TicketUnderProjectId
-                              )
-                            )
-                    remotes <- E.select $ E.from $ \ (tcl `E.InnerJoin` tar `E.InnerJoin` rt `E.InnerJoin` ro `E.InnerJoin` i) -> do
-                        E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
-                        E.on $ rt E.^. RemoteTicketIdent E.==. ro E.^. RemoteObjectId
-                        E.on $ tar E.^. TicketAuthorRemoteId E.==. rt E.^. RemoteTicketTicket
-                        E.on $ tcl E.^. TicketContextLocalId E.==. tar E.^. TicketAuthorRemoteTicket
-                        E.where_ $ tcl E.^. TicketContextLocalTicket `E.in_` E.valList tids'
-                        E.orderBy [E.desc $ tcl E.^. TicketContextLocalTicket]
-                        return
-                            ( tcl E.^. TicketContextLocalTicket
-                            , ( i E.^. InstanceHost
-                              , ro E.^. RemoteObjectIdent
-                              )
-                            )
-                    return $
-                        map snd $
-                            LO.mergeBy
-                                (flip compare `on` fst)
-                                (map (second Left) locals)
-                                (map (second Right) remotes)
-            getPageAndNavCount countAllTickets selectTickets
 
-        encodeRouteHome <- getEncodeRouteHome
+    encodeRouteLocal <- getEncodeRouteLocal
-        encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
-        encodeRoutePageLocal <- getEncodeRoutePageLocal
+    hashPerson <- getEncodeKeyHashid
-        let pageUrl = encodeRoutePageLocal here
+    hashItem <- getEncodeKeyHashid
-        host <- asksSite siteInstanceHost
+    hLocal <- getsYesod siteInstanceHost
-        encodeLT <- getEncodeKeyHashid
+    let route mk = encodeRouteLocal $ mk deckHash ticketHash
-        encodeTAL <- getEncodeKeyHashid
+        authorHost =
+            case author of
+                Left _       -> hLocal
+                Right (i, _) -> instanceHost i
+        ticketLocalAP = AP.TicketLocal
+            { AP.ticketId           = route TicketR
+            , AP.ticketReplies      = route TicketDiscussionR
+            , AP.ticketParticipants = route TicketFollowersR
+            , AP.ticketTeam         = Nothing
+            , AP.ticketEvents       = route TicketEventsR
+            , AP.ticketDeps         = route TicketDepsR
+            , AP.ticketReverseDeps  = route TicketReverseDepsR
+            }
+        ticketAP = AP.Ticket
+            { AP.ticketLocal        = Just (hLocal, ticketLocalAP)
+            , AP.ticketAttributedTo =
+                case author of
+                    Left authorID ->
+                        encodeRouteLocal $ PersonR $ hashPerson authorID
+                    Right (_instance, object) ->
+                        remoteObjectIdent object
+            , AP.ticketPublished    = Just $ ticketCreated ticket
+            , AP.ticketUpdated      = Nothing
+            , AP.ticketContext      = Just $ encodeRouteHome $ DeckR deckHash
+            -- , AP.ticketName         = Just $ "#" <> T.pack (show num)
+            , AP.ticketSummary      = TextHtml $ ticketTitle ticket
+            , AP.ticketContent      = TextHtml $ ticketDescription ticket
+            , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
+            , AP.ticketAssignedTo   = Nothing
+            , AP.ticketResolved     =
+                let u (Left (actor, obiid)) =
+                        encodeRouteHome $
+                            outboxItemRoute actor $ hashItem obiid
+                    u (Right (i, ro)) =
+                        ObjURI (instanceHost i) (remoteObjectIdent ro)
+                in  (,Nothing) . Just . u <$> resolve
+            , AP.ticketAttachment = Nothing
+            }
 
-        return $
+    provideHtmlAndAP' authorHost ticketAP $ redirectToPrettyJSON here
-            case mpage of
-                Nothing -> encodeStrict $ Doc host $ Collection
-                    { collectionId         = encodeRouteLocal here
-                    , collectionType       = CollectionTypeOrdered
-                    , collectionTotalItems = Just total
-                    , collectionCurrent    = Nothing
-                    , collectionFirst      = Just $ pageUrl 1
-                    , collectionLast       = Just $ pageUrl pages
-                    , collectionItems      = [] :: [Text]
-                    }
-                Just (tickets, navModel) ->
-                    let current = nmCurrent navModel
-                    in  encodeStrict $ 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 (ticketRoute encodeRouteHome encodeLT encodeTAL)
-                                    tickets
-                            }
     where
-    here = ProjectTicketsR shr prj
+    here = TicketR deckHash ticketHash
-    encodeStrict = BL.toStrict . encode
-    ticketRoute encodeRoute encodeLT encodeTAL (Left (E.Value ltid, E.Value mtalid, E.Value mshr, E.Value mtupid)) =
-        encodeRoute $
-            case (mtalid, mshr, mtupid) of
-                (Nothing, Nothing, Nothing) -> ProjectTicketR shr prj $ encodeLT ltid
-                (Just talid, Just shrA, Nothing) -> SharerTicketR shrA $ encodeTAL talid
-                (Just _, Just _, Just _) -> ProjectTicketR shr prj $ encodeLT ltid
-                _ -> error "Impossible"
-    ticketRoute _ _ _ (Right (E.Value h, E.Value lu)) = ObjURI h lu
 
-getProjectTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
-getProjectTicketTreeR _shr _prj = error "Ticket tree view disabled for now"
     {-
-    (summaries, deps) <- runDB $ do
-        Entity sid _ <- getBy404 $ UniqueSharer shr
-        Entity jid _ <- getBy404 $ UniqueProject prj sid
-        (,) <$> getTicketSummaries Nothing Nothing Nothing jid
-            <*> getTicketDepEdges jid
-    defaultLayout $ ticketTreeDW shr prj summaries deps
-    -}
-
-getProjectTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
-getProjectTicketNewR shr prj = do
-    wid <- runDB $ do
-        Entity sid _ <- getBy404 $ UniqueSharer shr
-        Entity _   j <- getBy404 $ UniqueProject prj sid
-        return $ projectWorkflow j
-    ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
-    defaultLayout $(widgetFile "ticket/new")
-
-getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
-getProjectTicketR shar proj ltkhid = do
     mpid <- maybeAuthId
     ( wshr, wfl,
       author, massignee, mresolved, ticket, lticket, tparams, eparams, cparams) <-
         runDB $ do
             (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etcl, _etpl, author, resolved) <- getProjectTicket404 shar proj ltkhid
-            (wshr, wid, wfl) <- do
-                w <- get404 $ projectWorkflow project
-                wsharer <-
-                    if workflowSharer w == sid
-                        then return sharer
-                        else get404 $ workflowSharer w
-                return
-                    ( sharerIdent wsharer
-                    , projectWorkflow project
-                    , workflowIdent w
-                    )
-            author' <-
-                case author of
-                    Left (Entity _ tal, _) -> Left <$> do
-                        p <- getJust $ ticketAuthorLocalAuthor tal
-                        getJust $ personIdent p
-                    Right (Entity _ tar) -> Right <$> do
-                        ra <- getJust $ ticketAuthorRemoteAuthor tar
-                        ro <- getJust $ remoteActorIdent ra
-                        i <- getJust $ remoteObjectInstance ro
-                        return (i, ro, ra)
-            massignee <- for (ticketAssignee ticket) $ \ apid -> do
-                person <- get404 apid
-                sharer <- get404 $ personIdent person
-                return (sharer, fromMaybe False $ (== apid) <$> mpid)
-            mresolved <- for resolved $ \ (_, etrx) ->
-                bitraverse
-                    (\ (Entity _ trl) -> do
-                        let obiid = ticketResolveLocalActivity trl
-                        obid <- outboxItemOutbox <$> getJust obiid
-                        ent <- getOutboxActorEntity obid
-                        actor <- actorEntityPath ent
-                        return (actor, obiid)
-                    )
-                    (\ (Entity _ trr) -> do
-                        roid <-
-                            remoteActivityIdent <$>
-                                getJust (ticketResolveRemoteActivity trr)
-                        ro <- getJust roid
-                        i <- getJust $ remoteObjectInstance ro
-                        return (i, ro)
-                    )
-                    etrx
             tparams <- getTicketTextParams tid wid
             eparams <- getTicketEnumParams tid wid
             cparams <- getTicketClasses tid wid
@@ -351,7 +252,6 @@ getProjectTicketR shar proj ltkhid = do
                 , author', massignee, mresolved, ticket, lticket
                 , tparams, eparams, cparams
                 )
-    encodeHid <- getEncodeKeyHashid
     let desc :: Widget
         desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
         discuss =
@@ -367,60 +267,6 @@ getProjectTicketR shar proj ltkhid = do
                 TSNew    -> wffNew filt
                 TSTodo   -> wffTodo filt
                 TSClosed -> wffClosed filt
-    hLocal <- getsYesod siteInstanceHost
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRouteHome <- getEncodeRouteHome
-    encodeKeyHashid <- getEncodeKeyHashid
-    let host =
-            case author of
-                Left _          -> hLocal
-                Right (i, _, _) -> instanceHost i
-        ticketAP = AP.Ticket
-            { AP.ticketLocal        = Just
-                ( hLocal
-                , AP.TicketLocal
-                    { AP.ticketId =
-                        encodeRouteLocal $ ProjectTicketR shar proj ltkhid
-                    , AP.ticketReplies =
-                        encodeRouteLocal $ ProjectTicketDiscussionR shar proj ltkhid
-                    , AP.ticketParticipants =
-                        encodeRouteLocal $ ProjectTicketParticipantsR shar proj ltkhid
-                    , AP.ticketTeam =
-                        Just $ encodeRouteLocal $ ProjectTicketTeamR shar proj ltkhid
-                    , AP.ticketEvents =
-                        encodeRouteLocal $ ProjectTicketEventsR shar proj ltkhid
-                    , AP.ticketDeps =
-                        encodeRouteLocal $ ProjectTicketDepsR shar proj ltkhid
-                    , AP.ticketReverseDeps =
-                        encodeRouteLocal $ ProjectTicketReverseDepsR shar proj ltkhid
-                    }
-                )
-
-            , AP.ticketAttributedTo =
-                case author of
-                    Left sharer ->
-                        encodeRouteLocal $ SharerR $ sharerIdent sharer
-                    Right (_inztance, object, _actor) ->
-                        remoteObjectIdent object
-            , AP.ticketPublished    = Just $ ticketCreated ticket
-            , AP.ticketUpdated      = Nothing
-            , AP.ticketContext      =
-                Just $ encodeRouteHome $ ProjectR shar proj
-            -- , AP.ticketName         = Just $ "#" <> T.pack (show num)
-            , AP.ticketSummary      = TextHtml $ ticketTitle ticket
-            , AP.ticketContent      = TextHtml $ ticketDescription ticket
-            , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
-            , AP.ticketAssignedTo   =
-                encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
-            , AP.ticketResolved     =
-                let u (Left (actor, obiid)) =
-                        encodeRouteHome $
-                            outboxItemRoute actor $ encodeKeyHashid obiid
-                    u (Right (i, ro)) =
-                        ObjURI (instanceHost i) (remoteObjectIdent ro)
-                in  (,Nothing) . Just . u <$> mresolved
-            , AP.ticketAttachment   = Nothing
-            }
     provideHtmlAndAP' host ticketAP $
         let followButton =
                 followW
@@ -428,6 +274,174 @@ getProjectTicketR shar proj ltkhid = do
                     (ProjectTicketUnfollowR shar proj ltkhid)
                     (return $ localTicketFollowers lticket)
         in  $(widgetFile "ticket/one")
+    -}
+
+getTicketDiscussionR
+    :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
+getTicketDiscussionR _ _ = do
+    error "Temporarily disabled"
+    {-
+    encodeHid <- getEncodeKeyHashid
+    getDiscussion
+        (ProjectTicketReplyR shar proj ltkhid . encodeHid)
+        (ProjectTicketTopReplyR shar proj ltkhid)
+        (selectDiscussionId shar proj ltkhid)
+    -}
+
+getTicketEventsR
+    :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
+getTicketEventsR _ _ = do
+    error "Not implemented yet"
+
+getTicketFollowersR
+    :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
+getTicketFollowersR deckHash ticketHash = getFollowersCollection here getFsid
+    where
+    here = TicketFollowersR deckHash ticketHash
+    getFsid = do
+        (_, _, Entity _ t, _, _) <- getTicket404 deckHash ticketHash
+        return $ ticketFollowers t
+
+getTicketDepsR
+    :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
+getTicketDepsR deckHash ticketHash =
+    error "Temporarily disabled"
+    {-
+    getDependencyCollection here dep getLocalTicketId404
+    where
+    here = TicketDepsR deckHash ticketHash
+    dep = TicketDepR deckHash ticketHash
+    getLocalTicketId404 = do
+        (_, _, Entity ltid _, _, _, _, _) <- getTicket404 dkhid ltkhid
+        return ltid
+    -}
+
+getTicketReverseDepsR
+    :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
+getTicketReverseDepsR deckHash ticketHash =
+    error "Temporarily disabled"
+    {-
+    getReverseDependencyCollection here getLocalTicketId404
+    where
+    here = TicketReverseDepsR deckhash ticketHash
+    getLocalTicketId404 = do
+        (_, _, _, Entity ltid _, _, _, _, _) <- getTicket404 deckHash ticketHash
+        return ltid
+    -}
+
+getTicketDepR
+    :: KeyHashid Deck
+    -> KeyHashid TicketDeck
+    -> KeyHashid LocalTicketDependency
+    -> Handler TypedContent
+getTicketDepR _ _ _ = do
+    error "Temporarily disabled"
+    {-
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    wiRoute <- askWorkItemRoute
+    hLocal <- asksSite siteInstanceHost
+
+    tdid <- decodeKeyHashid404 tdkhid
+    (td, author, parent, child) <- runDB $ do
+        td <- get404 tdid
+        (td,,,)
+            <$> getAuthor tdid
+            <*> getWorkItem ( localTicketDependencyParent td)
+            <*> getChild tdid
+    let host =
+            case author of
+                Left _ -> hLocal
+                Right (h, _) -> h
+        tdepAP = AP.TicketDependency
+            { ticketDepId           = Just $ encodeRouteHome here
+            , ticketDepParent       = encodeRouteHome $ wiRoute parent
+            , ticketDepChild        =
+                case child of
+                    Left wi -> encodeRouteHome $ wiRoute wi
+                    Right (h, lu) -> ObjURI h lu
+            , ticketDepAttributedTo =
+                case author of
+                    Left shr -> encodeRouteLocal $ SharerR shr
+                    Right (_h, lu) -> lu
+            , ticketDepPublished    = Just $ localTicketDependencyCreated td
+            , ticketDepUpdated      = Nothing
+            }
+    provideHtmlAndAP' host tdepAP $ redirectToPrettyJSON here
+    where
+    here = TicketDepR tdkhid
+    getAuthor tdid = do
+        tda <- requireEitherAlt
+            (getValBy $ UniqueTicketDependencyAuthorLocal tdid)
+            (getValBy $ UniqueTicketDependencyAuthorRemote tdid)
+            "No TDA"
+            "Both TDAL and TDAR"
+        bitraverse
+            (\ tdal -> do
+                p <- getJust $ ticketDependencyAuthorLocalAuthor tdal
+                s <- getJust $ personIdent p
+                return $ sharerIdent s
+            )
+            (\ tdar -> do
+                ra <- getJust $ ticketDependencyAuthorRemoteAuthor tdar
+                ro <- getJust $ remoteActorIdent ra
+                i <- getJust $ remoteObjectInstance ro
+                return (instanceHost i, remoteObjectIdent ro)
+            )
+            tda
+    getChild tdid = do
+        tdc <- requireEitherAlt
+            (getValBy $ UniqueTicketDependencyChildLocal tdid)
+            (getValBy $ UniqueTicketDependencyChildRemote tdid)
+            "No TDC"
+            "Both TDCL and TDCR"
+        bitraverse
+            (getWorkItem . ticketDependencyChildLocalChild)
+            (\ tdcr -> do
+                ro <- getJust $ ticketDependencyChildRemoteChild tdcr
+                i <- getJust $ remoteObjectInstance ro
+                return (instanceHost i, remoteObjectIdent ro)
+            )
+            tdc
+    -}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-
+getProjectTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
+getProjectTicketNewR shr prj = do
+    wid <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shr
+        Entity _   j <- getBy404 $ UniqueProject prj sid
+        return $ projectWorkflow j
+    ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
+    defaultLayout $(widgetFile "ticket/new")
 
 putProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 putProjectTicketR shr prj ltkhid = do
@@ -757,15 +771,6 @@ selectDiscussionId shr prj ltkhid = do
     (_es, _ej, _et, Entity _ lticket, _etcl, _etpl, _author, _) <- getProjectTicket404 shr prj ltkhid
     return $ localTicketDiscuss lticket
 
-getProjectTicketDiscussionR
-    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
-getProjectTicketDiscussionR shar proj ltkhid = do
-    encodeHid <- getEncodeKeyHashid
-    getDiscussion
-        (ProjectTicketReplyR shar proj ltkhid . encodeHid)
-        (ProjectTicketTopReplyR shar proj ltkhid)
-        (selectDiscussionId shar proj ltkhid)
-
 postProjectTicketDiscussionR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 postProjectTicketDiscussionR shr prj ltkhid = do
@@ -828,16 +833,6 @@ getProjectTicketReplyR shr prj ltkhid mkhid = do
         (selectDiscussionId shr prj ltkhid)
         mid
 
-getProjectTicketDepsR
-    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
-getProjectTicketDepsR shr prj ltkhid =
-    getDependencyCollection here getLocalTicketId404
-    where
-    here = ProjectTicketDepsR shr prj ltkhid
-    getLocalTicketId404 = do
-        (_, _, _, Entity ltid _, _, _, _, _) <- getProjectTicket404 shr prj ltkhid
-        return ltid
-
 postProjectTicketDepsR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 postProjectTicketDepsR _shr _prj _ltkhid = error "Temporarily disabled"
@@ -908,85 +903,6 @@ deleteTicketDepOldR _shr _prj _pnum _cnum = error "Dep deletion disabled for now
     redirect $ ProjectTicketDepsR shr prj pnum
 -}
 
-getProjectTicketReverseDepsR
-    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
-getProjectTicketReverseDepsR shr prj ltkhid =
-    getReverseDependencyCollection here getLocalTicketId404
-    where
-    here = ProjectTicketReverseDepsR shr prj ltkhid
-    getLocalTicketId404 = do
-        (_, _, _, Entity ltid _, _, _, _, _) <- getProjectTicket404 shr prj ltkhid
-        return ltid
-
-getTicketDepR :: KeyHashid LocalTicketDependency -> Handler TypedContent
-getTicketDepR tdkhid = do
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRouteHome <- getEncodeRouteHome
-    wiRoute <- askWorkItemRoute
-    hLocal <- asksSite siteInstanceHost
-
-    tdid <- decodeKeyHashid404 tdkhid
-    (td, author, parent, child) <- runDB $ do
-        td <- get404 tdid
-        (td,,,)
-            <$> getAuthor tdid
-            <*> getWorkItem ( localTicketDependencyParent td)
-            <*> getChild tdid
-    let host =
-            case author of
-                Left _ -> hLocal
-                Right (h, _) -> h
-        tdepAP = AP.TicketDependency
-            { ticketDepId           = Just $ encodeRouteHome here
-            , ticketDepParent       = encodeRouteHome $ wiRoute parent
-            , ticketDepChild        =
-                case child of
-                    Left wi -> encodeRouteHome $ wiRoute wi
-                    Right (h, lu) -> ObjURI h lu
-            , ticketDepAttributedTo =
-                case author of
-                    Left shr -> encodeRouteLocal $ SharerR shr
-                    Right (_h, lu) -> lu
-            , ticketDepPublished    = Just $ localTicketDependencyCreated td
-            , ticketDepUpdated      = Nothing
-            }
-    provideHtmlAndAP' host tdepAP $ redirectToPrettyJSON here
-    where
-    here = TicketDepR tdkhid
-    getAuthor tdid = do
-        tda <- requireEitherAlt
-            (getValBy $ UniqueTicketDependencyAuthorLocal tdid)
-            (getValBy $ UniqueTicketDependencyAuthorRemote tdid)
-            "No TDA"
-            "Both TDAL and TDAR"
-        bitraverse
-            (\ tdal -> do
-                p <- getJust $ ticketDependencyAuthorLocalAuthor tdal
-                s <- getJust $ personIdent p
-                return $ sharerIdent s
-            )
-            (\ tdar -> do
-                ra <- getJust $ ticketDependencyAuthorRemoteAuthor tdar
-                ro <- getJust $ remoteActorIdent ra
-                i <- getJust $ remoteObjectInstance ro
-                return (instanceHost i, remoteObjectIdent ro)
-            )
-            tda
-    getChild tdid = do
-        tdc <- requireEitherAlt
-            (getValBy $ UniqueTicketDependencyChildLocal tdid)
-            (getValBy $ UniqueTicketDependencyChildRemote tdid)
-            "No TDC"
-            "Both TDCL and TDCR"
-        bitraverse
-            (getWorkItem . ticketDependencyChildLocalChild)
-            (\ tdcr -> do
-                ro <- getJust $ ticketDependencyChildRemoteChild tdcr
-                i <- getJust $ remoteObjectInstance ro
-                return (instanceHost i, remoteObjectIdent ro)
-            )
-            tdc
-
 getProjectTicketParticipantsR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
 getProjectTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFsid
@@ -1034,10 +950,6 @@ getProjectTicketTeamR shr prj ltkhid = do
             }
     provideHtmlAndAP team $ redirectToPrettyJSON here
 
-getProjectTicketEventsR
-    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
-getProjectTicketEventsR _shr _prj _ltkhid = error "TODO not implemented"
-
 getSharerTicketsR :: ShrIdent -> Handler TypedContent
 getSharerTicketsR =
     getSharerWorkItems SharerTicketsR SharerTicketR countTickets selectTickets
@@ -1197,15 +1109,6 @@ getSharerTicketReverseDepsR shr talkhid =
         (_, Entity ltid _, _, _, _) <- getSharerTicket404 shr talkhid
         return ltid
 
-getSharerTicketFollowersR
-    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
-getSharerTicketFollowersR shr talkhid = getFollowersCollection here getFsid
-    where
-    here = SharerTicketFollowersR shr talkhid
-    getFsid = do
-        (_, Entity _ lt, _, _, _) <- getSharerTicket404 shr talkhid
-        return $ localTicketFollowers lt
-
 getSharerTicketTeamR
     :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerTicketTeamR shr talkhid = do
@@ -1221,3 +1124,4 @@ getSharerTicketEventsR shr talkhid = do
     provideEmptyCollection
         CollectionTypeOrdered
         (SharerTicketEventsR shr talkhid)
+-}

src/Vervis/Hook.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -135,7 +135,6 @@ instance ToJSON Commit
 data Push = Push
     { pushSecret :: Text
     , pushUser   :: Int64
-    , pushSharer :: Text
     , pushRepo   :: Text
     , pushBranch :: Maybe Text
     , pushBefore :: Maybe Text
@@ -200,8 +199,8 @@ sendPush config manager push = do
     adaptErr = T.pack . displayException
     consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
 
-reportNewCommits :: Config -> Text -> Text -> IO ()
+reportNewCommits :: Config -> Text -> IO ()
-reportNewCommits config sharer repo = do
+reportNewCommits config repo = do
     user <- read <$> getEnv "VERVIS_SSH_USER"
     manager <- newManager defaultManagerSettings
     withRepo "." $ loop user manager
@@ -251,7 +250,6 @@ reportNewCommits config sharer repo = do
                 let push = Push
                         { pushSecret = configSecret config
                         , pushUser   = user
-                        , pushSharer = sharer
                         , pushRepo   = repo
                         , pushBranch = Just branch
                         , pushBefore = old <$ moldRef
@@ -306,10 +304,10 @@ reportNewCommits config sharer repo = do
 
 postReceive :: IO ()
 postReceive = do
-    (host, sharer, repo) <- do
+    (host, repo) <- do
         args <- getArgs
         case args of
-            [h, s, r] -> return (h, T.pack s, T.pack r)
+            [h, r] -> return (h, T.pack r)
             _ -> die "Unexpected number of arguments"
     cachePath <- getVervisCachePath host
     config <- do
@@ -317,10 +315,10 @@ postReceive = do
         case mc of
             Nothing -> die "Parsing hook config failed"
             Just c -> return c
-    reportNewCommits config sharer repo
+    reportNewCommits config repo
 
-reportNewPatches :: Config -> Text -> Text -> IO ()
+reportNewPatches :: Config -> Text -> IO ()
-reportNewPatches config sharer repo = do
+reportNewPatches config repo = do
     user <- read <$> getEnv "VERVIS_SSH_USER"
     manager <- newManager defaultManagerSettings
     melem <- parseXMLDoc <$> getEnv "DARCS_PATCHES_XML"
@@ -333,7 +331,6 @@ reportNewPatches config sharer repo = do
             return Push
                 { pushSecret = configSecret config
                 , pushUser   = user
-                , pushSharer = sharer
                 , pushRepo   = repo
                 , pushBranch = Nothing
                 , pushBefore = Nothing
@@ -416,10 +413,10 @@ reportNewPatches config sharer repo = do
 
 postApply :: IO ()
 postApply = do
-    (host, sharer, repo) <- do
+    (host, repo) <- do
         args <- getArgs
         case args of
-            [h, s, r] -> return (h, T.pack s, T.pack r)
+            [h, r] -> return (h, T.pack r)
             _ -> die "Unexpected number of arguments"
     cachePath <- getVervisCachePath host
     config <- do
@@ -427,4 +424,4 @@ postApply = do
         case mc of
             Nothing -> die "Parsing hook config failed"
             Just c -> return c
-    reportNewPatches config sharer repo
+    reportNewPatches config repo

src/Vervis/Migration/Model.hs

@@ -14,6 +14,7 @@
  -}
 
 module Vervis.Migration.Model
+    {-
     ( EntityField (..)
     , Unique (..)
     , model_2016_08_04
@@ -282,25 +283,30 @@ module Vervis.Migration.Model
     , Repo300Generic (..)
     , CollabFulfillsLocalTopicCreation300Generic (..)
     )
+    -}
 where
 
 import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Database.Persist.Class (EntityField, Unique)
+import Database.Persist.EmailAddress ()
 import Database.Persist.Schema.Types (Entity)
 import Database.Persist.Schema.SQL ()
 import Database.Persist.Schema.TH (makeEntitiesMigration)
 import Database.Persist.Sql (SqlBackend)
+import Text.Email.Validate (EmailAddress)
+
+import Development.PatchMediaType
+import Development.PatchMediaType.Persist
 
 import Vervis.FedURI
 import Vervis.Migration.TH (schema)
-import Vervis.Model (SharerId)
 import Vervis.Model.Group
 import Vervis.Model.Ident
-import Development.PatchMediaType
 import Vervis.Model.Role
 import Vervis.Model.TH
+import Vervis.Model.Ticket
 import Vervis.Model.Workflow
 
 -- For migrations 77, 114
@@ -538,3 +544,82 @@ model_2022_07_24 = $(schema "2022_07_24_collab_fulfills")
 
 makeEntitiesMigration "300"
     $(modelFile "migrations/2022_07_25_collab_fulfills_mig.model")
+
+
+
+
+
+makeEntitiesMigration "303"
+    $(modelFile "migrations/303_2022-08-04_username.model")
+
+makeEntitiesMigration "308"
+    $(modelFile "migrations/308_2022-08-04_remove_tcr.model")
+
+makeEntitiesMigration "310"
+    $(modelFile "migrations/310_2022-08-04_move_ticket_discuss.model")
+
+makeEntitiesMigration "312"
+    $(modelFile "migrations/312_2022-08-04_move_ticket_followers.model")
+
+makeEntitiesMigration "316"
+    $(modelFile "migrations/316_2022-08-04_move_ticket_accept.model")
+
+makeEntitiesMigration "318"
+    $(modelFile "migrations/318_2022-08-04_tal_ticket.model")
+
+makeEntitiesMigration "323"
+    $(modelFile "migrations/323_2022-08-04_tar_ticket.model")
+
+makeEntitiesMigration "328"
+    $(modelFile "migrations/328_2022-08-04_tjl_ticket.model")
+
+makeEntitiesMigration "332"
+    $(modelFile "migrations/332_2022-08-04_trl_ticket.model")
+
+makeEntitiesMigration "338"
+    $(modelFile "migrations/338_2022-08-04_rtd_child.model")
+
+makeEntitiesMigration "342"
+    $(modelFile "migrations/342_2022-08-04_ltd_parent.model")
+
+makeEntitiesMigration "345"
+    $(modelFile "migrations/345_2022-08-04_tdcl_child.model")
+
+makeEntitiesMigration "348"
+    $(modelFile "migrations/348_2022-08-04_tr_ticket.model")
+
+makeEntitiesMigration "356"
+    $(modelFile "migrations/356_2022-08-04_person_actor.model")
+
+makeEntitiesMigration "365"
+    $(modelFile "migrations/365_2022-08-04_group_actor.model")
+
+makeEntitiesMigration "367"
+    $(modelFile "migrations/367_2022-08-04_repo_actor.model")
+
+model_384_loom :: [Entity SqlBackend]
+model_384_loom = $(schema "384_2022-08-04_loom")
+
+model_386_assignee :: [Entity SqlBackend]
+model_386_assignee = $(schema "386_2022-08-04_assignee")
+
+makeEntitiesMigration "388"
+    $(modelFile "migrations/388_2022-08-04_ticket_loom.model")
+
+makeEntitiesMigration "396"
+    $(modelFile "migrations/396_2022-08-04_repo_dir.model")
+
+model_399_fwder :: [Entity SqlBackend]
+model_399_fwder = $(schema "399_2022-08-04_fwder")
+
+model_408_collab_loom :: [Entity SqlBackend]
+model_408_collab_loom = $(schema "408_2022-08-04_collab_loom")
+
+makeEntitiesMigration "409"
+    $(modelFile "migrations/409_2022-08-05_repo_create.model")
+
+makeEntitiesMigration "414"
+    $(modelFile "migrations/414_2022-08-05_followremote_actor.model")
+
+makeEntitiesMigration "418"
+    $(modelFile "migrations/418_2022-08-06_follow_actor.model")

src/Vervis/Model/Ident.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,7 +16,11 @@
 -- | Dedicated identifier name types for type safety. For use in routes, models
 -- and handlers.
 module Vervis.Model.Ident
-    ( ShrIdent (..)
+    ( Username (..)
+    , username2text
+    , text2username
+
+    , ShrIdent (..)
     , shr2text
     , text2shr
     , KyIdent (..)
@@ -57,6 +61,16 @@ import Database.Persist.Class.Local ()
 import Database.Persist.Sql.Local ()
 import Web.PathPieces.Local ()
 
+newtype Username = Username { unUsername :: CI Text }
+    deriving
+        (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
+
+username2text :: Username -> Text
+username2text = CI.original . unUsername
+
+text2username :: Text -> Username
+text2username = Username . CI.mk
+
 newtype ShrIdent = ShrIdent { unShrIdent :: CI Text }
     deriving
         (Eq, Ord, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)

src/Vervis/Patch.hs

@@ -1,232 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ 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
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
-module Vervis.Patch
-    ( getSharerProposal
-    , getSharerProposal404
-    , getRepoProposal
-    , getRepoProposal404
-    )
-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
-import Vervis.Model.Ident
-
-getResolved
-    :: MonadIO m
-    => LocalTicketId
-    -> ReaderT SqlBackend m
-        (Maybe
-            ( Entity TicketResolve
-            , Either (Entity TicketResolveLocal) (Entity TicketResolveRemote)
-            )
-        )
-getResolved ltid = do
-    metr <- getBy $ UniqueTicketResolve ltid
-    for metr $ \ etr@(Entity trid _) ->
-        (etr,) <$>
-            requireEitherAlt
-                (getBy $ UniqueTicketResolveLocal trid)
-                (getBy $ UniqueTicketResolveRemote trid)
-                "No TRX"
-                "Both TRL and TRR"
-
-getSharerProposal
-    :: MonadIO m
-    => ShrIdent
-    -> TicketAuthorLocalId
-    -> ReaderT SqlBackend m
-        ( Maybe
-            ( Entity TicketAuthorLocal
-            , Entity LocalTicket
-            , Entity Ticket
-            , Either
-                ( Entity TicketContextLocal
-                , Entity TicketRepoLocal
-                )
-                ( Entity TicketProjectRemote
-                , Maybe (Entity TicketProjectRemoteAccept)
-                )
-            , Maybe
-                ( Entity TicketResolve
-                , Either
-                    (Entity TicketResolveLocal)
-                    (Entity TicketResolveRemote)
-                )
-            , NonEmpty BundleId
-            )
-        )
-getSharerProposal shr talid = runMaybeT $ do
-    pid <- do
-        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
-        MaybeT $ getKeyBy $ UniquePersonIdent sid
-    tal <- MaybeT $ get talid
-    guard $ ticketAuthorLocalAuthor tal == pid
-    let ltid = ticketAuthorLocalTicket tal
-    lt <- lift $ getJust ltid
-    let tid = localTicketTicket lt
-    t <- lift $ getJust tid
-    bnids <-
-        MaybeT $
-            nonEmpty <$> selectKeysList [BundleTicket ==. tid] [Desc BundleId]
-    repo <-
-        requireEitherAlt
-            (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid
-                for mtcl $ \ etcl@(Entity tclid _) -> do
-                    etrl <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid
-                    mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid
-                    mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
-                    unless (isJust mtup1 == isJust mtup2) $
-                        error "TUP points to unrelated TAL and TCL!"
-                    guard $ not $ isJust mtup1
-                    return (etcl, etrl)
-            )
-            (do mtpr <- lift $ getBy $ UniqueTicketProjectRemote talid
-                lift $ for mtpr $ \ etpr@(Entity tprid _) ->
-                    (etpr,) <$> getBy (UniqueTicketProjectRemoteAccept tprid)
-            )
-            "MR doesn't have context"
-            "MR has both local and remote context"
-    mresolved <- lift $ getResolved ltid
-    return (Entity talid tal, Entity ltid lt, Entity tid t, repo, mresolved, bnids)
-
-getSharerProposal404
-    :: ShrIdent
-    -> KeyHashid TicketAuthorLocal
-    -> AppDB
-        ( Entity TicketAuthorLocal
-        , Entity LocalTicket
-        , Entity Ticket
-        , Either
-            ( Entity TicketContextLocal
-            , Entity TicketRepoLocal
-            )
-            ( Entity TicketProjectRemote
-            , Maybe (Entity TicketProjectRemoteAccept)
-            )
-        , Maybe
-            ( Entity TicketResolve
-            , Either
-                (Entity TicketResolveLocal)
-                (Entity TicketResolveRemote)
-            )
-        , NonEmpty BundleId
-        )
-getSharerProposal404 shr talkhid = do
-    talid <- decodeKeyHashid404 talkhid
-    mpatch <- getSharerProposal shr talid
-    case mpatch of
-        Nothing -> notFound
-        Just patch -> return patch
-
-getRepoProposal
-    :: MonadIO m
-    => ShrIdent
-    -> RpIdent
-    -> LocalTicketId
-    -> ReaderT SqlBackend m
-        ( Maybe
-            ( Entity Sharer
-            , Entity Repo
-            , Entity Ticket
-            , Entity LocalTicket
-            , Entity TicketContextLocal
-            , Entity TicketRepoLocal
-            , Either
-                (Entity TicketAuthorLocal, Entity TicketUnderProject)
-                (Entity TicketAuthorRemote)
-            , Maybe
-                ( Entity TicketResolve
-                , Either
-                    (Entity TicketResolveLocal)
-                    (Entity TicketResolveRemote)
-                )
-            , NonEmpty BundleId
-            )
-        )
-getRepoProposal shr rp ltid = runMaybeT $ do
-    es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr
-    er@(Entity rid _) <- MaybeT $ getBy $ UniqueRepo rp sid
-    lt <- MaybeT $ get ltid
-    let tid = localTicketTicket lt
-    t <- MaybeT $ get tid
-    etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid
-    etrl@(Entity _ trl) <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid
-    guard $ ticketRepoLocalRepo trl == rid
-    bnids <-
-        MaybeT $
-            nonEmpty <$> selectKeysList [BundleTicket ==. tid] [Desc BundleId]
-    author <-
-        requireEitherAlt
-            (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
-                for mtal $ \ tal@(Entity talid _) -> do
-                    tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tclid
-                    tup@(Entity tupid2 _) <- MaybeT $ getBy $ UniqueTicketUnderProjectAuthor talid
-                    unless (tupid1 == tupid2) $
-                        error "TAL and TPL used by different TUPs!"
-                    return (tal, tup)
-            )
-            (lift $ getBy $ UniqueTicketAuthorRemote tclid)
-            "MR doesn't have author"
-            "MR has both local and remote author"
-    mresolved <- lift $ getResolved ltid
-    return (es, er, Entity tid t, Entity ltid lt, etcl, etrl, author, mresolved, bnids)
-
-getRepoProposal404
-    :: ShrIdent
-    -> RpIdent
-    -> KeyHashid LocalTicket
-    -> AppDB
-        ( Entity Sharer
-        , Entity Repo
-        , Entity Ticket
-        , Entity LocalTicket
-        , Entity TicketContextLocal
-        , Entity TicketRepoLocal
-        , Either
-            (Entity TicketAuthorLocal, Entity TicketUnderProject)
-            (Entity TicketAuthorRemote)
-        , Maybe
-            ( Entity TicketResolve
-            , Either
-                (Entity TicketResolveLocal)
-                (Entity TicketResolveRemote)
-            )
-        , NonEmpty BundleId
-        )
-getRepoProposal404 shr rp ltkhid = do
-    ltid <- decodeKeyHashid404 ltkhid
-    mpatch <- getRepoProposal shr rp ltid
-    case mpatch of
-        Nothing -> notFound
-        Just patch -> return patch

src/Vervis/Path.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,8 +15,6 @@
 
 module Vervis.Path
     ( askRepoRootDir
-    , sharerDir
-    , askSharerDir
     , repoDir
     , askRepoDir
     )
@@ -28,30 +26,21 @@ import System.FilePath ((</>))
 import qualified Data.CaseInsensitive as CI (foldedCase)
 import qualified Data.Text as T (unpack)
 
+import Yesod.Hashids
 import Yesod.MonadSite
 
 import Vervis.Foundation
-import Vervis.Model.Ident
+import Vervis.Model
 import Vervis.Settings
 
 askRepoRootDir :: (MonadSite m, SiteEnv m ~ App) => m FilePath
 askRepoRootDir = asksSite $ appRepoDir . appSettings
 
-sharerDir :: FilePath -> ShrIdent -> FilePath
+repoDir :: FilePath -> KeyHashid Repo -> FilePath
-sharerDir root sharer =
+repoDir root repo = root </> (T.unpack $ keyHashidText repo)
-    root </> (T.unpack $ CI.foldedCase $ unShrIdent sharer)
-
-askSharerDir :: (MonadSite m, SiteEnv m ~ App) => ShrIdent -> m FilePath
-askSharerDir sharer = do
-    root <- askRepoRootDir
-    return $ sharerDir root sharer
-
-repoDir :: FilePath -> ShrIdent -> RpIdent -> FilePath
-repoDir root sharer repo =
-    sharerDir root sharer </> (T.unpack $ CI.foldedCase $ unRpIdent repo)
 
 askRepoDir
-    :: (MonadSite m, SiteEnv m ~ App) => ShrIdent -> RpIdent -> m FilePath
+    :: (MonadSite m, SiteEnv m ~ App) => KeyHashid Repo -> m FilePath
-askRepoDir sharer repo = do
+askRepoDir repo = do
     root <- askRepoRootDir
-    return $ repoDir root sharer repo
+    return $ repoDir root repo

src/Vervis/Recipient.hs

@@ -0,0 +1,905 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- These are for the Barbie-based generated Eq and Ord instances
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Vervis.Recipient
+    ( -- * Local actors
+      LocalActorBy (..)
+    , LocalActor
+    , parseLocalActor
+    , renderLocalActor
+
+      -- * Local collections of (local and remote) actors
+    , LocalStageBy (..)
+    , LocalStage
+    , renderLocalStage
+
+      -- * Converting between KeyHashid, Key, Identity and Entity
+    , hashLocalActorPure
+    , getHashLocalActor
+    , hashLocalActor
+
+    , unhashLocalActorPure
+    , unhashLocalActor
+    , unhashLocalActorF
+    , unhashLocalActorM
+    , unhashLocalActorE
+    , unhashLocalActor404
+
+    , hashLocalStagePure
+    , getHashLocalStage
+    , hashLocalStage
+
+    , unhashLocalStagePure
+    , unhashLocalStage
+    , unhashLocalStageF
+    , unhashLocalStageM
+    , unhashLocalStageE
+    , unhashLocalStage404
+
+      -- * Local recipient set
+      -- ** Types
+    , TicketRoutes (..)
+    , ClothRoutes (..)
+    , PersonRoutes (..)
+    , GroupRoutes (..)
+    , RepoRoutes (..)
+    , DeckRoutes (..)
+    , LoomRoutes (..)
+    , DeckFamilyRoutes (..)
+    , LoomFamilyRoutes (..)
+    , RecipientRoutes (..)
+      -- ** Creating
+    , makeRecipientSet
+    , actorRecips
+      -- * Filtering
+    , localRecipSieve
+    , localRecipSieve'
+
+      -- * Parsing audience from a received activity
+    , ParsedAudience (..)
+    , concatRecipients
+    , parseAudience
+
+      -- * Creating a recipient set, supporting both local and remote recips
+    , Aud (..)
+    , collectAudience
+    )
+where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.Barbie
+import Data.Bifunctor
+import Data.Either
+import Data.Foldable
+import Data.Functor.Classes
+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 GHC.Generics
+import Web.Hashids
+import Yesod.Core
+
+import qualified Control.Monad.Fail as F
+import qualified Data.List.NonEmpty as NE
+import qualified Data.List.Ordered as LO
+import qualified Data.Text as T
+
+import Network.FedURI
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Data.List.Local
+import Data.List.NonEmpty.Local
+
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model
+
+-------------------------------------------------------------------------------
+-- Actor and collection-of-actors 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 LocalActorBy f
+    = LocalActorPerson (f Person)
+    | LocalActorGroup  (f Group)
+    | LocalActorRepo   (f Repo)
+    | LocalActorDeck   (f Deck)
+    | LocalActorLoom   (f Loom)
+    deriving (Generic, FunctorB, ConstraintsB)
+
+deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
+deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f)
+
+{-
+instance (Eq (f Person), Eq (f Group), Eq (f Repo), Eq (f Deck), Eq (f Loom)) => Eq (LocalActorBy f) where
+    (==) (LocalActorPerson p) (LocalActorPerson p') = p == p'
+    (==) (LocalActorGroup g) (LocalActorGroup g') = g == g'
+    (==) (LocalActorRepo r) (LocalActorRepo r') = r == r'
+    (==) (LocalActorDeck d) (LocalActorDeck d') = d == d'
+    (==) (LocalActorLoom l) (LocalActorLoom l') = l == l'
+    (==) _ _ = False
+
+instance (Ord (f Person), Ord (f Group), Ord (f Repo), Ord (f Deck), Ord (f Loom)) => Ord (LocalActorBy f) where
+    (<=) (LocalActorPerson p) (LocalActorPerson p') = p <= p'
+    (<=) (LocalActorPerson _) _                     = True
+
+    (<=) (LocalActorGroup _) (LocalActorPerson _) = False
+    (<=) (LocalActorGroup g) (LocalActorGroup g') = g <= g'
+    (<=) (LocalActorGroup _) _                    = True
+
+    (<=) (LocalActorGroup _) (LocalActorPerson _) = False
+    (<=) (LocalActorGroup g) (LocalActorGroup g') = g <= g'
+    (<=) (LocalActorGroup _) _                    = True
+-}
+
+type LocalActor = LocalActorBy KeyHashid
+
+parseLocalActor :: Route App -> Maybe LocalActor
+parseLocalActor (PersonR pkhid) = Just $ LocalActorPerson pkhid
+parseLocalActor (GroupR gkhid)  = Just $ LocalActorGroup gkhid
+parseLocalActor (RepoR rkhid)   = Just $ LocalActorRepo rkhid
+parseLocalActor (DeckR dkhid)   = Just $ LocalActorDeck dkhid
+parseLocalActor (LoomR lkhid)   = Just $ LocalActorLoom lkhid
+parseLocalActor _               = Nothing
+
+renderLocalActor :: LocalActor -> Route App
+renderLocalActor (LocalActorPerson pkhid) = PersonR pkhid
+renderLocalActor (LocalActorGroup gkhid)  = GroupR gkhid
+renderLocalActor (LocalActorRepo rkhid)   = RepoR rkhid
+renderLocalActor (LocalActorDeck dkhid)   = DeckR dkhid
+renderLocalActor (LocalActorLoom lkhid)   = LoomR lkhid
+
+data LocalStageBy f
+    = LocalStagePersonFollowers (f Person)
+
+    | LocalStageRepoFollowers   (f Repo)
+
+    | LocalStageDeckFollowers   (f Deck)
+    | LocalStageTicketFollowers (f Deck) (f TicketDeck)
+
+    | LocalStageLoomFollowers   (f Loom)
+    | LocalStageClothFollowers  (f Loom) (f TicketLoom)
+    deriving (Generic, FunctorB, ConstraintsB)
+
+deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f)
+deriving instance AllBF Ord f LocalStageBy => Ord (LocalStageBy f)
+
+type LocalStage = LocalStageBy KeyHashid
+
+parseLocalStage :: Route App -> Maybe LocalStage
+parseLocalStage (PersonFollowersR pkhid) =
+    Just $ LocalStagePersonFollowers pkhid
+parseLocalStage (RepoFollowersR rkhid) =
+    Just $ LocalStageRepoFollowers rkhid
+parseLocalStage (DeckFollowersR dkhid) =
+    Just $ LocalStageDeckFollowers dkhid
+parseLocalStage (TicketFollowersR dkhid ltkhid) =
+    Just $ LocalStageTicketFollowers dkhid ltkhid
+parseLocalStage (LoomFollowersR lkhid) =
+    Just $ LocalStageLoomFollowers lkhid
+parseLocalStage (ClothFollowersR lkhid ltkhid) =
+    Just $ LocalStageClothFollowers lkhid ltkhid
+parseLocalStage _ = Nothing
+
+renderLocalStage :: LocalStage -> Route App
+renderLocalStage (LocalStagePersonFollowers pkhid) =
+    PersonFollowersR pkhid
+renderLocalStage (LocalStageRepoFollowers rkhid) =
+    RepoFollowersR rkhid
+renderLocalStage (LocalStageDeckFollowers dkhid) =
+    DeckFollowersR dkhid
+renderLocalStage (LocalStageTicketFollowers dkhid ltkhid) =
+    TicketFollowersR dkhid ltkhid
+renderLocalStage (LocalStageLoomFollowers lkhid) =
+    LoomFollowersR lkhid
+renderLocalStage (LocalStageClothFollowers lkhid ltkhid) =
+    ClothFollowersR lkhid ltkhid
+
+parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage)
+parseLocalRecipient r =
+    Left <$> parseLocalActor r <|> Right <$> parseLocalStage r
+
+-------------------------------------------------------------------------------
+-- Converting between KeyHashid, Key, Identity and Entity
+-------------------------------------------------------------------------------
+
+hashLocalActorPure
+    :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
+hashLocalActorPure ctx = f
+    where
+    f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p
+    f (LocalActorGroup g)  = LocalActorGroup $ encodeKeyHashidPure ctx g
+    f (LocalActorRepo r)   = LocalActorRepo $ encodeKeyHashidPure ctx r
+    f (LocalActorDeck d)   = LocalActorDeck $ encodeKeyHashidPure ctx d
+    f (LocalActorLoom l)   = LocalActorLoom $ encodeKeyHashidPure ctx l
+
+getHashLocalActor
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => m (LocalActorBy Key -> LocalActorBy KeyHashid)
+getHashLocalActor = do
+    ctx <- asksSite siteHashidsContext
+    return $ hashLocalActorPure ctx
+
+hashLocalActor
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalActorBy Key -> m (LocalActorBy KeyHashid)
+hashLocalActor actor = do
+    hash <- getHashLocalActor
+    return $ hash actor
+
+unhashLocalActorPure
+    :: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key)
+unhashLocalActorPure ctx = f
+    where
+    f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p
+    f (LocalActorGroup g)  = LocalActorGroup <$> decodeKeyHashidPure ctx g
+    f (LocalActorRepo r)   = LocalActorRepo <$> decodeKeyHashidPure ctx r
+    f (LocalActorDeck d)   = LocalActorDeck <$> decodeKeyHashidPure ctx d
+    f (LocalActorLoom l)   = LocalActorLoom <$> decodeKeyHashidPure ctx l
+
+unhashLocalActor
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalActorBy KeyHashid -> m (Maybe (LocalActorBy Key))
+unhashLocalActor actor = do
+    ctx <- asksSite siteHashidsContext
+    return $ unhashLocalActorPure ctx actor
+
+unhashLocalActorF
+    :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m))
+    => LocalActorBy KeyHashid -> String -> m (LocalActorBy Key)
+unhashLocalActorF actor e = maybe (F.fail e) return =<< unhashLocalActor actor
+
+unhashLocalActorM
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalActorBy KeyHashid -> MaybeT m (LocalActorBy Key)
+unhashLocalActorM = MaybeT . unhashLocalActor
+
+unhashLocalActorE
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalActorBy KeyHashid -> e -> ExceptT e m (LocalActorBy Key)
+unhashLocalActorE actor e =
+    ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor
+
+unhashLocalActor404
+    :: ( MonadSite m
+       , MonadHandler m
+       , HandlerSite m ~ SiteEnv m
+       , YesodHashids (HandlerSite m)
+       )
+    => LocalActorBy KeyHashid
+    -> m (LocalActorBy Key)
+unhashLocalActor404 actor = maybe notFound return =<< unhashLocalActor actor
+
+hashLocalStagePure
+    :: HashidsContext -> LocalStageBy Key -> LocalStageBy KeyHashid
+hashLocalStagePure ctx = f
+    where
+    f (LocalStagePersonFollowers p) =
+        LocalStagePersonFollowers $ encodeKeyHashidPure ctx p
+    f (LocalStageRepoFollowers r) =
+        LocalStageRepoFollowers $ encodeKeyHashidPure ctx r
+    f (LocalStageDeckFollowers d) =
+        LocalStageDeckFollowers $ encodeKeyHashidPure ctx d
+    f (LocalStageTicketFollowers d t) =
+        LocalStageTicketFollowers
+            (encodeKeyHashidPure ctx d)
+            (encodeKeyHashidPure ctx t)
+    f (LocalStageLoomFollowers l) =
+        LocalStageLoomFollowers $ encodeKeyHashidPure ctx l
+    f (LocalStageClothFollowers l c) =
+        LocalStageClothFollowers
+            (encodeKeyHashidPure ctx l)
+            (encodeKeyHashidPure ctx c)
+
+getHashLocalStage
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => m (LocalStageBy Key -> LocalStageBy KeyHashid)
+getHashLocalStage = do
+    ctx <- asksSite siteHashidsContext
+    return $ hashLocalStagePure ctx
+
+hashLocalStage
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalStageBy Key -> m (LocalStageBy KeyHashid)
+hashLocalStage stage = do
+    hash <- getHashLocalStage
+    return $ hash stage
+
+unhashLocalStagePure
+    :: HashidsContext -> LocalStageBy KeyHashid -> Maybe (LocalStageBy Key)
+unhashLocalStagePure ctx = f
+    where
+    f (LocalStagePersonFollowers p) =
+        LocalStagePersonFollowers <$> decodeKeyHashidPure ctx p
+    f (LocalStageRepoFollowers r) =
+        LocalStageRepoFollowers <$> decodeKeyHashidPure ctx r
+    f (LocalStageDeckFollowers d) =
+        LocalStageDeckFollowers <$> decodeKeyHashidPure ctx d
+    f (LocalStageTicketFollowers d t) =
+        LocalStageTicketFollowers
+            <$> decodeKeyHashidPure ctx d
+            <*> decodeKeyHashidPure ctx t
+    f (LocalStageLoomFollowers l) =
+        LocalStageLoomFollowers <$> decodeKeyHashidPure ctx l
+    f (LocalStageClothFollowers l c) =
+        LocalStageClothFollowers
+            <$> decodeKeyHashidPure ctx l
+            <*> decodeKeyHashidPure ctx c
+
+unhashLocalStage
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalStageBy KeyHashid -> m (Maybe (LocalStageBy Key))
+unhashLocalStage stage = do
+    ctx <- asksSite siteHashidsContext
+    return $ unhashLocalStagePure ctx stage
+
+unhashLocalStageF
+    :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m))
+    => LocalStageBy KeyHashid -> String -> m (LocalStageBy Key)
+unhashLocalStageF stage e = maybe (F.fail e) return =<< unhashLocalStage stage
+
+unhashLocalStageM
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalStageBy KeyHashid -> MaybeT m (LocalStageBy Key)
+unhashLocalStageM = MaybeT . unhashLocalStage
+
+unhashLocalStageE
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => LocalStageBy KeyHashid -> e -> ExceptT e m (LocalStageBy Key)
+unhashLocalStageE stage e =
+    ExceptT $ maybe (Left e) Right <$> unhashLocalStage stage
+
+unhashLocalStage404
+    :: ( MonadSite m
+       , MonadHandler m
+       , HandlerSite m ~ SiteEnv m
+       , YesodHashids (HandlerSite m)
+       )
+    => LocalStageBy KeyHashid
+    -> m (LocalStageBy Key)
+unhashLocalStage404 stage = maybe notFound return =<< unhashLocalStage stage
+
+-------------------------------------------------------------------------------
+-- 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 LeafTicket = LeafTicketFollowers deriving (Eq, Ord)
+
+data LeafCloth = LeafClothFollowers deriving (Eq, Ord)
+
+data LeafPerson = LeafPerson | LeafPersonFollowers deriving (Eq, Ord)
+
+data LeafGroup = LeafGroup deriving (Eq, Ord)
+
+data LeafRepo = LeafRepo | LeafRepoFollowers deriving (Eq, Ord)
+
+data LeafDeck = LeafDeck | LeafDeckFollowers deriving (Eq, Ord)
+
+data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord)
+
+data PieceDeck
+    = PieceDeck LeafDeck
+    | PieceTicket (KeyHashid TicketDeck) LeafTicket
+    deriving (Eq, Ord)
+
+data PieceLoom
+    = PieceLoom LeafLoom
+    | PieceCloth (KeyHashid TicketLoom) LeafCloth
+    deriving (Eq, Ord)
+
+data LocalRecipient
+    = RecipPerson (KeyHashid Person) LeafPerson
+    | RecipGroup  (KeyHashid Group)  LeafGroup
+    | RecipRepo   (KeyHashid Repo)   LeafRepo
+    | RecipDeck   (KeyHashid Deck)   PieceDeck
+    | RecipLoom   (KeyHashid Loom)   PieceLoom
+    deriving (Eq, Ord)
+
+recipientFromActor :: LocalActor -> LocalRecipient
+recipientFromActor (LocalActorPerson pkhid) =
+    RecipPerson pkhid LeafPerson
+recipientFromActor (LocalActorGroup gkhid) =
+    RecipGroup gkhid LeafGroup
+recipientFromActor (LocalActorRepo rkhid) =
+    RecipRepo rkhid LeafRepo
+recipientFromActor (LocalActorDeck dkhid) =
+    RecipDeck dkhid $ PieceDeck LeafDeck
+recipientFromActor (LocalActorLoom lkhid) =
+    RecipLoom lkhid $ PieceLoom LeafLoom
+
+recipientFromStage :: LocalStage -> LocalRecipient
+recipientFromStage (LocalStagePersonFollowers pkhid) =
+    RecipPerson pkhid LeafPersonFollowers
+recipientFromStage (LocalStageRepoFollowers rkhid) =
+    RecipRepo rkhid LeafRepoFollowers
+recipientFromStage (LocalStageDeckFollowers dkhid) =
+    RecipDeck dkhid $ PieceDeck LeafDeckFollowers
+recipientFromStage (LocalStageTicketFollowers dkhid ltkhid) =
+    RecipDeck dkhid $ PieceTicket ltkhid LeafTicketFollowers
+recipientFromStage (LocalStageLoomFollowers lkhid) =
+    RecipLoom lkhid $ PieceLoom LeafLoomFollowers
+recipientFromStage (LocalStageClothFollowers lkhid ltkhid) =
+    RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers
+
+-------------------------------------------------------------------------------
+-- 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 TicketRoutes = TicketRoutes
+    { routeTicketFollowers :: Bool
+    }
+    deriving Eq
+
+data ClothRoutes = ClothRoutes
+    { routeClothFollowers :: Bool
+    }
+    deriving Eq
+
+data PersonRoutes = PersonRoutes
+    { routePerson          :: Bool
+    , routePersonFollowers :: Bool
+    }
+    deriving Eq
+
+data GroupRoutes = GroupRoutes
+    { routeGroup :: Bool
+    }
+    deriving Eq
+
+data RepoRoutes = RepoRoutes
+    { routeRepo          :: Bool
+    , routeRepoFollowers :: Bool
+    }
+    deriving Eq
+
+data DeckRoutes = DeckRoutes
+    { routeDeck          :: Bool
+    , routeDeckFollowers :: Bool
+    }
+    deriving Eq
+
+data LoomRoutes = LoomRoutes
+    { routeLoom          :: Bool
+    , routeLoomFollowers :: Bool
+    }
+    deriving Eq
+
+data DeckFamilyRoutes = DeckFamilyRoutes
+    { familyDeck    :: DeckRoutes
+    , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
+    }
+    deriving Eq
+
+data LoomFamilyRoutes = LoomFamilyRoutes
+    { familyLoom   :: LoomRoutes
+    , familyCloths :: [(KeyHashid TicketLoom, ClothRoutes)]
+    }
+    deriving Eq
+
+data RecipientRoutes = RecipientRoutes
+    { recipPeople :: [(KeyHashid Person, PersonRoutes)]
+    , recipGroups :: [(KeyHashid Group , GroupRoutes)]
+    , recipRepos  :: [(KeyHashid Repo  , RepoRoutes)]
+    , recipDecks  :: [(KeyHashid Deck  , DeckFamilyRoutes)]
+    , recipLooms  :: [(KeyHashid Loom  , LoomFamilyRoutes)]
+    }
+    deriving Eq
+
+groupLocalRecipients :: [LocalRecipient] -> RecipientRoutes
+groupLocalRecipients = organize . partitionByActor
+    where
+    partitionByActor
+        :: [LocalRecipient]
+        -> ( [(KeyHashid Person, LeafPerson)]
+           , [(KeyHashid Group, LeafGroup)]
+           , [(KeyHashid Repo, LeafRepo)]
+           , [(KeyHashid Deck, PieceDeck)]
+           , [(KeyHashid Loom, PieceLoom)]
+           )
+    partitionByActor = foldl' f ([], [], [], [], [])
+        where
+        f (p, g, r, d, l) (RecipPerson pkhid pleaf) =
+            ((pkhid, pleaf) : p, g, r, d, l)
+        f (p, g, r, d, l) (RecipGroup gkhid gleaf) =
+            (p, (gkhid, gleaf) : g, r, d, l)
+        f (p, g, r, d, l) (RecipRepo rkhid rleaf) =
+            (p, g, (rkhid, rleaf) : r, d, l)
+        f (p, g, r, d, l) (RecipDeck dkhid dpiece) =
+            (p, g, r, (dkhid, dpiece) : d, l)
+        f (p, g, r, d, l) (RecipLoom lkhid lpiece) =
+            (p, g, r, d, (lkhid, lpiece) : l)
+
+    organize 
+        :: ( [(KeyHashid Person, LeafPerson)]
+           , [(KeyHashid Group, LeafGroup)]
+           , [(KeyHashid Repo, LeafRepo)]
+           , [(KeyHashid Deck, PieceDeck)]
+           , [(KeyHashid Loom, PieceLoom)]
+           )
+        -> RecipientRoutes
+    organize (p, g, r, d, l) = RecipientRoutes
+        { recipPeople =
+            map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p
+        , recipGroups =
+            map (second $ foldr orLG $ GroupRoutes False) $ groupByKeySort g
+        , recipRepos =
+            map (second $ foldr orLR $ RepoRoutes False False) $ groupByKeySort r
+        , recipDecks =
+            map (second
+                    $ uncurry DeckFamilyRoutes
+                    . bimap
+                        (foldr orLD $ DeckRoutes False False)
+                        ( map (second $  foldr orLT $ TicketRoutes False)
+                        . groupByKey
+                        )
+                    . partitionEithers . NE.toList . NE.map pd2either
+                ) $
+            groupByKeySort d
+        , recipLooms =
+            map (second
+                    $ uncurry LoomFamilyRoutes
+                    . bimap
+                        (foldr orLL $ LoomRoutes False False)
+                        ( map (second $ foldr orLC $ ClothRoutes False)
+                        . groupByKey
+                        )
+                    . partitionEithers . NE.toList . NE.map pl2either
+                ) $
+            groupByKeySort l
+        }
+        where
+        groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)]
+        groupByKey = groupWithExtract fst snd
+
+        groupByKeySort :: Ord a => [(a, b)] -> [(a, NonEmpty b)]
+        groupByKeySort = groupAllExtract fst snd
+
+        orLP :: LeafPerson -> PersonRoutes -> PersonRoutes
+        orLP _                   pr@(PersonRoutes True True) = pr
+        orLP LeafPerson          pr@(PersonRoutes _    _)    = pr { routePerson = True }
+        orLP LeafPersonFollowers pr@(PersonRoutes _    _)    = pr { routePersonFollowers = True }
+
+        orLG :: LeafGroup -> GroupRoutes -> GroupRoutes
+        orLG _         gr@(GroupRoutes True) = gr
+        orLG LeafGroup gr@(GroupRoutes _)    = gr { routeGroup = True }
+
+        orLR :: LeafRepo -> RepoRoutes -> RepoRoutes
+        orLR _                 rr@(RepoRoutes True True) = rr
+        orLR LeafRepo          rr@(RepoRoutes _    _)    = rr { routeRepo = True }
+        orLR LeafRepoFollowers rr@(RepoRoutes _    _)    = rr { routeRepoFollowers = True }
+
+        orLD :: LeafDeck -> DeckRoutes -> DeckRoutes
+        orLD _                 dr@(DeckRoutes True True) = dr
+        orLD LeafDeck          dr@(DeckRoutes _    _)    = dr { routeDeck = True }
+        orLD LeafDeckFollowers dr@(DeckRoutes _    _)    = dr { routeDeckFollowers = True }
+
+        orLL :: LeafLoom -> LoomRoutes -> LoomRoutes
+        orLL _                 lr@(LoomRoutes True True) = lr
+        orLL LeafLoom          lr@(LoomRoutes _    _)    = lr { routeLoom = True }
+        orLL LeafLoomFollowers lr@(LoomRoutes _    _)    = lr { routeLoomFollowers = True }
+
+        orLT :: LeafTicket -> TicketRoutes -> TicketRoutes
+        orLT _                   tr@(TicketRoutes True) = tr
+        orLT LeafTicketFollowers tr@(TicketRoutes _)    = tr { routeTicketFollowers = True }
+
+        orLC :: LeafCloth -> ClothRoutes -> ClothRoutes
+        orLC _                  cr@(ClothRoutes True) = cr
+        orLC LeafClothFollowers cr@(ClothRoutes _)    = cr { routeClothFollowers = True }
+
+        pd2either :: PieceDeck -> Either LeafDeck (KeyHashid TicketDeck, LeafTicket)
+        pd2either (PieceDeck ld)          = Left ld
+        pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt)
+
+        pl2either :: PieceLoom -> Either LeafLoom (KeyHashid TicketLoom, LeafCloth)
+        pl2either (PieceLoom ll)         = Left ll
+        pl2either (PieceCloth ltkhid ll) = Right (ltkhid, ll)
+
+-------------------------------------------------------------------------------
+-- Parse URIs into a grouped recipient set
+-------------------------------------------------------------------------------
+
+makeRecipientSet :: [LocalActor] -> [LocalStage] -> RecipientRoutes
+makeRecipientSet actors stages =
+    groupLocalRecipients $
+        map recipientFromActor actors ++ map recipientFromStage stages
+
+actorIsMember :: LocalActor -> RecipientRoutes -> Bool
+actorIsMember (LocalActorPerson pkhid) routes =
+    case lookup pkhid $ recipPeople routes of
+        Just p -> routePerson p
+        Nothing -> False
+actorIsMember (LocalActorGroup gkhid) routes =
+    case lookup gkhid $ recipGroups routes of
+        Just g -> routeGroup g
+        Nothing -> False
+actorIsMember (LocalActorRepo rkhid) routes =
+    case lookup rkhid $ recipRepos routes of
+        Just r -> routeRepo r
+        Nothing -> False
+actorIsMember (LocalActorDeck dkhid) routes =
+    case lookup dkhid $ recipDecks routes of
+        Just d -> routeDeck $ familyDeck d
+        Nothing -> False
+actorIsMember (LocalActorLoom lkhid) routes =
+    case lookup lkhid $ recipLooms routes of
+        Just l -> routeLoom $ familyLoom l
+        Nothing -> False
+
+actorRecips :: LocalActor -> RecipientRoutes
+actorRecips = groupLocalRecipients . (: []) . recipientFromActor
+
+localRecipSieve
+    :: RecipientRoutes -> Bool -> RecipientRoutes -> RecipientRoutes
+localRecipSieve sieve allowActors =
+    localRecipSieve' sieve allowActors allowActors
+
+localRecipSieve'
+    :: RecipientRoutes
+    -> Bool
+    -> Bool
+    -> RecipientRoutes
+    -> RecipientRoutes
+localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
+    { recipPeople = applySieve' applyPerson recipPeople
+    , recipGroups = applySieve' applyGroup recipGroups
+    , recipRepos  = applySieve' applyRepo recipRepos
+    , recipDecks  = applySieve' applyDeck recipDecks
+    , recipLooms  = applySieve' applyLoom recipLooms
+    }
+    where
+    applySieve
+        :: (  KeyHashid record
+           -> These routes routes
+           -> Maybe (KeyHashid record, routes)
+           )
+        -> [(KeyHashid record, routes)]
+        -> [(KeyHashid record, routes)]
+        -> [(KeyHashid record, routes)]
+    applySieve merge sieveList routeList =
+        mapMaybe (uncurry merge) $ sortAlign sieveList routeList
+
+    applySieve'
+        :: (  KeyHashid record
+           -> These routes routes
+           -> Maybe (KeyHashid record, routes)
+           )
+        -> (RecipientRoutes -> [(KeyHashid record, routes)])
+        -> [(KeyHashid record, routes)]
+    applySieve' merge field = applySieve merge (field sieve) (field routes)
+
+    applyPerson _     (This _) = Nothing
+    applyPerson pkhid (That p) =
+        if allowPeople && routePerson p
+            then Just (pkhid, PersonRoutes True False)
+            else Nothing
+    applyPerson pkhid (These (PersonRoutes p' pf') (PersonRoutes p pf)) =
+        let merged = PersonRoutes (p && (p' || allowPeople)) (pf && pf')
+        in  if merged == PersonRoutes False False
+                then Nothing
+                else Just (pkhid, merged)
+
+    applyGroup _     (This _) = Nothing
+    applyGroup gkhid (That g) =
+        if allowOthers && routeGroup g
+            then Just (gkhid, GroupRoutes True)
+            else Nothing
+    applyGroup gkhid (These (GroupRoutes g') (GroupRoutes g)) =
+        let merged = GroupRoutes (g && (g' || allowOthers))
+        in  if merged == GroupRoutes False
+                then Nothing
+                else Just (gkhid, merged)
+
+    applyRepo _     (This _) = Nothing
+    applyRepo rkhid (That r) =
+        if allowOthers && routeRepo r
+            then Just (rkhid, RepoRoutes True False)
+            else Nothing
+    applyRepo rkhid (These (RepoRoutes r' rf') (RepoRoutes r rf)) =
+        let merged = RepoRoutes (r && (r' || allowOthers)) (rf && rf')
+        in  if merged == RepoRoutes False False
+                then Nothing
+                else Just (rkhid, merged)
+
+    applyDeck _     (This _) = Nothing
+    applyDeck dkhid (That d) =
+        if allowOthers && routeDeck (familyDeck d)
+            then Just (dkhid, DeckFamilyRoutes (DeckRoutes True False) [])
+            else Nothing
+    applyDeck
+        dkhid
+        (These
+            (DeckFamilyRoutes (DeckRoutes d' df') t')
+            (DeckFamilyRoutes (DeckRoutes d  df)  t)
+        ) =
+            let deck = DeckRoutes (d && (d' || allowOthers)) (df && df')
+                tickets = applySieve applyTicket t' t
+                    where
+                    applyTicket ltkhid (These (TicketRoutes tf') (TicketRoutes tf)) =
+                        let merged = TicketRoutes (tf && tf')
+                        in  if merged == TicketRoutes False
+                                then Nothing
+                                else Just (ltkhid, merged)
+                    applyTicket _ _ = Nothing
+            in  if deck == DeckRoutes False False && null tickets
+                    then Nothing
+                    else Just (dkhid, DeckFamilyRoutes deck tickets)
+
+    applyLoom _     (This _) = Nothing
+    applyLoom lkhid (That d) =
+        if allowOthers && routeLoom (familyLoom d)
+            then Just (lkhid, LoomFamilyRoutes (LoomRoutes True False) [])
+            else Nothing
+    applyLoom
+        lkhid
+        (These
+            (LoomFamilyRoutes (LoomRoutes l' lf') c')
+            (LoomFamilyRoutes (LoomRoutes l  lf)  c)
+        ) =
+            let loom = LoomRoutes (l && (l' || allowOthers)) (lf && lf')
+                cloths = applySieve applyCloth c' c
+                    where
+                    applyCloth ltkhid (These (ClothRoutes cf') (ClothRoutes cf)) =
+                        let merged = ClothRoutes (cf && cf')
+                        in  if merged == ClothRoutes False
+                                then Nothing
+                                else Just (ltkhid, merged)
+                    applyCloth _ _ = Nothing
+            in  if loom == LoomRoutes False False && null cloths
+                    then Nothing
+                    else Just (lkhid, LoomFamilyRoutes loom cloths)
+
+data ParsedAudience u = ParsedAudience
+    { paudLocalRecips  :: RecipientRoutes
+    , paudRemoteActors :: [(Authority u, NonEmpty LocalURI)]
+    , paudBlinded      :: AP.Audience u
+    , paudFwdHosts     :: [Authority u]
+    }
+
+concatRecipients :: AP.Audience u -> [ObjURI u]
+concatRecipients (AP.Audience to bto cc bcc gen _) =
+    concat [to, bto, cc, bcc, gen]
+
+parseRecipients
+    :: (MonadSite m, SiteEnv m ~ App)
+    => NonEmpty FedURI
+    -> ExceptT Text m (RecipientRoutes, [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], RecipientRoutes)
+    parseLocalRecipients lus =
+        let (lusInvalid, routes) = partitionEithers $ map parseRoute lus
+            (routesInvalid, recips) = partitionEithers $ map parseRecip routes
+            (actors, stages) = partitionEithers recips
+            grouped =
+                map recipientFromActor actors ++ map recipientFromStage stages
+        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
+
+parseAudience
+    :: (MonadSite m, SiteEnv m ~ App)
+    => AP.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 \\ AP.audienceNonActors audience
+            hosts = map fst remotesGrouped
+        return ParsedAudience
+            { paudLocalRecips  = localsSet
+            , paudRemoteActors = remotesGrouped
+            , paudBlinded      =
+                audience { AP.audienceBto = [], AP.audienceBcc = [] }
+            , paudFwdHosts     =
+                let nonActorHosts =
+                        LO.nubSort $
+                            map objUriAuthority $ AP.audienceNonActors audience
+                in  LO.isect hosts nonActorHosts
+            }
+    where
+    groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
+    groupByHost = groupAllExtract objUriAuthority objUriLocal
+
+data Aud u
+    = AudLocal [LocalActor] [LocalStage]
+    | AudRemote (Authority u) [LocalURI] [LocalURI]
+
+collectAudience
+    :: Foldable f
+    => f (Aud u)
+    -> ( RecipientRoutes
+       , [(Authority u, NonEmpty LocalURI)]
+       , [Authority u]
+       , [Route App]
+       , [ObjURI u]
+       )
+collectAudience auds =
+    let (locals, remotes) = partitionAudience auds
+        (actors, stages) =
+            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 stages
+        , mapMaybe (\ (h, (as, _)) -> (h,) <$> nonEmpty as) groupedRemotes
+        , [ h | (h, (_, cs)) <- groupedRemotes, not (null cs) ]
+        , map renderLocalActor actors ++ map renderLocalStage stages
+        , 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)

src/Vervis/Ssh.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -45,10 +45,14 @@ import System.Directory (doesFileExist, doesDirectoryExist)
 import System.Environment
 import System.FilePath ((</>))
 import System.Process (CreateProcess (..), StdStream (..), createProcess, proc)
+import Web.Hashids
+import Yesod.Core.Dispatch
 
 import qualified Data.Text as T
 import qualified Formatting as F
 
+import Yesod.Hashids
+
 import Vervis.Access
 import Vervis.Model
 import Vervis.Model.Ident
@@ -69,16 +73,11 @@ type Session = SessionT SessionBase UserAuthId ChannelBase
 type SshChanDB = SqlPersistT Channel
 type SshSessDB = SqlPersistT Session
 
-data RepoSpec
-    = SpecUserRepo ShrIdent RpIdent
-    | SpecRepo RpIdent
-    deriving Show
-
 data Action
-    = DarcsTransferMode RepoSpec
+    = DarcsTransferMode (KeyHashid Repo)
-    | DarcsApply RepoSpec
+    | DarcsApply (KeyHashid Repo)
-    | GitUploadPack RepoSpec
+    | GitUploadPack (KeyHashid Repo)
-    | GitReceivePack RepoSpec
+    | GitReceivePack (KeyHashid Repo)
     deriving Show
 
 -- | Result of running an action on the server side as a response to an SSH
@@ -139,24 +138,23 @@ authorize (PublicKey name key) = do
 -- Actions
 -------------------------------------------------------------------------------
 
+toKeyHashid t =
+    case fromPathPiece t of
+        Nothing -> fail "Can't parse keyhashid"
+        Just kh -> return kh
+
 --TOD TODO TODO check paths for safety... no /./ or /../ and so on
 
-darcsRepoSpecP :: Parser RepoSpec
+darcsRepoSpecP :: Parser (KeyHashid Repo)
-darcsRepoSpecP = f <$>
+darcsRepoSpecP = toKeyHashid =<< (part <* optional (char '/'))
-                 part <*>
-                 optional (char '/' *> optional (part <* optional (char '/')))
     where
-    f sharer (Just (Just repo)) = SpecUserRepo (text2shr sharer) (text2rp repo)
-    f repo _                    = SpecRepo (text2rp repo)
     part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
 
-gitRepoSpecP :: Parser RepoSpec
+gitRepoSpecP :: Parser (KeyHashid Repo)
-gitRepoSpecP = f <$> (msh *> part) <*> optional (char '/' *> part)
+gitRepoSpecP = toKeyHashid =<< (msh *> part)
     where
-    f repo Nothing       = SpecRepo (text2rp repo)
-    f sharer (Just repo) = SpecUserRepo (text2shr sharer) (text2rp repo)
     part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
-    msh  = optional (satisfy $ \ c -> c == '/' || c == '~')
+    msh  = optional $ satisfy $ \ c -> c == '/' || c == '~'
 
 actionP :: Parser Action
 actionP =   DarcsTransferMode <$>
@@ -178,17 +176,6 @@ detectAction (Execute s) =
         Right action -> Right action
 detectAction _           = Left "Unsupported channel request"
 
-resolveSpec :: RepoSpec -> Channel (ShrIdent, RpIdent)
-resolveSpec (SpecUserRepo u r) = return (u, r)
-resolveSpec (SpecRepo r) = do
-    u <- text2shr . T.pack . authUser <$> askAuthDetails
-    return (u, r)
-
-resolveSpec' :: FilePath -> RepoSpec -> Channel (ShrIdent, RpIdent, FilePath)
-resolveSpec' root spec = do
-    (u, r) <- resolveSpec spec
-    return (u, r, repoDir root u r)
-
 execute :: FilePath -> [String] -> Channel ()
 execute cmd args = do
     lift $ $logDebugS src $
@@ -229,26 +216,34 @@ whenGitRepoExists
     :: Bool -> FilePath -> Channel ActionResult -> Channel ActionResult
 whenGitRepoExists = whenRepoExists "Git" $ isRepo . fromString
 
-canPushTo :: ShrIdent -> RpIdent -> Channel Bool
+canPushTo :: RepoId -> Channel Bool
-canPushTo shr rp = do
+canPushTo repoID = do
     pid <- authId <$> askAuthDetails
-    oas <- runChanDB $ checkRepoAccess (Just pid) ProjOpPush shr rp
+    oas <- runChanDB $ checkRepoAccess' (Just pid) ProjOpPush repoID
     return $
         case oas of
             ObjectAccessAllowed -> True
             _                   -> False
 
-runAction :: FilePath -> Bool -> Action -> Channel ActionResult
+runAction
-runAction repoDir _wantReply action =
+    :: (KeyHashid Repo -> Maybe RepoId)
+    -> FilePath
+    -> Bool
+    -> Action
+    -> Channel ActionResult
+runAction decodeRepoHash root _wantReply action =
     case action of
-        DarcsTransferMode spec -> do
+        DarcsTransferMode repoHash -> do
-            (_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
+            let repoPath = repoDir root repoHash
             whenDarcsRepoExists False repoPath $ do
                 execute "darcs" ["transfer-mode", "--repodir", repoPath]
                 return ARProcess
-        DarcsApply spec -> do
+        DarcsApply repoHash -> do
-            (sharer, repo, repoPath) <- resolveSpec' repoDir spec
+            let repoPath = repoDir root repoHash
-            can <- canPushTo sharer repo
+            can <-
+                case decodeRepoHash repoHash of
+                    Nothing -> return False
+                    Just repoID -> canPushTo repoID
             if can
                 then whenDarcsRepoExists True repoPath $ do
                     pid <- authId <$> askAuthDetails
@@ -256,14 +251,17 @@ runAction repoDir _wantReply action =
                     execute "darcs" ["apply", "--all", "--repodir", repoPath]
                     return ARProcess
                 else return $ ARFail "You can't push to this repository"
-        GitUploadPack spec -> do
+        GitUploadPack repoHash -> do
-            (_sharer, _repo, repoPath) <- resolveSpec' repoDir spec
+            let repoPath = repoDir root repoHash
             whenGitRepoExists False repoPath $ do
                 execute "git-upload-pack" [repoPath]
                 return ARProcess
-        GitReceivePack spec -> do
+        GitReceivePack repoHash -> do
-            (sharer, repo, repoPath) <- resolveSpec' repoDir spec
+            let repoPath = repoDir root repoHash
-            can <- canPushTo sharer repo
+            can <-
+                case decodeRepoHash repoHash of
+                    Nothing -> return False
+                    Just repoID -> canPushTo repoID
             if can
                 then whenGitRepoExists True repoPath $ do
                     pid <- authId <$> askAuthDetails
@@ -272,8 +270,13 @@ runAction repoDir _wantReply action =
                     return ARProcess
                 else return $ ARFail "You can't push to this repository"
 
-handle :: FilePath -> Bool -> ChannelRequest -> Channel ()
+handle
-handle repoDir wantReply request = do
+    :: (KeyHashid Repo -> Maybe RepoId)
+    -> FilePath
+    -> Bool
+    -> ChannelRequest
+    -> Channel ()
+handle decodeRepoHash repoDir wantReply request = do
     lift $ $logDebugS src $ T.pack $ show request
     case detectAction request of
         Left e    -> do
@@ -282,7 +285,7 @@ handle repoDir wantReply request = do
             when wantReply channelFail
         Right act -> do
             lift $ $logDebugS src $ T.pack $ show act
-            res <- runAction repoDir wantReply act
+            res <- runAction decodeRepoHash repoDir wantReply act
             case res of
                 ARDone msg -> do
                     lift $ $logDebugS src $ "Action done: " <> msg
@@ -307,10 +310,11 @@ ready = runLoggingT $ $logInfoS src "SSH server component starting"
 
 mkConfig
     :: AppSettings
+    -> HashidsContext
     -> ConnectionPool
     -> LogFunc
     -> IO (Config SessionBase ChannelBase UserAuthId)
-mkConfig settings pool logFunc = do
+mkConfig settings ctx pool logFunc = do
     keyPair <- keyPairFromFile $ appSshKeyFile settings
     return $ Config
         { cSession     = SessionConfig
@@ -321,7 +325,7 @@ mkConfig settings pool logFunc = do
                 flip runReaderT pool . flip runLoggingT logFunc
             }
         , cChannel     = ChannelConfig
-            { ccRequestHandler = handle $ appRepoDir settings
+            { ccRequestHandler = handle (decodeKeyHashidPure ctx) (appRepoDir settings)
             , ccRunBaseMonad   =
                 flip runReaderT pool . flip runLoggingT logFunc
             }
@@ -329,7 +333,7 @@ mkConfig settings pool logFunc = do
         , cReadyAction = ready logFunc
         }
 
-runSsh :: AppSettings -> ConnectionPool -> LogFunc -> IO ()
+runSsh :: AppSettings -> HashidsContext -> ConnectionPool -> LogFunc -> IO ()
-runSsh settings pool logFunc = do
+runSsh settings ctx pool logFunc = do
-    config <- mkConfig settings pool logFunc
+    config <- mkConfig settings ctx pool logFunc
     startConfig config

src/Vervis/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2021
+ - Written in 2016, 2018, 2019, 2020, 2021, 2022
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -15,7 +15,9 @@
  -}
 
 module Vervis.Ticket
-    ( getTicketSummaries
+    (
+    {-
+      getTicketSummaries
     --, getTicketDepEdges
     , WorkflowFieldFilter (..)
     , WorkflowFieldSummary (..)
@@ -28,14 +30,13 @@ module Vervis.Ticket
     , getTicketEnumParams
     , TicketClassParam (..)
     , getTicketClasses
-    , getSharerTicket
+    -}
-    , getSharerTicket404
-    , getProjectTicket
-    , getProjectTicket404
 
-    , getSharerWorkItems
+      getTicket
-    , getDependencyCollection
+    , getTicket404
-    , getReverseDependencyCollection
+
+    --, getDependencyCollection
+    --, getReverseDependencyCollection
 
     , WorkItem (..)
     , getWorkItemRoute
@@ -43,7 +44,6 @@ module Vervis.Ticket
     , getWorkItem
     , parseWorkItem
     , parseProposalBundle
-    , getRemoteTicketByURI
 
     , checkDepAndTarget
     )
@@ -81,15 +81,15 @@ import Data.Paginate.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
-import Vervis.ActivityPub.Recipient
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Workflow
 import Vervis.Paginate
-import Vervis.Widget.Ticket (TicketSummary (..))
+import Vervis.Recipient
 
+{-
 -- | Get summaries of all the tickets in the given project.
 getTicketSummaries
     :: Maybe (E.SqlExpr (Entity Ticket) -> E.SqlExpr (E.Value Bool))
@@ -464,23 +464,18 @@ getTicketClasses tid wid = fmap (map toCParam) $
             , f E.^. WorkflowFieldFilterClosed
             , p E.?. TicketParamClassId
             )
+-}
 
-getSharerTicket
+getTicket
     :: MonadIO m
-    => ShrIdent
+    => DeckId
-    -> TicketAuthorLocalId
+    -> TicketDeckId
     -> ReaderT SqlBackend m
         ( Maybe
-            ( Entity TicketAuthorLocal
+            ( Entity Deck
-            , Entity LocalTicket
+            , Entity TicketDeck
             , Entity Ticket
-            , Either
+            , Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)
-                ( Entity TicketContextLocal
-                , Entity TicketProjectLocal
-                )
-                ( Entity TicketProjectRemote
-                , Maybe (Entity TicketProjectRemoteAccept)
-                )
             , Maybe
                 ( Entity TicketResolve
                 , Either
@@ -489,151 +484,57 @@ getSharerTicket
                 )
             )
         )
-getSharerTicket shr talid = runMaybeT $ do
+getTicket did tdid = runMaybeT $ do
-    pid <- do
+    d <- MaybeT $ get did
-        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+    td <- MaybeT $ get tdid
-        MaybeT $ getKeyBy $ UniquePersonIdent sid
+    guard $ ticketDeckDeck td == did
-    tal <- MaybeT $ get talid
+
-    guard $ ticketAuthorLocalAuthor tal == pid
+    let tid = ticketDeckTicket td
-    let ltid = ticketAuthorLocalTicket tal
-    lt <- lift $ getJust ltid
-    let tid = localTicketTicket lt
     t <- lift $ getJust tid
-    mbn <- lift $ selectFirst [BundleTicket ==. tid] []
-    guard $ isNothing mbn
-    project <-
-        requireEitherAlt
-            (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid
-                for mtcl $ \ etcl@(Entity tclid _) -> do
-                    etpl <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid
-                    mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid
-                    mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
-                    unless (isJust mtup1 == isJust mtup2) $
-                        error "TUP points to unrelated TAL and TCL!"
-                    guard $ not $ isJust mtup1
-                    return (etcl, etpl)
-            )
-            (do mtpr <- lift $ getBy $ UniqueTicketProjectRemote talid
-                lift $ for mtpr $ \ etpr@(Entity tprid _) ->
-                    (etpr,) <$> getBy (UniqueTicketProjectRemoteAccept tprid)
-            )
-            "Ticket doesn't have project"
-            "Ticket has both local and remote project"
-    mresolved <- lift $ getResolved ltid
-    return (Entity talid tal, Entity ltid lt, Entity tid t, project, mresolved)
 
-getSharerTicket404
+    author <-
-    :: ShrIdent
+        lift $
-    -> KeyHashid TicketAuthorLocal
-    -> AppDB
-        ( Entity TicketAuthorLocal
-        , Entity LocalTicket
-        , Entity Ticket
-        , Either
-            ( Entity TicketContextLocal
-            , Entity TicketProjectLocal
-            )
-            ( Entity TicketProjectRemote
-            , Maybe (Entity TicketProjectRemoteAccept)
-            )
-        , Maybe
-            ( Entity TicketResolve
-            , Either
-                (Entity TicketResolveLocal)
-                (Entity TicketResolveRemote)
-            )
-        )
-getSharerTicket404 shr talkhid = do
-    talid <- decodeKeyHashid404 talkhid
-    mticket <- getSharerTicket shr talid
-    case mticket of
-        Nothing -> notFound
-        Just ticket -> return ticket
-
-getResolved
-    :: MonadIO m
-    => LocalTicketId
-    -> ReaderT SqlBackend m
-        (Maybe
-            ( Entity TicketResolve
-            , Either (Entity TicketResolveLocal) (Entity TicketResolveRemote)
-            )
-        )
-getResolved ltid = do
-    metr <- getBy $ UniqueTicketResolve ltid
-    for metr $ \ etr@(Entity trid _) ->
-        (etr,) <$>
             requireEitherAlt
-                (getBy $ UniqueTicketResolveLocal trid)
+                (getBy $ UniqueTicketAuthorLocal tid)
-                (getBy $ UniqueTicketResolveRemote trid)
+                (getBy $ UniqueTicketAuthorRemote tid)
-                "No TRX"
+                "Ticket doesn't have author"
-                "Both TRL and TRR"
+                "Ticket has both local and remote author"
 
-getProjectTicket
+    mresolved <- lift $ getResolved tid
-    :: MonadIO m
+
-    => ShrIdent
+    return (Entity did d, Entity tdid td, Entity tid t, author, mresolved)
-    -> PrjIdent
+
-    -> LocalTicketId
+    where
-    -> ReaderT SqlBackend m
+
-        ( Maybe
+    getResolved
-            ( Entity Sharer
+        :: MonadIO m
-            , Entity Project
+        => TicketId
-            , Entity Ticket
+        -> ReaderT SqlBackend m
-            , Entity LocalTicket
+            (Maybe
-            , Entity TicketContextLocal
-            , Entity TicketProjectLocal
-            , Either
-                (Entity TicketAuthorLocal, Entity TicketUnderProject)
-                (Entity TicketAuthorRemote)
-            , Maybe
                 ( Entity TicketResolve
                 , Either
                     (Entity TicketResolveLocal)
                     (Entity TicketResolveRemote)
                 )
             )
-        )
+    getResolved tid = do
-getProjectTicket shr prj ltid = runMaybeT $ do
+        metr <- getBy $ UniqueTicketResolve tid
-    es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr
+        for metr $ \ etr@(Entity trid _) ->
-    ej@(Entity jid _) <- MaybeT $ getBy $ UniqueProject prj sid
+            (etr,) <$>
-    lt <- MaybeT $ get ltid
+                requireEitherAlt
-    let tid = localTicketTicket lt
+                    (getBy $ UniqueTicketResolveLocal trid)
-    t <- MaybeT $ get tid
+                    (getBy $ UniqueTicketResolveRemote trid)
-    etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid
+                    "No TRX"
-    etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid
+                    "Both TRL and TRR"
-    guard $ ticketProjectLocalProject tpl == jid
-    mbn <- lift $ selectFirst [BundleTicket ==. tid] []
-    guard $ isNothing mbn
-    author <-
-        requireEitherAlt
-            (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
-                for mtal $ \ tal@(Entity talid _) -> do
-                    tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tclid
-                    tup@(Entity tupid2 _) <- MaybeT $ getBy $ UniqueTicketUnderProjectAuthor talid
-                    unless (tupid1 == tupid2) $
-                        error "TAL and TPL used by different TUPs!"
-                    return (tal, tup)
-            )
-            (lift $ getBy $ UniqueTicketAuthorRemote tclid)
-            "Ticket doesn't have author"
-            "Ticket has both local and remote author"
-    mresolved <- lift $ getResolved ltid
-    return (es, ej, Entity tid t, Entity ltid lt, etcl, etpl, author, mresolved)
 
-getProjectTicket404
+getTicket404
-    :: ShrIdent
+    :: KeyHashid Deck
-    -> PrjIdent
+    -> KeyHashid TicketDeck
-    -> KeyHashid LocalTicket
     -> AppDB
-        ( Entity Sharer
+        ( Entity Deck
-        , Entity Project
+        , Entity TicketDeck
         , Entity Ticket
-        , Entity LocalTicket
+        , Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)
-        , Entity TicketContextLocal
-        , Entity TicketProjectLocal
-        , Either
-            (Entity TicketAuthorLocal, Entity TicketUnderProject)
-            (Entity TicketAuthorRemote)
         , Maybe
             ( Entity TicketResolve
             , Either
@@ -641,73 +542,21 @@ getProjectTicket404
                 (Entity TicketResolveRemote)
             )
         )
-getProjectTicket404 shr prj ltkhid = do
+getTicket404 dkhid tdkhid = do
-    ltid <- decodeKeyHashid404 ltkhid
+    did <- decodeKeyHashid404 dkhid
-    mticket <- getProjectTicket shr prj ltid
+    tdid <- decodeKeyHashid404 tdkhid
+    mticket <- getTicket did tdid
     case mticket of
         Nothing -> notFound
         Just ticket -> return ticket
 
-getSharerWorkItems
+{-
-    :: ToBackendKey SqlBackend record
-    => (ShrIdent -> Route App)
-    -> (ShrIdent -> KeyHashid record -> Route App)
-    -> (PersonId -> AppDB Int)
-    -> (PersonId -> Int -> Int -> AppDB [E.Value (Key record)])
-    -> ShrIdent
-    -> Handler TypedContent
-getSharerWorkItems mkhere itemRoute countItems selectItems shr = do
-    (total, pages, mpage) <- runDB $ do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        pid <- getKeyBy404 $ UniquePersonIdent sid
-        getPageAndNavCount (countItems pid) (selectItems pid)
-    encodeRouteHome <- getEncodeRouteHome
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRoutePageLocal <- getEncodeRoutePageLocal
-    let here = mkhere shr
-        pageUrl = encodeRoutePageLocal here
-    encodeTicketKey <- getEncodeKeyHashid
-    let ticketUrl = itemRoute shr . encodeTicketKey
-
-    case mpage of
-        Nothing -> provide here $ Collection
-            { collectionId         = encodeRouteLocal here
-            , collectionType       = CollectionTypeOrdered
-            , collectionTotalItems = Just total
-            , collectionCurrent    = Nothing
-            , collectionFirst      = Just $ pageUrl 1
-            , collectionLast       = Just $ pageUrl pages
-            , collectionItems      = [] :: [Text]
-            }
-        Just (tickets, navModel) ->
-            let current = nmCurrent navModel
-            in  provide here $ 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 (encodeRouteHome . ticketUrl . E.unValue) tickets
-                    }
-    where
-    provide :: ActivityPub a => Route App -> a URIMode -> Handler TypedContent
-    provide here a = provideHtmlAndAP a $ redirectToPrettyJSON here
-
 getDependencyCollection
-    :: Route App -> AppDB LocalTicketId -> Handler TypedContent
+    :: Route App
-getDependencyCollection here getLocalTicketId404 = do
+    -> (KeyHashid LocalTicket -> Route App)
+    -> AppDB LocalTicketId
+    -> Handler TypedContent
+getDependencyCollection here depRoute getLocalTicketId404 = do
     tdids <- runDB $ do
         ltid <- getLocalTicketId404
         selectKeysList
@@ -724,7 +573,7 @@ getDependencyCollection here getLocalTicketId404 = do
             , collectionFirst      = Nothing
             , collectionLast       = Nothing
             , collectionItems      =
-                map (encodeRouteHome . TicketDepR . encodeHid) tdids
+                map (encodeRouteHome . depRoute . encodeHid) tdids
             }
     provideHtmlAndAP deps $ redirectToPrettyJSON here
 
@@ -759,11 +608,11 @@ getReverseDependencyCollection here getLocalTicketId404 = do
             E.on $ rtd E.^. RemoteTicketDependencyIdent E.==. ro E.^. RemoteObjectId
             E.where_ $ rtd E.^. RemoteTicketDependencyChild E.==. E.val ltid
             return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
+-}
 
 data WorkItem
-    = WorkItemSharerTicket ShrIdent TicketAuthorLocalId Bool
+    = WorkItemTicket DeckId TicketDeckId
-    | WorkItemProjectTicket ShrIdent PrjIdent LocalTicketId
+    | WorkItemCloth LoomId TicketLoomId
-    | WorkItemRepoProposal ShrIdent RpIdent LocalTicketId
     deriving Eq
 
 getWorkItemRoute
@@ -773,99 +622,26 @@ getWorkItemRoute wi = ($ wi) <$> askWorkItemRoute
 askWorkItemRoute
     :: (MonadSite m, YesodHashids (SiteEnv m)) => m (WorkItem -> Route App)
 askWorkItemRoute = do
-    hashTALID <- getEncodeKeyHashid
+    hashDID <- getEncodeKeyHashid
-    hashLTID <- getEncodeKeyHashid
+    hashLID <- getEncodeKeyHashid
-    let route (WorkItemSharerTicket shr talid False) = SharerTicketR shr (hashTALID talid)
+    hashTDID <- getEncodeKeyHashid
-        route (WorkItemSharerTicket shr talid True)  = SharerProposalR shr (hashTALID talid)
+    hashTLID <- getEncodeKeyHashid
-        route (WorkItemProjectTicket shr prj ltid)   = ProjectTicketR shr prj (hashLTID ltid)
+    let route (WorkItemTicket did tdid) = TicketR (hashDID did) (hashTDID tdid)
-        route (WorkItemRepoProposal shr rp ltid)        = RepoProposalR shr rp (hashLTID ltid)
+        route (WorkItemCloth lid tlid)  = ClothR (hashLID lid) (hashTLID tlid)
     return route
 
-getWorkItem :: MonadIO m => LocalTicketId -> ReaderT SqlBackend m WorkItem
+getWorkItem :: MonadIO m => TicketId -> ReaderT SqlBackend m WorkItem
-getWorkItem ltid = (either error return =<<) $ runExceptT $ do
+getWorkItem tid = do
-    lt <- lift $ getJust ltid
+    tracker <-
-    let tid = localTicketTicket lt
+        requireEitherAlt
-
+            (getBy $ UniqueTicketDeck tid)
-    metal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
+            (getBy $ UniqueTicketLoom tid)
-    mremoteContext <-
+            "Neither TD nor TD found"
-        case metal of
+            "Both TD and TL found"
-            Nothing -> return Nothing
+    return $
-            Just (Entity talid _) -> lift $ do
+        case tracker of
-                metcr <- getBy (UniqueTicketProjectRemote talid)
+            Left (Entity tdid td) -> WorkItemTicket (ticketDeckDeck td) tdid
-                for metcr $ \ etcr ->
+            Right (Entity tlid tl) -> WorkItemCloth (ticketLoomLoom tl) tlid
-                    (etcr,) . (> 0) <$> count [BundleTicket ==. tid]
-    mlocalContext <- do
-        metcl <- lift $ getBy $ UniqueTicketContextLocal tid
-        for metcl $ \ etcl@(Entity tclid _) -> do
-            mbn <- lift $ selectFirst [BundleTicket ==. tid] []
-            metpl <- lift $ getBy $ UniqueTicketProjectLocal tclid
-            metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid
-            case (metpl, metrl) of
-                (Nothing, Nothing) -> throwE "TCL but no TPL and no TRL"
-                (Just etpl, Nothing) -> do
-                    when (isJust mbn) $ throwE "TPL but patches attached"
-                    return (etcl, Left etpl)
-                (Nothing, Just etrl) -> do
-                    when (isNothing mbn) $ throwE "TRL but no patches attached"
-                    return (etcl, Right etrl)
-                (Just _, Just _) -> throwE "Both TPL and TRL"
-    metar <-
-        case mlocalContext of
-            Nothing -> return Nothing
-            Just (Entity tclid _, _) ->
-                lift $ getBy $ UniqueTicketAuthorRemote tclid
-
-    mert <-
-        case metar of
-            Nothing -> return Nothing
-            Just (Entity tarid _) -> lift $ getBy $ UniqueRemoteTicket tarid
-
-    metuc <-
-        case (metal, mlocalContext) of
-            (Nothing, Nothing) -> return Nothing
-            (Just (Entity talid _), Nothing) -> do
-                mtuc <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
-                for mtuc $ \ _ -> throwE "No TCL, but TUC exists for TAL"
-            (Nothing, Just (Entity tclid _, _)) -> do
-                mtuc <- lift $ getBy $ UniqueTicketUnderProjectProject tclid
-                for mtuc $ \ _ -> throwE "No TAL, but TUC exists for TCL"
-            (Just (Entity talid _), Just (Entity tclid _, _)) -> do
-                metuc1 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
-                mtucid2 <- lift $ getKeyBy $ UniqueTicketUnderProjectProject tclid
-                case (metuc1, mtucid2) of
-                    (Nothing, Nothing) -> return Nothing
-                    (Just _, Nothing) -> throwE "TAL has TUC, TCL doesn't"
-                    (Nothing, Just _) -> throwE "TCL has TUC, TAL doesn't"
-                    (Just etuc, Just tucid) ->
-                        if entityKey etuc == tucid
-                            then return $ Just etuc
-                            else throwE "TAL and TCL have different TUCs"
-
-    verifyNothingE mert "Ticket has both LT and RT"
-
-    case (mremoteContext, metal, mlocalContext, metar) of
-        (Nothing, Just etal, Just (_, ctx), Nothing) ->
-            lift $
-            case metuc of
-                Nothing -> authorHosted etal (isRight ctx)
-                Just _ -> contextHosted ctx
-        (Nothing, Nothing, Just (_, ctx), Just _) -> lift $ contextHosted ctx
-        (Just (_, patch), Just etal, Nothing, Nothing) ->
-            lift $ authorHosted etal patch
-        _ -> throwE "Invalid/unexpected context/author situation"
-    where
-    contextHosted (Left (Entity _ tpl)) = do
-        j <- getJust $ ticketProjectLocalProject tpl
-        s <- getJust $ projectSharer j
-        return $ WorkItemProjectTicket (sharerIdent s) (projectIdent j) ltid
-    contextHosted (Right (Entity _ trl)) = do
-        r <- getJust $ ticketRepoLocalRepo trl
-        s <- getJust $ repoSharer r
-        return $ WorkItemRepoProposal (sharerIdent s) (repoIdent r) ltid
-    authorHosted (Entity talid tal) patch = do
-        p <- getJust $ ticketAuthorLocalAuthor tal
-        s <- getJust $ personIdent p
-        return $ WorkItemSharerTicket (sharerIdent s) talid patch
 
 parseWorkItem name u@(ObjURI h lu) = do
     hl <- hostIsLocal h
@@ -875,18 +651,14 @@ parseWorkItem name u@(ObjURI h lu) = do
                 fromMaybeE (decodeRouteLocal lu) $
                     name <> ": Not a valid route"
             case route of
-                SharerTicketR shr talkhid -> do
+                TicketR deck ticket ->
-                    talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
+                    WorkItemTicket
-                    return $ WorkItemSharerTicket shr talid False
+                        <$> decodeKeyHashidE deck   (name <> ": Invalid dkhid")
-                SharerProposalR shr talkhid -> do
+                        <*> decodeKeyHashidE ticket (name <> ": Invalid tdkhid")
-                    talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
+                ClothR loom ticket ->
-                    return $ WorkItemSharerTicket shr talid True
+                    WorkItemCloth
-                ProjectTicketR shr prj ltkhid -> do
+                        <$> decodeKeyHashidE loom   (name <> ": Invalid lkhid")
-                    ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
+                        <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
-                    return $ WorkItemProjectTicket shr prj ltid
-                RepoProposalR shr rp ltkhid -> do
-                    ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
-                    return $ WorkItemRepoProposal shr rp ltid
                 _ -> throwE $ name <> ": not a work item route"
         else return $ Right u
 
@@ -898,63 +670,14 @@ parseProposalBundle name u@(ObjURI h lu) = do
                 fromMaybeE (decodeRouteLocal lu) $
                     name <> ": Not a valid route"
             case route of
-                SharerProposalBundleR shr talkhid bnkhid-> do
+                BundleR loom ticket bundle ->
-                    talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
+                    (,,)
-                    bnid <- decodeKeyHashidE bnkhid $ name <> ": Invalid bnkhid"
+                        <$> decodeKeyHashidE loom   (name <> ": Invalid lkhid")
-                    return $ Left (shr, talid, bnid)
+                        <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
-                RepoProposalBundleR shr rp ltkhid bnkhid -> do
+                        <*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid")
-                    ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
-                    bnid <- decodeKeyHashidE bnkhid $ name <> ": Invalid bnkhid"
-                    return $ Right (shr, rp, ltid, bnid)
                 _ -> throwE $ name <> ": not a bundle route"
         else return $ Right u
 
-getRemoteTicketByURI
-    :: MonadIO m
-    => ObjURI URIMode
-    -> ExceptT Text (ReaderT SqlBackend m)
-        (Either
-            Text
-            ( Entity Instance
-            , Entity RemoteObject
-            , Entity RemoteTicket
-            , Entity TicketAuthorRemote
-            , Entity TicketContextLocal
-            , Either (Entity TicketProjectLocal) (Entity TicketRepoLocal)
-            )
-        )
-getRemoteTicketByURI (ObjURI h lu) = adapt $ do
-    ei@(Entity iid _) <- do
-        mei <- lift $ getBy $ UniqueInstance h
-        fromMaybeE mei $ Right "Instance not known"
-    ero@(Entity roid _) <- do
-        mero <- lift $ getBy $ UniqueRemoteObject iid lu
-        fromMaybeE mero $ Right "Remote object not known"
-    ert@(Entity _ rt) <- do
-        mert <- lift $ getBy $ UniqueRemoteTicketIdent roid
-        fromMaybeE mert $ Right "Not a known RemoteTicket"
-    etar@(Entity _ tar) <- do
-        metar <- lift $ getEntity $ remoteTicketTicket rt
-        fromMaybeE metar $ Left "RT's TAR not found in DB"
-    etcl@(Entity tclid _) <- do
-        metcl <- lift $ getEntity $ ticketAuthorRemoteTicket tar
-        fromMaybeE metcl $ Left "TAR's TCL not found in DB"
-    ctx <- do
-        metjl <- lift $ getBy $ UniqueTicketProjectLocal tclid
-        metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid
-        case (metjl, metrl) of
-            (Nothing, Nothing) -> throwE $ Left "TCL has neither TJL nor TRL"
-            (Just j, Nothing) -> return $ Left j
-            (Nothing, Just r) -> return $ Right r
-            (Just _, Just _) -> throwE $ Left "TCL has both TJL and TRL"
-    return (ei, ero, ert, etar, etcl, ctx)
-    where
-    adapt m = ExceptT $ adapt' <$> runExceptT m
-        where
-        adapt' (Left (Left e)) = Left e
-        adapt' (Left (Right e)) = Right $ Left e
-        adapt' (Right x) = Right $ Right x
-
 checkDepAndTarget
     :: (MonadSite m, SiteEnv m ~ App)
     => TicketDependency URIMode
@@ -985,13 +708,13 @@ checkDepAndTarget
                     (parseLocalActor route)
                     "Offer local target isn't an actor route"
             else return $ Right u
-    checkParentAndTarget (Left wi) (Left la) =
+    checkParentAndTarget (Left wi) (Left la) = do
-        unless (workItemActor wi == la) $
+        la' <-
+            case wi of
+                WorkItemTicket did _ -> LocalActorDeck <$> encodeKeyHashid did
+                WorkItemCloth lid _ -> LocalActorLoom <$> encodeKeyHashid lid
+        unless (la' == la) $
             throwE "Parent and target mismatch"
-        where
-        workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr
-        workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj
-        workItemActor (WorkItemRepoProposal shr rp _) = LocalActorRepo shr rp
     checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target"
     checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
     checkParentAndTarget (Right _) (Right _) = return ()

src/Vervis/Widget/Discussion.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -43,16 +43,19 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Yesod.RenderSource
 import Vervis.Settings (widgetFile)
-import Vervis.Widget.Sharer
+import Vervis.Widget.Person
 
 actorLinkW :: MessageTreeNodeAuthor -> Widget
-actorLinkW actor = $(widgetFile "widget/actor-link")
+actorLinkW actor = do
+    hashPerson <- getEncodeKeyHashid
+    $(widgetFile "widget/actor-link")
     where
     shortURI h (LocalURI p) = renderAuthority h <> p
 
 messageW
     :: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget
 messageW now (MessageTreeNode msgid msg author) reply = do
+    hashPerson <- getEncodeKeyHashid
     encodeHid <- getEncodeKeyHashid
     let showTime =
             showEventTime .

src/Vervis/Widget/Person.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -13,9 +13,9 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-module Vervis.Widget.Sharer
+module Vervis.Widget.Person
-    ( sharerLinkW
+    ( personLinkW
-    , sharerLinkFedW
+    , personLinkFedW
     , followW
     , personNavW
     )
@@ -29,6 +29,7 @@ import Yesod.Persist.Core
 
 import Network.FedURI
 import Yesod.Auth.Unverified
+import Yesod.Hashids
 
 import Database.Persist.Local
 
@@ -38,19 +39,19 @@ import Vervis.Model.Ident
 import Vervis.Settings
 import Vervis.Widget
 
-sharerLinkW :: Sharer -> Widget
+personLinkW :: Entity Person -> Actor -> Widget
-sharerLinkW sharer =
+personLinkW (Entity personID person) actor = do
+    personHash <- encodeKeyHashid personID
     [whamlet|
-        <a href=@{SharerR $ sharerIdent sharer}>
+        <a href=@{PersonR personHash}>
-          $maybe name <- sharerName sharer
+          #{actorName actor} ~#{username2text $ personUsername person}
-            #{name}
-          $nothing
-            #{shr2text $ sharerIdent sharer}
     |]
 
-sharerLinkFedW :: Either Sharer (Instance, RemoteObject, RemoteActor) -> Widget
+personLinkFedW
-sharerLinkFedW (Left sharer)                     = sharerLinkW sharer
+    :: Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
-sharerLinkFedW (Right (inztance, object, actor)) =
+    -> Widget
+personLinkFedW (Left (ep, a)) = personLinkW ep a
+personLinkFedW (Right (inztance, object, actor)) =
     [whamlet|
         <a href="#{renderObjURI uActor}">
           $maybe name <- remoteActorName actor
@@ -61,16 +62,18 @@ sharerLinkFedW (Right (inztance, object, actor)) =
     where
     uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
 
-followW :: Route App -> Route App -> AppDB FollowerSetId -> Widget
+followW :: Route App -> Route App -> FollowerSetId -> Widget
-followW followRoute unfollowRoute getFsid = do
+followW followRoute unfollowRoute fsid = do
-    mpid <- maybeVerifiedAuthId
+    maybeUser <- maybeVerifiedAuth
-    for_ mpid $ \ pid -> do
+    for_ maybeUser $ \ (Entity _ user) -> do
-        mfollow <- handlerToWidget $ runDB $ do
+        mfollow <-
-            fsid <- getFsid
+            handlerToWidget $ runDB $
-            getValBy $ UniqueFollow pid fsid
+                getBy $ UniqueFollow (personActor user) fsid
         case mfollow of
             Nothing -> buttonW POST "Follow" followRoute
             Just _ -> buttonW POST "Unfollow" unfollowRoute
 
-personNavW :: ShrIdent -> Widget
+personNavW :: Entity Person -> Widget
-personNavW shr = $(widgetFile "person/widget/nav")
+personNavW (Entity personID person) = do
+    personHash <- encodeKeyHashid personID
+    $(widgetFile "person/widget/nav")

src/Vervis/Widget/Repo.hs

@@ -31,19 +31,22 @@ import qualified Data.List.NonEmpty as N
 import qualified Data.Text as T (take)
 import qualified Data.Vector as V
 
+import Yesod.Hashids
+
 import Data.Patch.Local (Hunk (..))
 
 import Vervis.Changes
 import Vervis.Foundation
+import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Settings (widgetFile, appDiffContextLines)
 import Vervis.Style
 
-refSelectW :: ShrIdent -> RpIdent -> Set Text -> Set Text -> Widget
+refSelectW :: KeyHashid Repo -> Set Text -> Set Text -> Widget
-refSelectW shar repo branches tags = $(widgetFile "repo/widget/ref-select")
+refSelectW hash branches tags = $(widgetFile "repo/widget/ref-select")
 
-changesW :: Foldable f => ShrIdent -> RpIdent -> f LogEntry -> Widget
+changesW :: Foldable f => KeyHashid Repo -> f LogEntry -> Widget
-changesW shr rp entries = $(widgetFile "repo/widget/changes")
+changesW hash entries = $(widgetFile "repo/widget/changes")
 
 numberHunk :: Int -> Int -> Hunk -> (Int, Int, [(Bool, Int, Text)])
 numberHunk startOld startNew hunk = j $ i ((startOld, startNew), []) hunk

src/Vervis/WorkItem.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -14,15 +14,16 @@
  -}
 
 module Vervis.WorkItem
-    ( WorkItemDetail (..)
+    (
-    , getWorkItemAuthorDetail
+    --  WorkItemDetail (..)
-    , askWorkItemFollowers
+    --, getWorkItemAuthorDetail
-    , contextAudience
+      askWorkItemFollowers
-    , authorAudience
+    --, contextAudience
-    , parseTicketContext
+    --, authorAudience
-    , getRemoteContextHttp
+    --, parseTicketContext
-    , getWorkItemDetail
+    --, getRemoteContextHttp
-    , WorkItemTarget (..)
+    --, getWorkItemDetail
+    --, WorkItemTarget (..)
     )
 where
 
@@ -41,6 +42,7 @@ import Database.Persist.Sql
 
 import qualified Data.Text as T
 
+import Development.PatchMediaType
 import Network.FedURI
 import Web.ActivityPub
 import Yesod.ActivityPub
@@ -52,15 +54,15 @@ import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 
-import Vervis.ActivityPub.Recipient
+import Vervis.Cloth
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Development.PatchMediaType
+import Vervis.Recipient
-import Vervis.Patch
 import Vervis.Ticket
 
+{-
 data WorkItemDetail = WorkItemDetail
     { widIdent   :: Either (WorkItem, LocalTicketId) (FedURI, LocalURI)
     , widContext :: Either (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) (FedURI, Host, Maybe LocalURI, Maybe LocalURI)
@@ -85,19 +87,22 @@ getWorkItemAuthorDetail =
             i <- getJust $ remoteObjectInstance ro
             return (i, ro)
         )
+-}
 
 askWorkItemFollowers
-    :: (MonadSite m, YesodHashids (SiteEnv m))
+    :: (MonadSite m, YesodHashids (SiteEnv m)) => m (WorkItem -> LocalStage)
-    => m (WorkItem -> LocalPersonCollection)
 askWorkItemFollowers = do
-    hashTALID <- getEncodeKeyHashid
+    hashDeck <- getEncodeKeyHashid
-    hashLTID <- getEncodeKeyHashid
+    hashLoom <- getEncodeKeyHashid
-    let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid
+    hashTicket <- getEncodeKeyHashid
-        workItemFollowers (WorkItemSharerTicket shr talid True)  = LocalPersonCollectionSharerProposalFollowers shr $ hashTALID talid
+    hashCloth <- getEncodeKeyHashid
-        workItemFollowers (WorkItemProjectTicket shr prj ltid)   = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid
+    let workItemFollowers (WorkItemTicket deck ticket) =
-        workItemFollowers (WorkItemRepoProposal shr rp ltid)        = LocalPersonCollectionRepoProposalFollowers shr rp $ hashLTID ltid
+            LocalStageTicketFollowers (hashDeck deck) (hashTicket ticket)
+        workItemFollowers (WorkItemCloth loom cloth) =
+            LocalStageClothFollowers (hashLoom loom) (hashCloth cloth)
     return workItemFollowers
 
+{-
 contextAudience
     :: Either
         (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
@@ -249,3 +254,4 @@ getWorkItemDetail name v = do
 data WorkItemTarget
     = WITProject ShrIdent PrjIdent
     | WITRepo ShrIdent RpIdent (Maybe Text) PatchMediaType (NonEmpty Text)
+-}

src/Web/ActivityPub.hs

@@ -451,7 +451,7 @@ instance ActivityPub Actor where
 
 data Repo u = Repo
     { repoActor :: Actor u
-    , repoTeam  :: LocalURI
+    , repoTeam  :: Maybe LocalURI
     , repoVcs   :: VersionControlSystem
     }
 
@@ -463,16 +463,16 @@ instance ActivityPub Repo where
             fail "Actor type isn't Repository"
         fmap (h,) $
             Repo a
-                <$> withAuthorityO h (o .:| "team")
+                <$> withAuthorityMaybeO h (o .:|? "team")
                 <*> o .: "versionControlSystem"
     toSeries authority (Repo actor team vcs)
         =  toSeries authority actor
-        <> "team"                 .= ObjURI authority team
+        <> "team"                 .= (ObjURI authority <$> team)
         <> "versionControlSystem" .= vcs
 
 data TicketTracker u = TicketTracker
     { ticketTrackerActor :: Actor u
-    , ticketTrackerTeam  :: LocalURI
+    , ticketTrackerTeam  :: Maybe LocalURI
     }
 
 instance ActivityPub TicketTracker where
@@ -483,10 +483,10 @@ instance ActivityPub TicketTracker where
             fail "Actor type isn't TicketTracker"
         fmap (h,) $
             TicketTracker a
-                <$> withAuthorityO h (o .:| "team")
+                <$> withAuthorityMaybeO h (o .:|? "team")
     toSeries authority (TicketTracker actor team)
         =  toSeries authority actor
-        <> "team" .= ObjURI authority team
+        <> "team" .= (ObjURI authority <$> team)
 
 data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered
 
@@ -1085,7 +1085,7 @@ encodeTicketLocal
 
 data MergeRequest u = MergeRequest
     { mrOrigin :: Maybe (ObjURI u)
-    , mrTarget :: LocalURI
+    , mrTarget :: Either LocalURI (Branch u)
     , mrBundle :: Either (ObjURI u) (Authority u, Bundle u)
     }
 
@@ -1097,12 +1097,16 @@ instance ActivityPub MergeRequest where
         unless (typ == ("Offer" :: Text)) $
             fail "type isn't Offer"
 
-        ObjURI a target <- o .: "target"
+        target <- o .:+ "target"
+        let (a, target') =
+                case target of
+                    Left (ObjURI h lu) -> (h, Left lu)
+                    Right (Doc h branch) -> (h, Right branch)
 
         fmap (a,) $
             MergeRequest
                 <$> o .:? "origin"
-                <*> pure target
+                <*> pure target'
                 <*> (second fromDoc . toEither <$> o .: "object")
         where
         fromDoc (Doc h v) = (h, v)
@@ -1110,7 +1114,7 @@ instance ActivityPub MergeRequest where
     toSeries h (MergeRequest morigin target bundle)
         =  "type"   .=  ("Offer" :: Text)
         <> "origin" .=? morigin
-        <> "target" .=  ObjURI h target
+        <> "target" .=+ bimap (ObjURI h) (Doc h) target
         <> "object" .=  fromEither (second (uncurry Doc) bundle)
 
 data Ticket u = Ticket

src/Yesod/Hashids.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -17,9 +17,12 @@ module Yesod.Hashids
     ( YesodHashids (..)
     , KeyHashid ()
     , keyHashidText
+
     , encodeKeyHashidPure
     , getEncodeKeyHashid
     , encodeKeyHashid
+
+    , decodeKeyHashidPure
     , decodeKeyHashid
     , decodeKeyHashidF
     , decodeKeyHashidM
@@ -83,6 +86,14 @@ encodeKeyHashid k = do
     enc <- getEncodeKeyHashid
     return $ enc k
 
+decodeKeyHashidPure
+    :: ToBackendKey SqlBackend record
+    => HashidsContext
+    -> KeyHashid record
+    -> Maybe (Key record)
+decodeKeyHashidPure ctx (KeyHashid t) =
+    fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t
+
 decodeKeyHashid
     :: ( MonadSite m
        , YesodHashids (SiteEnv m)
@@ -90,9 +101,9 @@ decodeKeyHashid
        )
     => KeyHashid record
     -> m (Maybe (Key record))
-decodeKeyHashid (KeyHashid t) = do
+decodeKeyHashid khid = do
     ctx <- asksSite siteHashidsContext
-    return $ fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t
+    return $ decodeKeyHashidPure ctx khid
 
 decodeKeyHashidF
     :: ( MonadFail m

templates/browse.hamlet

@@ -29,7 +29,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 <p>
   Vervis is a web application written in the Haskell programming language and
   the Yesod web framework. It's free as in freedom, under AGPLv3. It's being
-  developed by fr33domlover, who can be found under this nickname on Freenode
+  developed by fr33domlover, who can be found under this nickname on
+  <a href="https://libera.chat">
+    Libera Chat
   in the #peers channel.
 
 <p>
@@ -55,53 +57,37 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     and
     <a href="https://socialhub.activitypub.rocks/c/software/forgefed">forum
 
-<h2>Repos
-
-<table>
-  <tr>
-    <th>Sharer
-    <th>Project
-    <th>Repo
-    <th>VCS
-    <th>Last change
-  $forall (sharer, mproj, repo, vcs, ago) <- rowsRepo
-    <tr>
-      <td>
-        <a href=@{SharerR sharer}>#{shr2text sharer}
-      <td>
-        $maybe proj <- mproj
-          <a href=@{ProjectR sharer proj}>#{prj2text proj}
-        $nothing
-          (none)
-      <td>
-        <a href=@{RepoR sharer repo}>#{rp2text repo}
-      <td>
-        $case vcs
-          $of VCSDarcs
-            Darcs
-          $of VCSGit
-            Git
-      <td>
-        $maybe t <- ago
-          #{t}
-        $nothing
-          Error
-
-<h2>Projects without repos
-
-<table>
-  <tr>
-    <th>Sharer
-    <th>Project
-  $forall (E.Value sharer, E.Value project) <- rowsProject
-    <tr>
-      <td>
-        <a href=@{SharerR sharer}>#{shr2text sharer}
-      <td>
-        <a href=@{ProjectR sharer project}>#{prj2text project}
-
 <h2>People
 
-<p>
+<ul>
-  See
+  $forall (Entity personID person, Entity _ actor) <- people
-  <a href=@{PeopleR}>people</a>.
+    <a href=@{PersonR $ hashPerson personID}>
+      ~#{username2text $ personUsername person} #{actorName actor}
+
+<h2>Groups
+
+<ul>
+  $forall (Entity groupID _, Entity _ actor) <- groups
+    <a href=@{GroupR $ hashGroup groupID}>
+      &#{keyHashidText $ hashGroup groupID} #{actorName actor}
+
+<h2>Repos
+
+<ul>
+  $forall (Entity repoID _, Entity _ actor) <- repos
+    <a href=@{RepoR $ hashRepo repoID}>
+      ^#{keyHashidText $ hashRepo repoID} #{actorName actor}
+
+<h2>Decks
+
+<ul>
+  $forall (Entity deckID _, Entity _ actor) <- decks
+    <a href=@{DeckR $ hashDeck deckID}>
+      =#{keyHashidText $ hashDeck deckID} #{actorName actor}
+
+<h2>Looms
+
+<ul>
+  $forall (Entity loomID _, Entity _ actor) <- looms
+    <a href=@{LoomR $ hashLoom loomID}>
+      +#{keyHashidText $ hashLoom loomID} #{actorName actor}

templates/default-layout.hamlet

@@ -13,7 +13,7 @@ $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <header>
-  $maybe (Entity _pid person, verified, sharer, unread) <- mperson
+  $maybe (Entity _ person, hash, verified, unread) <- mperson
     <div>
       $if verified
         <span>
@@ -21,19 +21,19 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
           <span .username>#{personLogin person}</span>]
         $if unread > 0
           <span>
-            <a href=@{NotificationsR $ sharerIdent sharer}>
+            <a href=@{NotificationsR}>
               🔔#{unread}
         <span>
-          <a href=@{SharerInboxR $ sharerIdent sharer}>
+          <a href=@{PersonInboxR hash}>
             [📥 Inbox]
         <span>
-          <a href=@{SharerOutboxR $ sharerIdent sharer}>
+          <a href=@{PersonOutboxR hash}>
             [📤 Outbox]
         <span>
-          <a href=@{SharerFollowersR $ sharerIdent sharer}>
+          <a href=@{PersonFollowersR hash}>
             [🐤 Followers]
         <span>
-          <a href=@{SharerFollowingR $ sharerIdent sharer}>
+          <a href=@{PersonFollowingR hash}>
             [🐔 Following]
         <span>
           <a href=@{BrowseR}>
@@ -52,7 +52,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
           it. Or <a href=@{AuthR LogoutR}>Log out.
         $if unread > 0
           <span>
-            <a href=@{NotificationsR $ sharerIdent sharer}>
+            <a href=@{NotificationsR}>
               🔔#{unread}
   $nothing
     <div>

templates/discussion/widget/message.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -18,8 +18,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       ^{actorLinkW author}
     <span .time>
       $case author
-        $of MessageTreeNodeLocal lmid s
+        $of MessageTreeNodeLocal lmid pid
-          <a href=@{MessageR (sharerIdent s) (encodeHid lmid)}>
+          <a href=@{PersonMessageR (hashPerson pid) (encodeHid lmid)}>
             #{showTime $ messageCreated msg}
         $of MessageTreeNodeRemote h luMsg _luAuthor _mname
           <a href="#{renderObjURI $ ObjURI h luMsg}"}>

templates/person.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -16,6 +16,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 ^{followButton}
 
-<p>#{personAbout person}
+<p>#{actorDesc actor}
 
-^{personNavW shr}
+^{personNavW ep}

templates/person/notifications.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -16,7 +16,7 @@ $if null notifications
   <p>
     Nothing new here :-)
 $else
-  <form method=POST action=@{NotificationsR shr} enctype=#{enctypeAll}>
+  <form method=POST action=@{NotificationsR} enctype=#{enctypeAll}>
     ^{widgetAll}
     <div class="submit">
       <input type="submit" value="Mark all as read">
@@ -37,7 +37,7 @@ $else
     $nothing
       ^{renderPrettyJSONSkylighting obj}
 
-    <form method=POST action=@{NotificationsR shr} enctype=#{enctype}>
+    <form method=POST action=@{NotificationsR} enctype=#{enctype}>
       ^{widget}
       <div class="submit">
         <input type="submit" value="Mark as read">

templates/person/widget/nav.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -15,30 +15,27 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 <div>
   <span>
   [[ 🧙
-  <a href=@{SharerR shr}>
+  <a href=@{PersonR personHash}>
-    #{shr2text shr}
+    ~#{username2text $ personUsername person}
   ]] ::
   <span>
-    <a href=@{SharerInboxR shr}>
+    <a href=@{PersonInboxR personHash}>
       [📥 Inbox]
   <span>
-    <a href=@{SharerOutboxR shr}>
+    <a href=@{PersonOutboxR personHash}>
       [📤 Outbox]
   <span>
-    <a href=@{SharerFollowersR shr}>
+    <a href=@{PersonFollowersR personHash}>
       [🐤 Followers]
   <span>
-    <a href=@{SharerFollowingR shr}>
+    <a href=@{PersonFollowingR personHash}>
       [🐔 Following]
   <span>
-    <a href=@{ProjectsR shr}>
+    <a href="">
       [🏗 Projects]
   <span>
-    <a href=@{ReposR shr}>
+    <a href="">
       [🗃 Repositories]
   <span>
-    <a href=@{WorkflowsR shr}>
+    <a href="">
       [🔁 Workflows]
-  <span>
-    <a href=@{SharerTicketsR shr}>
-      [🐛 Tickets]

templates/personal-overview.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -21,32 +21,3 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <li>
     <a href=@{PublishR}>
       Publish an activity
-  <li>
-    <p>Projects:
-    <ul>
-      $forall project <- projects
-        <li>
-          <a href=@{ProjectR ident project}>#{prj2text project}
-      <li>
-        <a href=@{ProjectNewR ident}>Create new…
-
-  <li>
-    <p>Standalone repos:
-    <ul>
-      $forall repo <- repos
-        <li>
-          <a href=@{RepoR ident repo}>#{rp2text repo}
-      <li>
-        <a href=@{RepoNewR ident}>Create new…
-
-  <li>
-    <a href=@{SharerInboxR ident}>Inbox
-
-  <li>
-    <a href=@{KeysR}>SSH keys
-
-  <li>
-    <a href=@{ProjectRolesR ident}>Roles
-
-  <li>
-    <a href=@{ClaimRequestsPersonR}>Ticket claim requests

templates/project/one.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -14,15 +14,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <div>
   <span>
-    $maybe name <- projectName project
+    #{actorName actor}
-      #{name}
+  -
-    $nothing
+  <span>
-      #{prj2text proj}
+    #{actorDesc actor}
-  $maybe desc <- projectDesc project
-    -
-    <span>#{desc}
 
-^{personNavW shar}
+^{personNavW $ Entity deckID deck}
 
 ^{projectNavW project workflow wsharer shar proj}
 

templates/repo/patch.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#

templates/repo/widget/changes.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018, 2020 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -18,11 +18,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Hash
     <th>Message
     <th>Time
-  $forall LogEntry author hash message (_, time) <- entries
+  $forall LogEntry author changeHash message (_, time) <- entries
     <tr>
       <td>#{author}
       <td .hash>
-        <a href=@{RepoCommitR shr rp hash}>
+        <a href=@{RepoCommitR hash changeHash}>
-          #{T.take 10 hash}
+          #{T.take 10 changeHash}
       <td>#{message}
       <td>#{time}

templates/repo/widget/ref-select.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -17,11 +17,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 <ul>
 $forall branch <- branches
   <li>
-    <a href=@{RepoSourceR shar repo [branch]}>#{branch}
+    <a href=@{RepoBranchSourceR hash branch []}>#{branch}
 
 <h2>Tags
 
 <ul>
 $forall tag <- tags
   <li>
-    <a href=@{RepoSourceR shar repo [tag]}>#{tag}
+    <a href=@{RepoBranchSourceR hash tag []}>#{tag}

templates/widget/actor-link.hamlet

@@ -13,14 +13,11 @@ $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 $case actor
-  $of MessageTreeNodeLocal _lmid s
+  $of MessageTreeNodeLocal _lmid pid
-    <a href=@{SharerR $ sharerIdent s}>
+    <a href=@{PersonR $ hashPerson pid}>
-      $maybe name <- sharerName s
+      ~#{keyHashidText $ hashPerson pid}
-        #{name}
-      $nothing
-        #{shr2text $ sharerIdent s}
     <span>
-      ./s/#{shr2text $ sharerIdent s}
+      ./people/#{keyHashidText $ hashPerson pid}
   $of MessageTreeNodeRemote h _luMsg luAuthor mname
     <a href="#{renderObjURI $ ObjURI h luAuthor}">
       $maybe name <- mname

th/models

@@ -13,9 +13,9 @@
 -- with this software. If not, see
 -- <http://creativecommons.org/publicdomain/zero/1.0/>.
 
--------------------------------------------------------------------------------
+-- ========================================================================= --
--- Instances
+-- Remote Object
--------------------------------------------------------------------------------
+-- ========================================================================= --
 
 Instance
     host Host
@@ -28,8 +28,81 @@ RemoteObject
 
     UniqueRemoteObject instance ident
 
+RemoteActivity
+    ident    RemoteObjectId
+    content  PersistJSONObject
+    received UTCTime
+
+    UniqueRemoteActivity ident
+
+UnfetchedRemoteActor
+    ident RemoteObjectId
+    since UTCTime Maybe
+
+    UniqueUnfetchedRemoteActor ident
+
+RemoteActor
+    ident      RemoteObjectId
+    name       Text Maybe
+    inbox      LocalURI
+    followers  LocalURI       Maybe
+    errorSince UTCTime        Maybe
+
+    UniqueRemoteActor ident
+
+RemoteCollection
+    ident RemoteObjectId
+
+    UniqueRemoteCollection ident
+
+-- ========================================================================= --
+-- Local Actor
+-- ========================================================================= --
+
 -------------------------------------------------------------------------------
--- People
+-- Outbox
+-------------------------------------------------------------------------------
+
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime
+
+-------------------------------------------------------------------------------
+-- Inbox
+-------------------------------------------------------------------------------
+
+Inbox
+
+InboxItem
+    unread Bool
+
+InboxItemLocal
+    inbox    InboxId
+    activity OutboxItemId
+    item     InboxItemId
+
+    UniqueInboxItemLocal     inbox activity
+    UniqueInboxItemLocalItem item
+
+InboxItemRemote
+    inbox    InboxId
+    activity RemoteActivityId
+    item     InboxItemId
+
+    UniqueInboxItemRemote     inbox activity
+    UniqueInboxItemRemoteItem item
+
+-------------------------------------------------------------------------------
+-- Followers
+-------------------------------------------------------------------------------
+
+FollowerSet
+
+-------------------------------------------------------------------------------
+-- Actors
 -------------------------------------------------------------------------------
 
 Actor
@@ -44,15 +117,8 @@ Actor
     UniqueActorOutbox    outbox
     UniqueActorFollowers followers
 
-Sharer
-    ident   ShrIdent
-    name    Text     Maybe
-    created UTCTime
-
-    UniqueSharer ident
-
 Person
-    ident               SharerId
+    username            Username
     login               Text
     passphraseHash      ByteString
     email               EmailAddress
@@ -61,52 +127,17 @@ Person
     verifiedKeyCreated  UTCTime
     resetPassKey        Text
     resetPassKeyCreated UTCTime
-    about               Text
+    actor               ActorId
-    inbox               InboxId
+--  reviewFollow        Bool
-    outbox              OutboxId
-    followers           FollowerSetId
 
-    UniquePersonIdent ident
+    UniquePersonUsername username
-    UniquePersonLogin login
+    UniquePersonLogin    login
-    UniquePersonEmail email
+    UniquePersonEmail    email
-    UniquePersonInbox inbox
+    UniquePersonActor    actor
-    UniquePersonOutbox outbox
-    UniquePersonFollowers followers
 
-Outbox
+-- ========================================================================= --
-
+-- Delivery
-OutboxItem
+-- ========================================================================= --
-    outbox    OutboxId
-    activity  PersistJSONObject
-    published UTCTime
-
-Inbox
-
-InboxItem
-    unread Bool
-
-InboxItemLocal
-    inbox    InboxId
-    activity OutboxItemId
-    item     InboxItemId
-
-    UniqueInboxItemLocal inbox activity
-    UniqueInboxItemLocalItem item
-
-RemoteActivity
-    ident    RemoteObjectId
-    content  PersistJSONObject
-    received UTCTime
-
-    UniqueRemoteActivity ident
-
-InboxItemRemote
-    inbox    InboxId
-    activity RemoteActivityId
-    item     InboxItemId
-
-    UniqueInboxItemRemote inbox activity
-    UniqueInboxItemRemoteItem item
 
 UnlinkedDelivery
     recipient  UnfetchedRemoteActorId
@@ -133,17 +164,17 @@ Forwarding
 
     UniqueForwarding recipient activity
 
-ForwarderSharer
+ForwarderPerson
     task   ForwardingId
-    sender SharerId
+    sender PersonId
 
-    UniqueForwarderSharer task
+    UniqueForwarderPerson task
 
-ForwarderProject
+ForwarderGroup
     task   ForwardingId
-    sender ProjectId
+    sender GroupId
 
-    UniqueForwarderProject task
+    UniqueForwarderGroup task
 
 ForwarderRepo
     task   ForwardingId
@@ -151,6 +182,25 @@ ForwarderRepo
 
     UniqueForwarderRepo task
 
+ForwarderLoom
+    task   ForwardingId
+    sender LoomId
+
+    UniqueForwarderLoom task
+
+ForwarderDeck
+    task   ForwardingId
+    sender DeckId
+
+    UniqueForwarderDeck task
+
+-- ========================================================================= --
+-- ========================================================================= --
+
+-------------------------------------------------------------------------------
+-- People
+-------------------------------------------------------------------------------
+
 VerifKey
     ident    LocalRefURI
     instance InstanceId
@@ -166,25 +216,12 @@ VerifKeySharedUsage
 
     UniqueVerifKeySharedUsage key user
 
-UnfetchedRemoteActor
+--RemoteFollowRequest
-    ident RemoteObjectId
+--    actor  RemoteActorId
-    since UTCTime Maybe
+--    target PersonId
-
+--
-    UniqueUnfetchedRemoteActor ident
+--    UniqueRemoteFollowRequest actor target
-
+--
-RemoteActor
-    ident      RemoteObjectId
-    name       Text Maybe
-    inbox      LocalURI
-    followers  LocalURI       Maybe
-    errorSince UTCTime        Maybe
-
-    UniqueRemoteActor ident
-
-RemoteCollection
-    ident RemoteObjectId
-
-    UniqueRemoteCollection ident
 
 FollowRemoteRequest
     person   PersonId
@@ -197,27 +234,31 @@ FollowRemoteRequest
     UniqueFollowRemoteRequestActivity activity
 
 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
+    UniqueFollowRemote       actor target
     UniqueFollowRemoteFollow follow
     UniqueFollowRemoteAccept accept
 
-FollowerSet
+--FollowRequest
+--    person PersonId
+--    target FollowerSetId
+--
+--    UniqueFollowRequest person target
 
 Follow
-    person PersonId
+    actor  ActorId
     target FollowerSetId
     public Bool
     follow OutboxItemId
     accept OutboxItemId
 
-    UniqueFollow person target
+    UniqueFollow       actor target
     UniqueFollowFollow follow
     UniqueFollowAccept accept
 
@@ -241,9 +282,9 @@ SshKey
     UniqueSshKey person ident
 
 Group
-    ident SharerId
+    actor ActorId
 
-    UniqueGroup ident
+    UniqueGroupActor actor
 
 GroupMember
     person PersonId
@@ -253,13 +294,12 @@ GroupMember
 
     UniqueGroupMember person group
 
+-- I'm removing the 'sharer' field, so all roles are now public for everyone to
+-- use! This is temporary, until I figure out a sane plan for federated roles
 Role
     ident  RlIdent
-    sharer SharerId
     desc   Text
 
-    UniqueRole sharer ident
-
 RoleInherit
     parent RoleId
     child  RoleId
@@ -276,12 +316,8 @@ RoleAccess
 -- Projects
 -------------------------------------------------------------------------------
 
-Project
+Deck
     actor      ActorId
-    ident      PrjIdent
-    sharer     SharerId
-    name       Text          Maybe
-    desc       Text          Maybe
     workflow   WorkflowId
     nextTicket Int
     wiki       RepoId        Maybe
@@ -289,37 +325,40 @@ Project
     collabAnon RoleId        Maybe
     create     OutboxItemId
 
-    UniqueProjectActor  actor
+    UniqueDeckActor  actor
-    UniqueProjectCreate create
+    UniqueDeckCreate create
-    UniqueProject ident sharer
+
+Loom
+    nextTicket Int
+    actor      ActorId
+    repo       RepoId
+    create     OutboxItemId
+
+    UniqueLoomActor  actor
+    UniqueLoomRepo   repo
+    UniqueLoomCreate create
 
 Repo
-    ident      RpIdent
-    sharer     SharerId
     vcs        VersionControlSystem
-    project    ProjectId            Maybe
+    project    DeckId               Maybe
-    desc       Text                 Maybe
     mainBranch Text
     collabUser RoleId               Maybe
     collabAnon RoleId               Maybe
-    inbox      InboxId
+    actor      ActorId
-    outbox     OutboxId
+    create     OutboxItemId
-    followers  FollowerSetId
 
-    UniqueRepo ident sharer
+    UniqueRepoActor  actor
-    UniqueRepoInbox inbox
+    UniqueRepoCreate create
-    UniqueRepoOutbox outbox
-    UniqueRepoFollowers followers
 
+-- I removed the 'sharer' field so Workflows don't specify who controls them
+-- For now there's no way to create new ones, and what's already in the DB can
+-- be publicly experimented with, until I make a plan for federated workflows
 Workflow
-    sharer SharerId
     ident  WflIdent
     name   Text          Maybe
     desc   Text          Maybe
     scope  WorkflowScope
 
-    UniqueWorkflow sharer ident
-
 WorkflowField
     workflow     WorkflowId
     ident        FldIdent
@@ -377,69 +416,37 @@ Ticket
     title       Text                -- HTML
     source      Text                -- Pandoc Markdown
     description Text                -- HTML
-    assignee    PersonId      Maybe
     status      TicketStatus
+    discuss     DiscussionId
+    followers   FollowerSetId
+    accept      OutboxItemId
 
     -- UniqueTicket project number
+    UniqueTicketDiscuss   discuss
+    UniqueTicketFollowers followers
+    UniqueTicketAccept    accept
 
-LocalTicket
+TicketAssignee
-    ticket    TicketId
+    ticket TicketId
-    discuss   DiscussionId
+    person PersonId
-    followers FollowerSetId
 
-    UniqueLocalTicket           ticket
+    UniqueTicketAssignee ticket person
-    UniqueLocalTicketDiscussion discuss
-    UniqueLocalTicketFollowers  followers
 
-RemoteTicket
+TicketDeck
-    ticket  TicketAuthorRemoteId
+    ticket TicketId
-    ident   RemoteObjectId
+    deck   DeckId
-    discuss RemoteDiscussionId
 
-    UniqueRemoteTicket        ticket
+    UniqueTicketDeck ticket
-    UniqueRemoteTicketIdent   ident
-    UniqueRemoteTicketDiscuss discuss
 
-TicketContextLocal
+TicketLoom
-    ticket  TicketId
+    ticket TicketId
-    accept  OutboxItemId
+    loom   LoomId
+    branch Text     Maybe
 
-    UniqueTicketContextLocal       ticket
+    UniqueTicketLoom ticket
-    UniqueTicketContextLocalAccept accept
-
-TicketProjectLocal
-    context TicketContextLocalId
-    project ProjectId
-
-    UniqueTicketProjectLocal context
-
-TicketRepoLocal
-    context TicketContextLocalId
-    repo    RepoId
-    branch  Text Maybe
-
-    UniqueTicketRepoLocal context
-
-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
-
-TicketProjectRemoteAccept
-    ticket   TicketProjectRemoteId
-    activity RemoteActivityId
-    accept   Bool
-    result   LocalURI Maybe
-
-    UniqueTicketProjectRemoteAccept         ticket
-    UniqueTicketProjectRemoteAcceptActivity activity
 
 TicketAuthorLocal
-    ticket LocalTicketId
+    ticket TicketId
     author PersonId
     open   OutboxItemId
 
@@ -447,22 +454,15 @@ TicketAuthorLocal
     UniqueTicketAuthorLocalOpen open
 
 TicketAuthorRemote
-    ticket TicketContextLocalId
+    ticket TicketId
     author RemoteActorId
     open   RemoteActivityId
 
     UniqueTicketAuthorRemote     ticket
     UniqueTicketAuthorRemoteOpen open
 
-TicketUnderProject
-    project TicketContextLocalId
-    author  TicketAuthorLocalId
-
-    UniqueTicketUnderProjectProject project
-    UniqueTicketUnderProjectAuthor  author
-
 Bundle
-    ticket TicketId
+    ticket TicketLoomId
 
 Patch
     bundle  BundleId
@@ -470,28 +470,24 @@ Patch
     type    PatchMediaType
     content Text
 
-TicketDependencyOffer
-    offer InboxItemId
-    child LocalTicketId
-
-    UniqueTicketDependencyOffer offer
-
 RemoteTicketDependency
     ident  RemoteObjectId
-    child  LocalTicketId
+    child  TicketId
     accept RemoteActivityId
 
-    UniqueRemoteTicketDependency ident
+    UniqueRemoteTicketDependency       ident
     UniqueRemoteTicketDependencyAccept accept
 
 LocalTicketDependency
-    parent  LocalTicketId
+    parent  TicketId
     created UTCTime
     accept  OutboxItemId
 
+    UniqueLocalTicketDependencyAccept accept
+
 TicketDependencyChildLocal
     dep   LocalTicketDependencyId
-    child LocalTicketId
+    child TicketId
 
     UniqueTicketDependencyChildLocal dep
 
@@ -526,7 +522,7 @@ TicketClaimRequest
     UniqueTicketClaimRequest person ticket
 
 TicketResolve
-    ticket LocalTicketId
+    ticket TicketId
     accept OutboxItemId
 
     UniqueTicketResolve ticket
@@ -604,11 +600,17 @@ CollabTopicLocalRepo
 
     UniqueCollabTopicLocalRepo collab
 
-CollabTopicLocalProject
+CollabTopicLocalDeck
-    collab  CollabId
+    collab CollabId
-    project ProjectId
+    deck   DeckId
 
-    UniqueCollabTopicLocalProject collab
+    UniqueCollabTopicLocalDeck collab
+
+CollabTopicLocalLoom
+    collab CollabId
+    loom   LoomId
+
+    UniqueCollabTopicLocalLoom collab
 
 CollabTopicRemote
     collab CollabId
@@ -654,3 +656,24 @@ CollabFulfillsLocalTopicCreation
     collab CollabId
 
     UniqueCollabFulfillsLocalTopicCreation collab
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+--RepoRemoteCollab
+--    repo   RepoId
+--    collab RemoteActorId
+--    role   RoleId        Maybe
+--    cap    Text
+--
+--    UniqueRepoRemoteCollab    repo collab
+--    UniqueRepoRemoteCollabCap cap
+--
+--ProjectRemoteCollab
+--    project DeckId
+--    collab  RemoteActorId
+--    role    RoleId        Maybe
+--    cap     Text
+--
+--    UniqueProjectRemoteCollab    project person
+--    UniqueProjectRemoteCollabCap cap

th/routes

@@ -17,205 +17,260 @@
 -- Yesod misc
 -- ----------------------------------------------------------------------------
 
-/static                                      StaticR           Static appStatic
+-- /highlight/#Text/style.css                   HighlightStyleR   GET
-/favicon.svg                                 FaviconSvgR       GET
-/favicon.png                                 FaviconPngR       GET
-/robots.txt                                  RobotsR           GET
-
-/highlight/#Text/style.css                   HighlightStyleR   GET
 
 -- ----------------------------------------------------------------------------
 -- Internal
 -- ----------------------------------------------------------------------------
 
-/post-receive                                PostReceiveR      POST
 
 -- ----------------------------------------------------------------------------
 -- Federation
 -- ----------------------------------------------------------------------------
 
-/publish                                     PublishR          GET POST
-/inbox                                       InboxDebugR       GET
-/akey1                                       ActorKey1R        GET
-/akey2                                       ActorKey2R        GET
 
 -- ----------------------------------------------------------------------------
 -- Current user
 -- ----------------------------------------------------------------------------
 
-/                                            HomeR                GET
+-- /k                                           KeysR                GET POST
+-- /k/!new                                      KeyNewR              GET
+-- /k/#KyIdent                                  KeyR                 GET DELETE POST
 
-/auth/!resend                                ResendVerifyEmailR   GET
+-- /cr                                          ClaimRequestsPersonR GET
-/auth                                        AuthR                Auth getAuth
-/oauth                                       DvaraR               Dvara getDvara
-
-/k                                           KeysR                GET POST
-/k/!new                                      KeyNewR              GET
-/k/#KyIdent                                  KeyR                 GET DELETE POST
-
-/cr                                          ClaimRequestsPersonR GET
 
 -- ----------------------------------------------------------------------------
 -- People
 -- ----------------------------------------------------------------------------
 
-/s                                           SharersR             GET
+-- /g/!new                                      GroupNewR            GET
-/s/#ShrIdent                                 SharerR              GET
+-- /g/#ShrIdent/m                               GroupMembersR        GET POST
-/s/#ShrIdent/inbox                           SharerInboxR         GET POST
+-- /g/#ShrIdent/m/!new                          GroupMemberNewR      GET
-/s/#ShrIdent/notifications                   NotificationsR       GET POST
+-- /g/#ShrIdent/m/#ShrIdent                     GroupMemberR         GET DELETE POST
-/s/#ShrIdent/outbox                          SharerOutboxR        GET POST
-/s/#ShrIdent/outbox/#OutboxItemKeyHashid     SharerOutboxItemR    GET
-/s/#ShrIdent/followers                       SharerFollowersR     GET
-/s/#ShrIdent/following                       SharerFollowingR     GET
-/s/#ShrIdent/follow                          SharerFollowR        POST
-/s/#ShrIdent/unfollow                        SharerUnfollowR      POST
 
-/s/#ShrIdent/k/#SshKeyKeyHashid              SshKeyR              GET
+-- /s/#ShrIdent/pr                              ProjectRolesR        GET POST
-
+-- /s/#ShrIdent/pr/!new                         ProjectRoleNewR      GET
-/p                                           PeopleR              GET
+-- /s/#ShrIdent/pr/#RlIdent                     ProjectRoleR         GET DELETE POST
-
+-- /s/#ShrIdent/pr/#RlIdent/a                   ProjectRoleOpsR      GET POST
-/g                                           GroupsR              GET POST
+-- /s/#ShrIdent/pr/#RlIdent/a/!new              ProjectRoleOpNewR    GET
-/g/!new                                      GroupNewR            GET
-/g/#ShrIdent/m                               GroupMembersR        GET POST
-/g/#ShrIdent/m/!new                          GroupMemberNewR      GET
-/g/#ShrIdent/m/#ShrIdent                     GroupMemberR         GET DELETE POST
-
-/s/#ShrIdent/pr                              ProjectRolesR        GET POST
-/s/#ShrIdent/pr/!new                         ProjectRoleNewR      GET
-/s/#ShrIdent/pr/#RlIdent                     ProjectRoleR         GET DELETE POST
-/s/#ShrIdent/pr/#RlIdent/a                   ProjectRoleOpsR      GET POST
-/s/#ShrIdent/pr/#RlIdent/a/!new              ProjectRoleOpNewR    GET
 
 -- ----------------------------------------------------------------------------
 -- Projects
 -- ----------------------------------------------------------------------------
 
-/browse                                      BrowseR               GET
+-- /s/#ShrIdent/r                               ReposR                GET
 
-/s/#ShrIdent/r                               ReposR                GET POST
+-- /s/#ShrIdent/p/#PrjIdent/tcr                 ClaimRequestsProjectR GET
-/s/#ShrIdent/r/!new                          RepoNewR              GET
-/s/#ShrIdent/r/#RpIdent                      RepoR                 GET PUT DELETE POST
-/s/#ShrIdent/r/#RpIdent/inbox                RepoInboxR            GET POST
-/s/#ShrIdent/r/#RpIdent/outbox                      RepoOutboxR     GET
-/s/#ShrIdent/r/#RpIdent/outbox/#OutboxItemKeyHashid RepoOutboxItemR GET
-/s/#ShrIdent/r/#RpIdent/team                 RepoTeamR             GET
-/s/#ShrIdent/r/#RpIdent/followers            RepoFollowersR        GET
-/s/#ShrIdent/r/#RpIdent/edit                 RepoEditR             GET
-/s/#ShrIdent/r/#RpIdent/follow               RepoFollowR           POST
-/s/#ShrIdent/r/#RpIdent/unfollow             RepoUnfollowR         POST
-/s/#ShrIdent/r/#RpIdent/s/+Texts             RepoSourceR           GET
-/s/#ShrIdent/r/#RpIdent/c                    RepoHeadChangesR      GET
-/s/#ShrIdent/r/#RpIdent/b/#Text              RepoBranchR           GET
-/s/#ShrIdent/r/#RpIdent/c/#Text              RepoChangesR          GET
-/s/#ShrIdent/r/#RpIdent/p/#Text              RepoCommitR           GET
-/s/#ShrIdent/r/#RpIdent/d                    RepoDevsR             GET POST
-/s/#ShrIdent/r/#RpIdent/d/!new               RepoDevNewR           GET
-/s/#ShrIdent/r/#RpIdent/d/#ShrIdent          RepoDevR              GET DELETE POST
-
-/s/#ShrIdent/r/#RpIdent/mr                                 RepoProposalsR        GET
-
-/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid           RepoProposalR            GET
-/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/d         RepoProposalDiscussionR  GET
-/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/deps      RepoProposalDepsR        GET
-/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/rdeps     RepoProposalReverseDepsR GET
-/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/followers RepoProposalFollowersR   GET
-/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/events    RepoProposalEventsR      GET
-
-/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/b/#BundleKeyHashid RepoProposalBundleR GET
-/s/#ShrIdent/r/#RpIdent/mr/#LocalTicketKeyHashid/b/#BundleKeyHashid/pt/#PatchKeyHashid RepoProposalBundlePatchR GET
-
-/s/#ShrIdent/r/#RpIdent/_darcs/+Texts        DarcsDownloadR        GET
-
-/s/#ShrIdent/r/#RpIdent/info/refs            GitRefDiscoverR       GET
-/s/#ShrIdent/r/#RpIdent/git-upload-pack      GitUploadRequestR     POST
-
-/s/#ShrIdent/p                               ProjectsR             GET POST
-/s/#ShrIdent/p/!new                          ProjectNewR           GET
-/s/#ShrIdent/p/#PrjIdent                     ProjectR              GET PUT POST
-/s/#ShrIdent/p/#PrjIdent/inbox               ProjectInboxR         GET POST
-/s/#ShrIdent/p/#PrjIdent/outbox                      ProjectOutboxR     GET
-/s/#ShrIdent/p/#PrjIdent/outbox/#OutboxItemKeyHashid ProjectOutboxItemR GET
-/s/#ShrIdent/p/#PrjIdent/team                ProjectTeamR          GET
-/s/#ShrIdent/p/#PrjIdent/followers           ProjectFollowersR     GET
-/s/#ShrIdent/p/#PrjIdent/edit                ProjectEditR          GET
-/s/#ShrIdent/p/#PrjIdent/follow              ProjectFollowR        POST
-/s/#ShrIdent/p/#PrjIdent/unfollow            ProjectUnfollowR      POST
-/s/#ShrIdent/p/#PrjIdent/d                   ProjectDevsR          GET POST
-/s/#ShrIdent/p/#PrjIdent/d/!new              ProjectDevNewR        GET
-/s/#ShrIdent/p/#PrjIdent/d/#ShrIdent         ProjectDevR           GET DELETE POST
-
-/s/#ShrIdent/p/#PrjIdent/tcr                 ClaimRequestsProjectR GET
 
 -- /w                                           GlobalWorkflowsR      GET POST
 -- /w/!new                                      GlobalWorkflowNewR    GET
 -- /w/#WflIdent                                 GlobalWorkflowR       GET DELETE POST
 
-/s/#ShrIdent/w                               WorkflowsR            GET POST
+-- /s/#ShrIdent/w                               WorkflowsR            GET POST
-/s/#ShrIdent/w/!new                          WorkflowNewR          GET
+-- /s/#ShrIdent/w/!new                          WorkflowNewR          GET
-/s/#ShrIdent/w/#WflIdent                     WorkflowR             GET DELETE POST
+-- /s/#ShrIdent/w/#WflIdent                     WorkflowR             GET DELETE POST
-/s/#ShrIdent/w/#WflIdent/f                   WorkflowFieldsR       GET POST
+-- /s/#ShrIdent/w/#WflIdent/f                   WorkflowFieldsR       GET POST
-/s/#ShrIdent/w/#WflIdent/f/!new              WorkflowFieldNewR     GET
+-- /s/#ShrIdent/w/#WflIdent/f/!new              WorkflowFieldNewR     GET
-/s/#ShrIdent/w/#WflIdent/f/#FldIdent         WorkflowFieldR        GET DELETE POST
+-- /s/#ShrIdent/w/#WflIdent/f/#FldIdent         WorkflowFieldR        GET DELETE POST
-/s/#ShrIdent/w/#WflIdent/e                   WorkflowEnumsR        GET POST
+-- /s/#ShrIdent/w/#WflIdent/e                   WorkflowEnumsR        GET POST
-/s/#ShrIdent/w/#WflIdent/e/!new              WorkflowEnumNewR      GET
+-- /s/#ShrIdent/w/#WflIdent/e/!new              WorkflowEnumNewR      GET
-/s/#ShrIdent/w/#WflIdent/e/#EnmIdent         WorkflowEnumR         GET DELETE POST
+-- /s/#ShrIdent/w/#WflIdent/e/#EnmIdent         WorkflowEnumR         GET DELETE POST
-/s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c       WorkflowEnumCtorsR    GET POST
+-- /s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c       WorkflowEnumCtorsR    GET POST
-/s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c/!new  WorkflowEnumCtorNewR  GET
+-- /s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c/!new  WorkflowEnumCtorNewR  GET
-/s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c/#Text WorkflowEnumCtorR     PUT DELETE POST
+-- /s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c/#Text WorkflowEnumCtorR     PUT DELETE POST
 
-/s/#ShrIdent/m/#LocalMessageKeyHashid        MessageR              GET
+-- /s/#ShrIdent/p/#PrjIdent/w/+Texts            WikiPageR             GET
 
-/tdeps/#TicketDepKeyHashid                   TicketDepR            GET
 
-/s/#ShrIdent/p/#PrjIdent/t                   ProjectTicketsR              GET POST
-/s/#ShrIdent/p/#PrjIdent/t/!tree             ProjectTicketTreeR           GET
-/s/#ShrIdent/p/#PrjIdent/t/!new              ProjectTicketNewR            GET
 
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid              ProjectTicketR               GET PUT DELETE POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/edit         ProjectTicketEditR           GET
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/accept       ProjectTicketAcceptR         POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/close        ProjectTicketCloseR          POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/open         ProjectTicketOpenR           POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/claim        ProjectTicketClaimR          POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/unclaim      ProjectTicketUnclaimR        POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/assign       ProjectTicketAssignR         GET POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/unassign     ProjectTicketUnassignR       POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/follow       ProjectTicketFollowR         POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/unfollow     ProjectTicketUnfollowR       POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/cr           ClaimRequestsTicketR  GET POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/cr/new       ClaimRequestNewR      GET
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/d            ProjectTicketDiscussionR     GET POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/d/!reply     ProjectTicketTopReplyR       GET
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/d/#MessageKeyHashid ProjectTicketMessageR        POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/d/#MessageKeyHashid/reply ProjectTicketReplyR          GET
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/deps         ProjectTicketDepsR           GET POST
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/deps/!new    ProjectTicketDepNewR         GET
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/deps/#LocalTicketKeyHashid TicketDepOldR            POST DELETE
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/rdeps        ProjectTicketReverseDepsR    GET
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/participants ProjectTicketParticipantsR   GET
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/team         ProjectTicketTeamR           GET
-/s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/events       ProjectTicketEventsR         GET
 
-/s/#ShrIdent/t                               SharerTicketsR        GET
 
-/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid   SharerTicketR         GET
-/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/d         SharerTicketDiscussionR     GET
-/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/deps      SharerTicketDepsR           GET
-/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/rdeps     SharerTicketReverseDepsR    GET
-/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/followers SharerTicketFollowersR      GET
-/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/team      SharerTicketTeamR           GET
-/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/events    SharerTicketEventsR         GET
 
-/s/#ShrIdent/mr                                       SharerProposalsR          GET
 
-/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid           SharerProposalR            GET
-/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/d         SharerProposalDiscussionR  GET
-/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/deps      SharerProposalDepsR        GET
-/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/rdeps     SharerProposalReverseDepsR GET
-/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/followers SharerProposalFollowersR   GET
-/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/events    SharerProposalEventsR      GET
 
-/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/b/#BundleKeyHashid SharerProposalBundleR GET
-/s/#ShrIdent/mr/#TicketAuthorLocalKeyHashid/b/#BundleKeyHashid/pt/#PatchKeyHashid SharerProposalBundlePatchR GET
 
-/s/#ShrIdent/p/#PrjIdent/w/+Texts            WikiPageR             GET
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+------------------------------------------------------------------------------
+-- New route structure
+------------------------------------------------------------------------------
+
+---- Static Files ------------------------------------------------------------
+
+/static      StaticR     Static appStatic
+/favicon.svg FaviconSvgR GET
+/favicon.png FaviconPngR GET
+/robots.txt  RobotsR     GET
+
+---- Authentication ----------------------------------------------------------
+
+/auth/!resend ResendVerifyEmailR GET
+/auth         AuthR              Auth  getAuth
+/oauth        DvaraR             Dvara getDvara
+/akey1        ActorKey1R         GET
+/akey2        ActorKey2R         GET
+
+---- Client ------------------------------------------------------------------
+
+/              HomeR          GET
+/browse        BrowseR        GET
+/notifications NotificationsR GET POST
+/publish       PublishR       GET POST
+/inbox         InboxDebugR    GET
+
+---- Person ------------------------------------------------------------------
+
+/people/#PersonKeyHashid                                 PersonR           GET
+/people/#PersonKeyHashid/inbox                           PersonInboxR      GET POST
+/people/#PersonKeyHashid/outbox                          PersonOutboxR     GET POST
+/people/#PersonKeyHashid/outbox/#OutboxItemKeyHashid     PersonOutboxItemR GET
+/people/#PersonKeyHashid/followers                       PersonFollowersR  GET
+/people/#PersonKeyHashid/following                       PersonFollowingR  GET
+
+/people/#PersonKeyHashid/ssh-keys/#SshKeyKeyHashid       SshKeyR           GET
+
+/people/#PersonKeyHashid/messages/#LocalMessageKeyHashid PersonMessageR    GET
+
+/people/#PersonKeyHashid/follow                          PersonFollowR     POST
+/people/#PersonKeyHashid/unfollow                        PersonUnfollowR   POST
+
+---- Group ------------------------------------------------------------------
+
+/groups/#GroupKeyHashid                                 GroupR           GET
+/groups/#GroupKeyHashid/inbox                           GroupInboxR      GET POST
+/groups/#GroupKeyHashid/outbox                          GroupOutboxR     GET
+/groups/#GroupKeyHashid/outbox/#OutboxItemKeyHashid     GroupOutboxItemR GET
+/groups/#GroupKeyHashid/followers                       GroupFollowersR  GET
+
+---- Repo --------------------------------------------------------------------
+
+/repos/#RepoKeyHashid                             RepoR              GET
+/repos/#RepoKeyHashid/inbox                       RepoInboxR         GET POST
+/repos/#RepoKeyHashid/outbox                      RepoOutboxR        GET
+/repos/#RepoKeyHashid/outbox/#OutboxItemKeyHashid RepoOutboxItemR    GET
+/repos/#RepoKeyHashid/followers                   RepoFollowersR     GET
+
+/repos/#RepoKeyHashid/_darcs/+Texts               DarcsDownloadR     GET
+/repos/#RepoKeyHashid/info/refs                   GitRefDiscoverR    GET
+/repos/#RepoKeyHashid/git-upload-pack             GitUploadRequestR  POST
+
+/repos/#RepoKeyHashid/source/+Texts               RepoSourceR        GET
+/repos/#RepoKeyHashid/source-by/#Text/+Texts      RepoBranchSourceR  GET
+/repos/#RepoKeyHashid/commits                     RepoCommitsR       GET
+/repos/#RepoKeyHashid/commits-by/#Text            RepoBranchCommitsR GET
+/repos/#RepoKeyHashid/commits/#Text               RepoCommitR        GET
+
+/new-repo                                         RepoNewR           GET POST
+/repos/#RepoKeyHashid/delete                      RepoDeleteR        POST
+/repos/#RepoKeyHashid/edit                        RepoEditR          GET POST
+/repos/#RepoKeyHashid/follow                      RepoFollowR        POST
+/repos/#RepoKeyHashid/unfollow                    RepoUnfollowR      POST
+
+/post-receive                                     PostReceiveR       POST
+
+---- Deck --------------------------------------------------------------------
+
+/decks/#DeckKeyHashid                             DeckR           GET
+/decks/#DeckKeyHashid/inbox                       DeckInboxR      GET POST
+/decks/#DeckKeyHashid/outbox                      DeckOutboxR     GET
+/decks/#DeckKeyHashid/outbox/#OutboxItemKeyHashid DeckOutboxItemR GET
+/decks/#DeckKeyHashid/followers                   DeckFollowersR  GET
+/decks/#DeckKeyHashid/tickets                     DeckTicketsR    GET
+
+/decks/#DeckKeyHashid/tree                        DeckTreeR       GET
+
+/new-deck                                         DeckNewR        GET POST
+/decks/#DeckKeyHashid/delete                      DeckDeleteR     POST
+/decks/#DeckKeyHashid/edit                        DeckEditR       GET POST
+/decks/#DeckKeyHashid/follow                      DeckFollowR     POST
+/decks/#DeckKeyHashid/unfollow                    DeckUnfollowR   POST
+
+---- Ticket ------------------------------------------------------------------
+
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid            TicketR            GET
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/discussion TicketDiscussionR  GET
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/events     TicketEventsR      GET
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/followers  TicketFollowersR   GET
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/deps       TicketDepsR        GET
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/rdeps      TicketReverseDepsR GET
+
+-- /decks/#DeckKeyHashid/new-ticket                           TicketNewR         GET POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/edit       TicketEditR        GET POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/delete     TicketDeleteR      POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/accept     TicketAcceptR      POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/close      TicketCloseR       POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/open       TicketOpenR        POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/claim      TicketClaimR       POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unclaim    TicketUnclaimR     POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/assign     TicketAssignR      GET POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unassign   TicketUnassignR    POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/follow     TicketFollowR      POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unfollow   TicketUnfollowR    POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/reply      TicketTopReplyR    GET POST
+
+---- Ticket Dependency -------------------------------------------------------
+
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/deps/#TicketDepKeyHashid        TicketDepR       GET
+
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/new-dep                         TicketDepNewR    GET POST
+-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/deps/#TicketDepKeyHashid/delete TicketDepDeleteR POST
+
+---- Loom --------------------------------------------------------------------
+
+/looms/#LoomKeyHashid                             LoomR           GET
+/looms/#LoomKeyHashid/inbox                       LoomInboxR      GET POST
+/looms/#LoomKeyHashid/outbox                      LoomOutboxR     GET
+/looms/#LoomKeyHashid/outbox/#OutboxItemKeyHashid LoomOutboxItemR GET
+/looms/#LoomKeyHashid/followers                   LoomFollowersR  GET
+/looms/#LoomKeyHashid/cloths                      LoomClothsR     GET
+
+-- /new-loom                                         LoomNewR        GET POST
+-- /looms/#LoomKeyHashid/delete                      LoomDeleteR     POST
+-- /looms/#LoomKeyHashid/edit                        LoomEditR       GET POST
+-- /looms/#LoomKeyHashid/follow                      LoomFollowR     POST
+-- /looms/#LoomKeyHashid/unfollow                    LoomUnfollowR   POST
+
+---- Cloth -------------------------------------------------------------------
+
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid            ClothR            GET
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/discussion ClothDiscussionR  GET
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/events     ClothEventsR      GET
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/followers  ClothFollowersR   GET
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/deps       ClothDepsR        GET
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/rdeps      ClothReverseDepsR GET
+
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/bundles/#BundleKeyHashid                         BundleR GET
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/bundles/#BundleKeyHashid/patches/#PatchKeyHashid PatchR  GET
+
+-- /looms/#LoomKeyHashid/new-cloth                           ClothNewR         GET POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/edit       ClothEditR        GET POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/delete     ClothDeleteR      POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/accept     ClothAcceptR      POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/close      ClothCloseR       POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/open       ClothOpenR        POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/claim      ClothClaimR       POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unclaim    ClothUnclaimR     POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/assign     ClothAssignR      GET POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unassign   ClothUnassignR    POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/follow     ClothFollowR      POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unfollow   ClothUnfollowR    POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply      ClothTopReplyR    GET POST
+
+---- Cloth Dependency --------------------------------------------------------
+
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/deps/#TicketDepKeyHashid        ClothDepR       GET
+
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/new-dep                         ClothDepNewR    GET POST
+-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/deps/#TicketDepKeyHashid/delete ClothDepDeleteR POST

vervis.cabal

@@ -49,6 +49,7 @@ library
                        Data.Aeson.Local
                        Data.Attoparsec.ByteString.Local
                        Data.Binary.Local
+                       -- Data.Bitraversable.Local
                        Data.ByteString.Char8.Local
                        Data.ByteString.Local
                        Data.CaseInsensitive.Local
@@ -102,6 +103,7 @@ library
                        Text.Jasmine.Local
                        Web.ActivityAccess
                        Web.ActivityPub
+                       -- Web.Capability
                        Web.Hashids.Local
                        Web.PathPieces.Local
                        Yesod.ActivityPub
@@ -118,7 +120,7 @@ library
 
                        Vervis.Access
                        Vervis.ActivityPub
-                       Vervis.ActivityPub.Recipient
+                       Vervis.Actor
                        Vervis.ActorKey
                        Vervis.API
                        Vervis.Application
@@ -126,58 +128,61 @@ library
                        Vervis.BinaryBody
                        Vervis.Changes
                        Vervis.ChangeFeed
-                       Vervis.Client
+                       --Vervis.Class.Actor
+                       --Vervis.Client
+                       Vervis.Cloth
                        Vervis.Colour
                        Vervis.Content
                        Vervis.Darcs
+                       Vervis.Delivery
                        Vervis.Discussion
                        Vervis.Federation
                        Vervis.Federation.Auth
-                       Vervis.Federation.Discussion
+                       --Vervis.Federation.Discussion
-                       Vervis.Federation.Offer
+                       --Vervis.Federation.Offer
-                       Vervis.Federation.Push
+                       --Vervis.Federation.Push
-                       Vervis.Federation.Ticket
+                       --Vervis.Federation.Ticket
                        Vervis.Federation.Util
                        Vervis.FedURI
-                       Vervis.Field.Key
+                       -- Vervis.Field.Key
                        Vervis.Field.Person
-                       Vervis.Field.Project
+                       --Vervis.Field.Project
-                       Vervis.Field.Repo
+                       --Vervis.Field.Repo
-                       Vervis.Field.Role
+                       --Vervis.Field.Role
-                       Vervis.Field.Sharer
+                       --Vervis.Field.Sharer
-                       Vervis.Field.Ticket
+                       --Vervis.Field.Ticket
-                       Vervis.Field.Workflow
+                       -- Vervis.Field.Workflow
                        Vervis.Form.Discussion
-                       Vervis.Form.Group
+                       --Vervis.Form.Group
-                       Vervis.Form.Key
+                       -- Vervis.Form.Key
-                       Vervis.Form.Project
+                       --Vervis.Form.Project
-                       Vervis.Form.Repo
+                       --Vervis.Form.Repo
-                       Vervis.Form.Role
+                       --Vervis.Form.Role
-                       Vervis.Form.Ticket
+                       --Vervis.Form.Ticket
-                       Vervis.Form.Workflow
+                       -- Vervis.Form.Workflow
                        Vervis.Formatting
                        Vervis.Foundation
                        Vervis.Git
                        Vervis.GraphProxy
                        Vervis.Handler.Client
+                       Vervis.Handler.Cloth
                        Vervis.Handler.Common
+                       Vervis.Handler.Deck
                        Vervis.Handler.Discussion
-                       Vervis.Handler.Git
+                       -- Vervis.Handler.Git
                        Vervis.Handler.Group
-                       Vervis.Handler.Home
+                       --Vervis.Handler.Inbox
-                       Vervis.Handler.Inbox
+                       --Vervis.Handler.Key
-                       Vervis.Handler.Key
+                       Vervis.Handler.Loom
-                       Vervis.Handler.Patch
                        Vervis.Handler.Person
-                       Vervis.Handler.Project
                        Vervis.Handler.Repo
-                       Vervis.Handler.Repo.Darcs
+                       --Vervis.Handler.Repo.Darcs
-                       Vervis.Handler.Repo.Git
+                       --Vervis.Handler.Repo.Git
-                       Vervis.Handler.Role
+                       --Vervis.Handler.Role
-                       Vervis.Handler.Sharer
+                       --Vervis.Handler.Sharer
                        Vervis.Handler.Ticket
-                       Vervis.Handler.Wiki
+                       -- Vervis.Handler.Wiki
-                       Vervis.Handler.Workflow
+                       -- Vervis.Handler.Workflow
                        Vervis.Hook
                        Vervis.KeyFile
                        Vervis.Migration
@@ -193,12 +198,13 @@ library
                        Vervis.Model.Workflow
                        Vervis.Paginate
                        Vervis.Palette
-                       Vervis.Patch
                        Vervis.Path
                        Vervis.Query
                        Vervis.Readme
+                       Vervis.Recipient
                        Vervis.RemoteActorStore
-                       Vervis.Role
+                       --Vervis.Repo
+                       --Vervis.Role
                        Vervis.Secure
                        Vervis.Settings
                        Vervis.Settings.StaticFiles
@@ -211,13 +217,13 @@ library
                        Vervis.Time
                        Vervis.Widget
                        Vervis.Widget.Discussion
-                       Vervis.Widget.Project
+                       Vervis.Widget.Person
+                       --Vervis.Widget.Project
                        Vervis.Widget.Repo
-                       Vervis.Widget.Role
+                       --Vervis.Widget.Role
-                       Vervis.Widget.Sharer
+                       --Vervis.Widget.Ticket
-                       Vervis.Widget.Ticket
+                       -- Vervis.Widget.Workflow
-                       Vervis.Widget.Workflow
+                       -- Vervis.Wiki
-                       Vervis.Wiki
                        Vervis.WorkItem
   -- other-modules:       
   default-extensions:  TemplateHaskell
@@ -244,6 +250,8 @@ library
                        -- for parsing commands sent over SSH and Darcs patch
                        -- metadata
                      , attoparsec
+                       -- For LocalActorBy and LocalStageBy
+                     , barbies
                      , base
                        -- for hex display of Darcs patch hashes
                      , base16-bytestring
@@ -399,7 +407,7 @@ library
 
   if flag(dev) || flag(library-only)
     cpp-options:       -DDEVELOPMENT
-    ghc-options:       -Wall -fwarn-tabs -O0 -Werror=incomplete-patterns
+    ghc-options:       -Wall -fwarn-tabs -O0 -Werror=incomplete-patterns -Werror=missing-fields
   else
     ghc-options:       -Wall -fwarn-tabs -O2