C2S: Rewrite createNoteC based on createTicketC

src/Database/Persist/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,10 +15,12 @@
 
 module Database.Persist.Local
     ( idAndNew
+    , valAndNew
     , getKeyBy
     , getValBy
     , insertUnique_
     , insertBy'
+    , insertByEntity'
     )
 where
 
@@ -28,6 +30,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Bifunctor
 import Database.Persist
 
 import qualified Data.Text as T
@@ -36,6 +39,10 @@ idAndNew :: Either (Entity a) (Key a) -> (Key a, Bool)
 idAndNew (Left (Entity iid _)) = (iid, False)
 idAndNew (Right iid)           = (iid, True)
 
+valAndNew :: Either (Entity a) (Entity a) -> (a, Bool)
+valAndNew (Left (Entity _ val))  = (val, False)
+valAndNew (Right (Entity _ val)) = (val, True)
+
 getKeyBy
     :: ( MonadIO m
        , PersistRecordBackend record backend
@@ -80,3 +87,11 @@ insertBy' val = do
                 "insertBy': Couldn't insert but also couldn't get the value, \
                 \perhaps it was concurrently deleted or updated: " <>
                 T.pack (show $ map toPersistValue $ toPersistFields val)
+
+insertByEntity'
+    :: ( MonadIO m
+       , PersistUniqueWrite backend
+       , PersistRecordBackend record backend
+       )
+    => record -> ReaderT backend m (Either (Entity record) (Entity record))
+insertByEntity' val = second (flip Entity val) <$> insertBy' val

src/Vervis/API.hs

@@ -14,7 +14,8 @@
  -}
 
 module Vervis.API
-    ( createNoteC
+    ( noteC
+    , createNoteC
     , createTicketC
     , followC
     , offerTicketC
@@ -110,6 +111,7 @@ import Vervis.Model.Ident
 import Vervis.Model.Ticket
 import Vervis.RemoteActorStore
 import Vervis.Settings
+import Vervis.Ticket
 
 verifyIsLoggedInUser
     :: LocalURI
@@ -147,35 +149,213 @@ parseComment luParent = do
         MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
         _                -> throwE "Not a local message route"
 
+data NoteContext
+    = NoteContextSharerTicket ShrIdent TicketAuthorLocalId
+    | NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
+    deriving Eq
+
+noteC
+    :: Entity Person
+    -> Sharer
+    -> Note URIMode
+    -> Handler (Either Text LocalMessageId)
+noteC person sharer note = do
+    let shrUser = sharerIdent sharer
+    summary <-
+        TextHtml . TL.toStrict . renderHtml <$>
+            withUrlRenderer
+                [hamlet|
+                    <p>
+                      <a href=@{SharerR shrUser}>#{shr2text shrUser}
+                      $maybe uContext <- noteContext note
+                        \ commented under a #
+                        <a href="#{renderObjURI uContext}">topic</a>.
+                      $nothing
+                        \ commented.
+                |]
+    createNoteC person sharer summary (noteAudience note) note
+
 -- | Handle a Note submitted by a local user to their outbox. It can be either
 -- a comment on a local ticket, or a comment on some remote context. Return an
 -- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
-createNoteC :: Host -> Note URIMode -> Handler (Either Text LocalMessageId)
+createNoteC
-createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do
+    :: Entity Person
-    verifyHostLocal host "Attributed to non-local actor"
+    -> Sharer
+    -> TextHtml
+    -> Audience URIMode
+    -> Note URIMode
+    -> Handler (Either Text LocalMessageId)
+createNoteC (Entity pidUser personUser) sharerUser summary audience note = runExceptT $ do
+    let shrUser = sharerIdent sharerUser
+    noteData@(muParent, mparent, uContext, context, source, content) <- checkNote shrUser note
+    (localRecips, remoteRecips) <- do
+        mrecips <- parseAudience audience
+        fromMaybeE mrecips "Create Note with no recipients"
+    checkFederation remoteRecips
+    verifyContextRecip context localRecips remoteRecips
+    now <- liftIO getCurrentTime
+    (lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
+        obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
+        (mproject, did, meparent) <- getTopicAndParent context mparent
+        lmid <- lift $ insertMessage now content source obiidCreate did meparent
+        docCreate <- lift $ insertCreateToOutbox now shrUser noteData obiidCreate lmid
+        remoteRecipsHttpCreate <- do
+            hashLT <- getEncodeKeyHashid
+            hashTAL <- getEncodeKeyHashid
+            let sieve =
+                    let actors =
+                            case mproject of
+                                Nothing -> []
+                                Just (shr, prj) -> [LocalActorProject shr prj]
+                        collections =
+                            let project =
+                                    case mproject of
+                                        Nothing -> []
+                                        Just (shr, prj) ->
+                                            [ LocalPersonCollectionProjectTeam shr prj
+                                            , LocalPersonCollectionProjectFollowers shr prj
+                                            ]
+                                ticket =
+                                    case context of
+                                        Left nc ->
+                                            case nc of
+                                                NoteContextSharerTicket shr talid ->
+                                                    let talkhid = hashTAL talid
+                                                    in  [ LocalPersonCollectionSharerTicketTeam shr talkhid
+                                                        , LocalPersonCollectionSharerTicketFollowers shr talkhid
+                                                        ]
+                                                NoteContextProjectTicket shr prj ltid ->
+                                                    let ltkhid = hashLT ltid
+                                                    in  [ LocalPersonCollectionProjectTicketTeam shr prj ltkhid
+                                                        , LocalPersonCollectionProjectTicketFollowers shr prj ltkhid
+                                                        ]
+                                        Right _ -> []
+                                commenter = [LocalPersonCollectionSharerFollowers shrUser]
+                            in  project ++ ticket ++ commenter
+                    in  makeRecipientSet actors collections
+            moreRemoteRecips <-
+                lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $
+                    localRecipSieve' sieve True False localRecips
+            checkFederation moreRemoteRecips
+            lift $ deliverRemoteDB' (objUriAuthority uContext) obiidCreate remoteRecips moreRemoteRecips
+        return (lmid, obiidCreate, docCreate, remoteRecipsHttpCreate)
+    lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
+    return lmid
+    where
+    checkNote shrUser (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do
         verifyNothingE mluNote "Note specifies an id"
+        encodeRouteLocal <- getEncodeRouteLocal
+        unless (encodeRouteLocal (SharerR shrUser) == luAttrib) $
+            throwE "Note attributed to someone else"
         verifyNothingE mpublished "Note specifies published"
         uContext <- fromMaybeE muContext "Note without context"
-    (mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent uContext muParent
+        context <- parseNoteContext uContext
-    federation <- getsYesod $ appFederation . appSettings
+        mparent <- checkParent context =<< traverse parseParent muParent
+        return (muParent, mparent, uContext, context, source, content)
+        where
+        parseTopic name route =
+            case route of
+                SharerTicketR shr talkhid ->
+                    NoteContextSharerTicket shr <$>
+                        decodeKeyHashidE
+                            talkhid
+                            (name <> " sharer ticket invalid talkhid")
+                ProjectTicketR shr prj ltkhid ->
+                    NoteContextProjectTicket shr prj <$>
+                        decodeKeyHashidE
+                            ltkhid
+                            (name <> " project ticket invalid ltkhid")
+                _ -> throwE $ name <> " isn't a discussion topic route"
+        parseNoteContext u@(ObjURI h lu) = do
+            hl <- hostIsLocal h
+            if hl
+                then Left <$> do
+                    route <-
+                        fromMaybeE
+                            (decodeRouteLocal lu)
+                            "Note context local but not a valid route"
+                    parseTopic "Note context" route
+                else return $ Right u
+        parseParent u@(ObjURI h lu) = do
+            hl <- hostIsLocal h
+            if hl
+                then Left <$> do
+                    route <-
+                        fromMaybeE
+                            (decodeRouteLocal lu)
+                            "Note parent local but not a valid route"
+                    Left <$> parseTopic "Note parent" route <|>
+                        Right <$> parseComment route
+                else return $ Right u
+            where
+            parseComment (MessageR shr lmkhid) =
+                (shr,) <$> decodeKeyHashidE lmkhid "Note parent invalid lmkhid"
+            parseComment _ = throwE "Note parent not a comment route"
+        checkParent _            Nothing                     = return Nothing
+        checkParent (Left topic) (Just (Left (Left topic'))) =
+            if topic == topic'
+                then return Nothing
+                else throwE "Note context and parent are different local topics"
+        checkParent _            (Just (Left (Right msg)))   = return $ Just $ Left msg
+        checkParent (Left _)     (Just (Right u))            = return $ Just $ Right u
+        checkParent (Right u)    (Just (Right u'))           =
+            return $
+                if u == u'
+                    then Nothing
+                    else Just $ Right u'
+    checkFederation remoteRecips = do
+        federation <- asksSite $ appFederation . appSettings
         unless (federation || null remoteRecips) $
-        throwE "Federation disabled, but remote recipients specified"
+            throwE "Federation disabled, but remote recipients found"
-    (lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
+    verifyContextRecip (Right (ObjURI h _)) _ remoteRecips =
-        (pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
+        unless (any ((== h) . fst) remoteRecips) $
-        (did, meparent, mcollections) <- case mticket of
+            throwE
-            Just (shr, prj, ltkhid) -> do
+                "Context is remote but no recipients of that host are listed"
-                mt <- lift $ runMaybeT $ do
+    verifyContextRecip (Left (NoteContextSharerTicket shr _)) localRecips _ =
-                    sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+        fromMaybeE
-                    Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
+            verify
-                    ltid <- decodeKeyHashidM ltkhid
+            "Local context ticket's hosting sharer isn't listed as a recipient"
-                    lt <- MaybeT $ get ltid
+        where
-                    tpl <-
+        verify = do
-                        MaybeT $ getValBy $
+            sharerSet <- lookup shr localRecips
-                            UniqueTicketProjectLocal $ localTicketTicket lt
+            guard $ localRecipSharer $ localRecipSharerDirect sharerSet
-                    guard $ ticketProjectLocalProject tpl == jid
+    verifyContextRecip (Left (NoteContextProjectTicket shr prj _)) localRecips _ =
-                    return (sid, projectInbox j, projectFollowers j, lt)
+        fromMaybeE
-                (sid, ibidProject, fsidProject, lt) <- fromMaybeE mt "Context: No such local ticket"
+            verify
-                let did = localTicketDiscuss lt
+            "Local context ticket's hosting project isn't listed as a recipient"
+        where
+        verify = do
+            sharerSet <- lookup shr localRecips
+            projectSet <- lookup prj $ localRecipProjectRelated sharerSet
+            guard $ localRecipProject $ localRecipProjectDirect projectSet
+    insertEmptyOutboxItem obid now = do
+        h <- asksSite siteInstanceHost
+        insert OutboxItem
+            { outboxItemOutbox    = obid
+            , outboxItemActivity  = persistJSONObjectFromDoc $ Doc h emptyActivity
+            , outboxItemPublished = now
+            }
+    getProject tpl = do
+        j <- getJust $ ticketProjectLocalProject tpl
+        s <- getJust $ projectSharer j
+        return (sharerIdent s, projectIdent j)
+    getTopicAndParent (Left context) mparent = do
+        (mproject, did) <-
+            case context of
+                NoteContextSharerTicket shr talid -> do
+                    (_, Entity _ lt, _, project) <- do
+                        mticket <- lift $ getSharerTicket shr talid
+                        fromMaybeE mticket "Note context no such local sharer-hosted ticket"
+                    mproj <-
+                        case project of
+                            Left (Entity _ tpl) -> lift $ Just <$> getProject tpl
+                            Right () -> return Nothing
+                    return (mproj, localTicketDiscuss lt)
+                NoteContextProjectTicket shr prj ltid -> do
+                    (_, _, _, Entity _ lt, _, _) <- do
+                        mticket <- lift $ getProjectTicket shr prj ltid
+                        fromMaybeE mticket "Note context no such local project-hosted ticket"
+                    return (Just (shr, prj), localTicketDiscuss lt)
         mmidParent <- for mparent $ \ parent ->
             case parent of
                 Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
@@ -190,152 +370,47 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                     unless (messageRoot m == did) $
                         throwE "Remote parent belongs to a different discussion"
                     return mid
-                -- lift $ insertUnique_ $ Follow pid (ticketFollowers t) False True
+        return (mproject, did, Left <$> mmidParent)
-                return (did, Left <$> mmidParent, Just (sid, localTicketFollowers lt, ibidProject, fsidProject))
+    getTopicAndParent (Right u@(ObjURI h lu)) mparent = do
-            Nothing -> do
+        (mproject, rd, rdnew) <- lift $ do
-                (rd, rdnew) <- lift $ do
+            iid <- either entityKey id <$> insertBy' (Instance h)
-                    let ObjURI hContext luContext = uContext
+            roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
-                    iid <- either entityKey id <$> insertBy' (Instance hContext)
+            merd <- getBy $ UniqueRemoteDiscussionIdent roid
-                    roid <- either entityKey id <$> insertBy' (RemoteObject iid luContext)
+            case merd of
-                    mrd <- getValBy $ UniqueRemoteDiscussionIdent roid
+                Just (Entity rdid rd) -> do
-                    case mrd of
+                    mproj <- do
-                        Just rd -> return (rd, False)
+                        mrt <- getValBy $ UniqueRemoteTicketDiscuss rdid
+                        for mrt $ \ rt -> do
+                            tar <- getJust $ remoteTicketTicket rt
+                            tpl <- getJust $ ticketAuthorRemoteTicket tar
+                            getProject tpl
+                    return (mproj, rd, False)
                 Nothing -> do
                     did <- insert Discussion
-                            let rd = RemoteDiscussion roid did
+                    (rd, rdnew) <- valAndNew <$> insertByEntity' (RemoteDiscussion roid did)
-                            erd <- insertBy' rd
+                    unless rdnew $ delete did
-                            case erd of
+                    return (Nothing, rd, rdnew)
-                                Left (Entity _ rd') -> do
-                                    delete did
-                                    return (rd', False)
-                                Right _ -> return (rd, True)
         let did = remoteDiscussionDiscuss rd
         meparent <- for mparent $ \ parent ->
             case parent of
                 Left (shrParent, lmidParent) -> do
                     when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
                     Left <$> getLocalParentMessageId did shrParent lmidParent
-                        Right p@(ObjURI hParent luParent) -> do
+                Right uParent@(ObjURI hParent luParent) -> do
                     mrm <- lift $ runMaybeT $ do
                         iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                         roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
                         MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
                     case mrm of
-                                Nothing -> return $ Right p
+                        Nothing -> return $ Right uParent
                         Just rm -> Left <$> do
                             let mid = remoteMessageRest rm
                             m <- lift $ getJust mid
                             unless (messageRoot m == did) $
                                 throwE "Remote parent belongs to a different discussion"
                             return mid
-                return (did, meparent, Nothing)
+        return (mproject, did, meparent)
-        summary <-
+    insertMessage now content source obiidCreate did meparent = do
-            withUrlRenderer
-                [hamlet|
-                    <p>
-                      <a href=@{SharerR shrUser}>#{shr2text shrUser}
-                      \ commented on a #
-                      <a href=#{renderObjURI uContext}>ticket</a>.
-                |]
-        (lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary
-        moreRemotes <- deliverLocal pid obiid localRecips mcollections
-        unless (federation || null moreRemotes) $
-            throwE "Federation disabled but remote collection members found"
-        remotesHttp <- lift $ deliverRemoteDB' (objUriAuthority uContext) obiid remoteRecips moreRemotes
-        return (lmid, obiid, doc, remotesHttp)
-    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
-    return lmid
-    where
-    parseRecipsContextParent
-        :: FedURI
-        -> Maybe FedURI
-        -> ExceptT Text Handler
-            ( Maybe (Either (ShrIdent, LocalMessageId) FedURI)
-            , [ShrIdent]
-            , Maybe (ShrIdent, PrjIdent, KeyHashid LocalTicket)
-            , [(Host, NonEmpty LocalURI)]
-            )
-    parseRecipsContextParent uContext muParent = do
-        (localsSet, remotes) <- do
-            mrecips <- parseAudience aud
-            fromMaybeE mrecips "Note without recipients"
-        let ObjURI hContext luContext = uContext
-        parent <- parseParent uContext muParent
-        local <- hostIsLocal hContext
-        if local
-            then do
-                ticket <- parseContextTicket luContext
-                shrs <- verifyTicketRecipients ticket localsSet
-                return (parent, shrs, Just ticket, remotes)
-            else do
-                shrs <- verifyOnlySharers localsSet
-                return (parent, shrs, Nothing, remotes)
-        where
-        parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) FedURI))
-        parseParent _        Nothing        = return Nothing
-        parseParent uContext (Just uParent) =
-            if uParent == uContext
-                then return Nothing
-                else Just <$> do
-                    let ObjURI hParent luParent = uParent
-                    parentLocal <- hostIsLocal hParent
-                    if parentLocal
-                        then Left <$> parseComment luParent
-                        else return $ Right uParent
-
-        parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, KeyHashid LocalTicket)
-        parseContextTicket 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 -> return (shr, prj, num)
-                _ -> throwE "Local context isn't a ticket route"
-
-        atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
-        atMostSharer _ (shr, LocalSharerRelatedSet s [] [] []) = return $ if localRecipSharer s then Just shr else Nothing
-        atMostSharer e (_  , LocalSharerRelatedSet _ _  _  _ ) = throwE e
-
-        verifyTicketRecipients :: (ShrIdent, PrjIdent, KeyHashid LocalTicket) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
-        verifyTicketRecipients (shr, prj, num) recips = do
-            lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
-            (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
-            unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
-            unless (localRecipProject $ localRecipProjectDirect lprSet) $ throwE "Note context's project not addressed"
-            unless (localRecipProjectFollowers $ localRecipProjectDirect lprSet) $ throwE "Note context's project followers not addressed"
-            (num', ltrSet) <- verifySingleton (localRecipProjectTicketRelated lprSet) "Note ticket-related recipient sets"
-            unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
-            unless (localRecipTicketTeam ltrSet) $
-                throwE "Note ticket team not addressed"
-            unless (localRecipTicketFollowers ltrSet) $
-                throwE "Note ticket participants not addressed"
-            let rest = deleteBy ((==) `on` fst) (shr, lsrSet) recips
-                orig = if localRecipSharer $ localRecipSharerDirect lsrSet then Just shr else Nothing
-            catMaybes . (orig :) <$> traverse (atMostSharer "Note with unrelated non-sharer recipients") rest
-                where
-                verifySingleton :: Monad m => [a] -> Text -> ExceptT Text m a
-                verifySingleton []  t = throwE $ t <> ": expected 1, got 0"
-                verifySingleton [x] _ = return x
-                verifySingleton l   t = throwE $ t <> ": expected 1, got " <> T.pack (show $ length l)
-
-        verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
-        verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs
-
-    insertMessage
-        :: LocalURI
-        -> ShrIdent
-        -> PersonId
-        -> OutboxId
-        -> FedURI
-        -> DiscussionId
-        -> Maybe FedURI
-        -> Maybe (Either MessageId FedURI)
-        -> Text
-        -> Text
-        -> Html
-        -> AppDB (LocalMessageId, OutboxItemId, Doc Activity URIMode)
-    insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary = do
-        now <- liftIO getCurrentTime
         mid <- insert Message
             { messageCreated = now
             , messageSource  = source
@@ -346,17 +421,31 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                     _                     -> Nothing
             , messageRoot    = did
             }
-        let activity luAct luNote = Doc host Activity
+        insert LocalMessage
-                { activityId       = Just luAct
+            { localMessageAuthor         = pidUser
+            , localMessageRest           = mid
+            , localMessageCreate         = obiidCreate
+            , localMessageUnlinkedParent =
+                case meparent of
+                    Just (Right uParent) -> Just uParent
+                    _                    -> Nothing
+            }
+    insertCreateToOutbox now shrUser (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        hLocal <- asksSite siteInstanceHost
+        obikhid <- encodeKeyHashid obiidCreate
+        lmkhid <- encodeKeyHashid lmid
+        let luAttrib = encodeRouteLocal $ SharerR shrUser
+            create = Doc hLocal Activity
+                { activityId       = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
                 , activityActor    = luAttrib
-                , activitySummary  =
+                , activitySummary  = Just summary
-                    Just $ TextHtml $ TL.toStrict $ renderHtml summary
+                , activityAudience = audience
-                , activityAudience = aud
                 , activitySpecific = CreateActivity Create
                     { createObject = CreateNote Note
-                        { noteId        = Just luNote
+                        { noteId        = Just $ encodeRouteLocal $ MessageR shrUser lmkhid
                         , noteAttrib    = luAttrib
-                        , noteAudience  = aud
+                        , noteAudience  = emptyAudience
                         , noteReplyTo   = Just $ fromMaybe uContext muParent
                         , noteContext   = Just uContext
                         , notePublished = Just now
@@ -366,90 +455,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                     , createTarget = Nothing
                     }
                 }
-            tempUri = topLocalURI
+        update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
-        obiid <- insert OutboxItem
+        return create
-            { outboxItemOutbox    = obid
-            , outboxItemActivity  =
-                persistJSONObjectFromDoc $ activity tempUri tempUri
-            , outboxItemPublished = now
-            }
-        lmid <- insert LocalMessage
-            { localMessageAuthor         = pid
-            , localMessageRest           = mid
-            , localMessageCreate         = obiid
-            , localMessageUnlinkedParent =
-                case meparent of
-                    Just (Right uParent) -> Just uParent
-                    _                    -> Nothing
-            }
-        route2local <- getEncodeRouteLocal
-        obihid <- encodeKeyHashid obiid
-        lmhid <- encodeKeyHashid lmid
-        let luAct = route2local $ SharerOutboxItemR shrUser obihid
-            luNote = route2local $ MessageR shrUser lmhid
-            doc = activity luAct luNote
-        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-        return (lmid, obiid, doc)
-
-    -- Deliver to local recipients. For local users, find in DB and deliver.
-    -- For local collections, expand them, deliver to local users, and return a
-    -- list of remote actors found in them.
-    deliverLocal
-        :: PersonId
-        -> OutboxItemId
-        -> [ShrIdent]
-        -> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
-        -> ExceptT Text AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
-    deliverLocal pidAuthor obid recips mticket = do
-        recipPids <- traverse getPersonId $ nub recips
-        when (pidAuthor `elem` recipPids) $
-            throwE "Note addressed to note author"
-        (morePids, remotes) <-
-            lift $ case mticket of
-                Nothing -> return ([], [])
-                Just (sid, fsidT, _, fsidJ) -> do
-                    (teamPids, teamRemotes) <- getTicketTeam sid
-                    (tfsPids, tfsRemotes) <- getFollowers fsidT
-                    (jfsPids, jfsRemotes) <- getFollowers fsidJ
-                    return
-                        ( L.delete pidAuthor $ union teamPids $ union tfsPids jfsPids
-                        , teamRemotes `unionRemotes` tfsRemotes `unionRemotes` jfsRemotes
-                        )
-        lift $ do
-            for_ mticket $ \ (_, _, ibidProject, _) -> do
-                ibiid <- insert $ InboxItem False
-                insert_ $ InboxItemLocal ibidProject obid ibiid
-            for_ (union recipPids morePids) $ \ pid -> do
-                ibid <- personInbox <$> getJust pid
-                ibiid <- insert $ InboxItem True
-                insert_ $ InboxItemLocal ibid obid ibiid
-        return remotes
-        where
-        getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId
-        getPersonId shr = do
-            msid <- lift $ getKeyBy $ UniqueSharer shr
-            sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
-            id_ <- lift $ getPersonOrGroupId sid
-            case id_ of
-                Left pid -> return pid
-                Right _gid -> throwE "Local Note addresses a local group"
-
-    {-
-    -- Deliver to a local sharer, if they exist as a user account
-    deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
-    deliverToLocalSharer obid shr = do
-        msid <- lift $ getKeyBy $ UniqueSharer shr
-        sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
-        mpid <- lift $ getKeyBy $ UniquePersonIdent sid
-        mgid <- lift $ getKeyBy $ UniqueGroup sid
-        id_ <-
-            requireEitherM mpid mgid
-                "Found sharer that is neither person nor group"
-                "Found sharer that is both person and group"
-        case id_ of
-            Left pid -> lift $ insert_ $ InboxItemLocal pid obid
-            Right _gid -> throwE "Local Note addresses a local group"
-    -}
 
 -- | Handle a Ticket submitted by a local user to their outbox. The ticket's
 -- context project may be local or remote. Return an error message if the
@@ -984,6 +991,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
             where
             offerRecips prj = LocalSharerRelatedSet
                 { localRecipSharerDirect        = LocalSharerDirectSet False False
+                , localRecipSharerTicketRelated = []
                 , localRecipProjectRelated      =
                     [ ( prj
                       , LocalProjectRelatedSet

src/Vervis/ActivityPub/Recipient.hs

@@ -32,6 +32,7 @@ module Vervis.ActivityPub.Recipient
     , parseAudience
     , actorRecips
     , localRecipSieve
+    , localRecipSieve'
     )
 where
 
@@ -454,22 +455,31 @@ 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 False False) []
+        LocalProjectRelatedSet (LocalProjectDirectSet (j && allowOthers) False False) []
     onlyActorsR (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f)) =
-        LocalRepoRelatedSet $ LocalRepoDirectSet r False False
+        LocalRepoRelatedSet $ LocalRepoDirectSet (r && allowOthers) False False
     onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) _ts js rs) =
         LocalSharerRelatedSet
-            (LocalSharerDirectSet s False)
+            (LocalSharerDirectSet (s && allowSharers) False)
             []
             (map (second onlyActorsJ) js)
             (map (second onlyActorsR) rs)
 
     applySharerRelated _   (This _) = Nothing
     applySharerRelated shr (That s) =
-        if allowActors
+        if allowSharers || allowOthers
             then Just (shr, onlyActorsS s)
             else Nothing
     applySharerRelated shr (These (LocalSharerRelatedSet s' t' j' r') (LocalSharerRelatedSet s t j r)) =
@@ -483,7 +493,7 @@ localRecipSieve sieve allowActors =
             )
         where
         applySharer (LocalSharerDirectSet s' f') (LocalSharerDirectSet s f) =
-            LocalSharerDirectSet (s && (s' || allowActors)) (f && f')
+            LocalSharerDirectSet (s && (s' || allowSharers)) (f && f')
 
         applyTicketRelated ltkhid (These t' t) = Just (ltkhid, applyTicket t' t)
             where
@@ -493,7 +503,7 @@ localRecipSieve sieve allowActors =
 
         applyProjectRelated _   (This _) = Nothing
         applyProjectRelated prj (That j) =
-            if allowActors
+            if allowOthers
                 then Just (prj, onlyActorsJ j)
                 else Nothing
         applyProjectRelated prj (These (LocalProjectRelatedSet j' t') (LocalProjectRelatedSet j t)) =
@@ -505,15 +515,15 @@ localRecipSieve sieve allowActors =
                 )
             where
             applyProject (LocalProjectDirectSet j' t' f') (LocalProjectDirectSet j t f) =
-                LocalProjectDirectSet (j && (j' || allowActors)) (t && t') (f && f')
+                LocalProjectDirectSet (j && (j' || allowOthers)) (t && t') (f && f')
 
         applyRepoRelated _  (This _) = Nothing
         applyRepoRelated rp (That r) =
-            if allowActors
+            if allowOthers
                 then Just (rp, onlyActorsR r)
                 else Nothing
         applyRepoRelated rp (These (LocalRepoRelatedSet r') (LocalRepoRelatedSet r)) =
             Just (rp, LocalRepoRelatedSet $ applyRepo r' r)
             where
             applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) =
-                LocalRepoDirectSet (r && (r' || allowActors)) (t && t') (f && f')
+                LocalRepoDirectSet (r && (r' || allowOthers)) (t && t') (f && f')

src/Vervis/Handler/Client.hs

@@ -296,7 +296,7 @@ postPublishR = do
                 FormMissing -> throwE "Field(s) missing"
                 FormFailure _l -> throwE "Invalid input, see below"
                 FormSuccess r -> return r
-        bitraverse (bitraverse (publishComment shrAuthor) (publishTicket ep s)) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
+        bitraverse (bitraverse (publishComment ep s) (publishTicket ep s)) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
     case eid of
         Left err -> setMessage $ toHtml err
         Right id_ ->
@@ -322,13 +322,14 @@ postPublishR = do
             widget3 enctype3
             widget4 enctype4
     where
-    publishComment shrAuthor ((hTicket, shrTicket, prj, num), muParent, msg) = do
+    publishComment eperson sharer ((hTicket, shrTicket, prj, num), muParent, msg) = do
         encodeRouteFed <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
         let msg' = T.filter (/= '\r') msg
         contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
         let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal
             uTicket = encodeRecipRoute $ ProjectTicketR shrTicket prj num
+            shrAuthor = sharerIdent sharer
             ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
             collections =
                 [ ProjectFollowersR shrTicket prj
@@ -353,7 +354,7 @@ postPublishR = do
                 , noteSource    = msg'
                 , noteContent   = contentHtml
                 }
-        ExceptT $ createNoteC hLocal note
+        ExceptT $ noteC eperson sharer note
     publishTicket eperson sharer (target, context, title, desc) = do
         (summary, audience, create) <-
             ExceptT $ C.createTicket (sharerIdent sharer) title desc target context

src/Vervis/Handler/Discussion.hs

@@ -209,18 +209,19 @@ postTopReply
     -> Handler Html
 postTopReply hDest recipsA recipsC context recipF replyP after = do
     ((result, widget), enctype) <- runFormPost newMessageForm
-    shrAuthor <- do
+    (eperson, sharer) <- do
-        Entity _ p <- requireVerifiedAuth
+        ep@(Entity _ p) <- requireVerifiedAuth
-        runDB $ sharerIdent <$> get404 (personIdent p)
+        s <- runDB $ get404 (personIdent p)
+        return (ep, s)
+    let shrAuthor = sharerIdent sharer
     elmid <- runExceptT $ do
         msg <- case result of
             FormMissing -> throwE "Field(s) missing."
             FormFailure _l -> throwE "Message submission failed, see errors below."
             FormSuccess nm ->
                 return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
-        hLocal <- asksSite siteInstanceHost
         note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context
-        ExceptT $ createNoteC hLocal note
+        ExceptT $ noteC eperson sharer note
     case elmid of
         Left e -> do
             setMessage $ toHtml e
@@ -264,18 +265,19 @@ postReply
     -> Handler Html
 postReply hDest recipsA recipsC context recipF replyG replyP after getdid midParent = do
     ((result, widget), enctype) <- runFormPost newMessageForm
-    shrAuthor <- do
+    (eperson, sharer) <- do
-        Entity _ p <- requireVerifiedAuth
+        ep@(Entity _ p) <- requireVerifiedAuth
-        runDB $ sharerIdent <$> get404 (personIdent p)
+        s <- runDB $ get404 (personIdent p)
+        return (ep, s)
+    let shrAuthor = sharerIdent sharer
     elmid <- runExceptT $ do
         msg <- case result of
             FormMissing -> throwE "Field(s) missing."
             FormFailure _l -> throwE "Message submission failed, see errors below."
             FormSuccess nm ->
                 return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
-        hLocal <- asksSite siteInstanceHost
         note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent
-        ExceptT $ createNoteC hLocal note
+        ExceptT $ noteC eperson sharer note
     case elmid of
         Left e -> do
             setMessage $ toHtml e

src/Vervis/Handler/Ticket.hs

@@ -266,31 +266,6 @@ getProjectTicketNewR shr prj = do
     ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
     defaultLayout $(widgetFile "ticket/new")
 
-getProjectTicket :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB (Entity Sharer, Entity Project, Entity Ticket, Entity LocalTicket, Entity TicketProjectLocal, Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote))
-getProjectTicket shr prj ltkhid = do
-    es@(Entity sid _) <- getBy404 $ UniqueSharer shr
-    ej@(Entity jid _) <- getBy404 $ UniqueProject prj sid
-    ltid <- decodeKeyHashid404 ltkhid
-    lt <- get404 ltid
-    let tid = localTicketTicket lt
-    t <- get404 tid
-    etpl@(Entity tplid tpl) <- getBy404 $ UniqueTicketProjectLocal tid
-    unless (ticketProjectLocalProject tpl == jid) notFound
-    author <-
-        requireEitherAlt
-            (do mtal <- getBy $ UniqueTicketAuthorLocal ltid
-                for mtal $ \ tal@(Entity talid _) -> do
-                    tupid1 <- getKeyBy404 $ UniqueTicketUnderProjectProject tplid
-                    tupid2 <- getKeyBy404 $ UniqueTicketUnderProjectAuthor talid
-                    unless (tupid1 == tupid2) $
-                        error "TAL and TPL used by different TUPs!"
-                    return tal
-            )
-            (getBy $ UniqueTicketAuthorRemote tplid)
-            "Ticket doesn't have author"
-            "Ticket has both local and remote author"
-    return (es, ej, Entity tid t, Entity ltid lt, etpl, author)
-
 getProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
 getProjectTicketR shar proj ltkhid = do
     mpid <- maybeAuthId
@@ -298,7 +273,7 @@ getProjectTicketR shar proj ltkhid = do
       author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams,
       deps, rdeps) <-
         runDB $ do
-            (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etpl, author) <- getProjectTicket shar proj ltkhid
+            (Entity sid sharer, Entity jid project, Entity tid ticket, Entity _ lticket, _etpl, author) <- getProjectTicket404 shar proj ltkhid
             (wshr, wid, wfl) <- do
                 w <- get404 $ projectWorkflow project
                 wsharer <-
@@ -428,7 +403,7 @@ getProjectTicketR shar proj ltkhid = do
 putProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 putProjectTicketR shr prj ltkhid = do
     (tid, ticket, wid) <- runDB $ do
-        (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         return (tid, ticket, projectWorkflow project)
     ((result, widget), enctype) <-
         runFormPost $ editTicketContentForm tid ticket wid
@@ -502,7 +477,7 @@ postProjectTicketR shr prj ltkhid = do
 getProjectTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 getProjectTicketEditR shr prj ltkhid = do
     (tid, ticket, wid) <- runDB $ do
-        (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, Entity _ project, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         return (tid, ticket, projectWorkflow project)
     ((_result, widget), enctype) <-
         runFormPost $ editTicketContentForm tid ticket wid
@@ -512,7 +487,7 @@ postProjectTicketAcceptR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 postProjectTicketAcceptR shr prj ltkhid = do
     succ <- runDB $ do
-        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         case ticketStatus ticket of
             TSNew -> do
                 update tid [TicketStatus =. TSTodo]
@@ -530,7 +505,7 @@ postProjectTicketCloseR shr prj ltkhid = do
     pid <- requireAuthId
     now <- liftIO getCurrentTime
     succ <- runDB $ do
-        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         case ticketStatus ticket of
             TSClosed -> return False
             _        -> do
@@ -553,7 +528,7 @@ postProjectTicketOpenR shr prj ltkhid = do
     pid <- requireAuthId
     now <- liftIO getCurrentTime
     succ <- runDB $ do
-        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         case ticketStatus ticket of
             TSClosed -> do
                 update tid
@@ -573,7 +548,7 @@ postProjectTicketClaimR
 postProjectTicketClaimR shr prj ltkhid = do
     pid <- requireAuthId
     mmsg <- runDB $ do
-        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         case (ticketStatus ticket, ticketAssignee ticket) of
             (TSNew, _) ->
                 return $
@@ -595,7 +570,7 @@ postProjectTicketUnclaimR
 postProjectTicketUnclaimR shr prj ltkhid = do
     pid <- requireAuthId
     mmsg <- runDB $ do
-        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
             (Nothing, _) ->
                 return $ Just "The ticket is already unassigned."
@@ -619,7 +594,7 @@ getProjectTicketAssignR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 getProjectTicketAssignR shr prj ltkhid = do
     vpid <- requireAuthId
-    (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid
+    (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
     let msg t = do
             setMessage t
             redirect $ ProjectTicketR shr prj ltkhid
@@ -636,7 +611,7 @@ postProjectTicketAssignR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 postProjectTicketAssignR shr prj ltkhid = do
     vpid <- requireAuthId
-    (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid
+    (_es, Entity jid _, Entity tid ticket, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
     let msg t = do
             setMessage t
             redirect $ ProjectTicketR shr prj ltkhid
@@ -668,7 +643,7 @@ postProjectTicketUnassignR
 postProjectTicketUnassignR shr prj ltkhid = do
     pid <- requireAuthId
     mmsg <- runDB $ do
-        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, Entity tid ticket, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
             (Nothing, _) ->
                 return $ Just "The ticket is already unassigned."
@@ -747,7 +722,7 @@ getClaimRequestsTicketR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 getClaimRequestsTicketR shr prj ltkhid = do
     rqs <- runDB $ do
-        (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do
                 E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
                 E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
@@ -771,7 +746,7 @@ postClaimRequestsTicketR shr prj ltkhid = do
             now <- liftIO getCurrentTime
             pid <- requireAuthId
             runDB $ do
-                (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+                (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
                 let cr = TicketClaimRequest
                         { ticketClaimRequestPerson  = pid
                         , ticketClaimRequestTicket  = tid
@@ -791,7 +766,7 @@ postClaimRequestsTicketR shr prj ltkhid = do
 selectDiscussionId
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId
 selectDiscussionId shr prj ltkhid = do
-    (_es, _ej, _et, Entity _ lticket, _etpl, _author) <- getProjectTicket shr prj ltkhid
+    (_es, _ej, _et, Entity _ lticket, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
     return $ localTicketDiscuss lticket
 
 getProjectTicketDiscussionR
@@ -878,7 +853,7 @@ getTicketDeps forward shr prj ltkhid = do
                 if forward then TicketDependencyParent else TicketDependencyChild
             to' =
                 if forward then TicketDependencyChild else TicketDependencyParent
-        (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, Entity tid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         fmap (map toRow) $ E.select $ E.from $
             \ ( td
               `E.InnerJoin` t
@@ -951,7 +926,7 @@ getProjectTicketDepsR = getTicketDeps True
 postProjectTicketDepsR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 postProjectTicketDepsR shr prj ltkhid = do
-    (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid
+    (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
     ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
     case result of
         FormSuccess ctid -> do
@@ -979,7 +954,7 @@ postProjectTicketDepsR shr prj ltkhid = do
 getProjectTicketDepNewR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 getProjectTicketDepNewR shr prj ltkhid = do
-    (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket shr prj ltkhid
+    (_es, Entity jid _, Entity tid _, _elt, _etpl, _author) <- runDB $ getProjectTicket404 shr prj ltkhid
     ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
     defaultLayout $(widgetFile "ticket/dep/new")
 
@@ -995,7 +970,7 @@ deleteTicketDepOldR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
 deleteTicketDepOldR shr prj pnum cnum = do
     runDB $ do
-        (_es, Entity jid _, Entity ptid _, _elt, _etpl, _author) <- getProjectTicket shr prj pnum
+        (_es, Entity jid _, Entity ptid _, _elt, _etpl, _author) <- getProjectTicket404 shr prj pnum
 
         cltid <- decodeKeyHashid404 cnum
         clt <- get404 cltid
@@ -1072,14 +1047,14 @@ getProjectTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFs
     where
     here = ProjectTicketParticipantsR shr prj ltkhid
     getFsid = do
-        (_es, _ej, _et, Entity _ lt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (_es, _ej, _et, Entity _ lt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         return $ localTicketFollowers lt
 
 getProjectTicketTeamR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
 getProjectTicketTeamR shr prj ltkhid = do
     memberShrs <- runDB $ do
-        (Entity sid _, _ej, _et, _elt, _etpl, _author) <- getProjectTicket shr prj ltkhid
+        (Entity sid _, _ej, _et, _elt, _etpl, _author) <- getProjectTicket404 shr prj ltkhid
         id_ <-
             requireEitherAlt
                 (getKeyBy $ UniquePersonIdent sid)
@@ -1117,43 +1092,6 @@ getProjectTicketEventsR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
 getProjectTicketEventsR _shr _prj _ltkhid = error "TODO not implemented"
 
-getSharerTicket
-    :: ShrIdent
-    -> KeyHashid TicketAuthorLocal
-    -> AppDB
-        ( Entity TicketAuthorLocal
-        , Entity LocalTicket
-        , Entity Ticket
-        , Either (Entity TicketProjectLocal) ()
-        )
-getSharerTicket shr talkhid = do
-    pid <- do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        getKeyBy404 $ UniquePersonIdent sid
-    talid <- decodeKeyHashid404 talkhid
-    tal <- get404 talid
-    unless (ticketAuthorLocalAuthor tal == pid) notFound
-    let ltid = ticketAuthorLocalTicket tal
-    lt <- getJust ltid
-    let tid = localTicketTicket lt
-    t <- getJust tid
-    project <-
-        requireEitherAlt
-            (do mtpl <- getBy $ UniqueTicketProjectLocal tid
-                for mtpl $ \ etpl@(Entity tplid tpl) -> do
-                    mtup1 <- getBy $ UniqueTicketUnderProjectProject tplid
-                    mtup2 <- getBy $ UniqueTicketUnderProjectAuthor talid
-                    unless (isJust mtup1 == isJust mtup2) $
-                        error "TUP points to unrelated TAL and TPL!"
-                    unless (isNothing mtup1) notFound
-                    return etpl
-            )
-            (return Nothing
-            )
-            "Ticket doesn't have project"
-            "Ticket has both local and remote project"
-    return (Entity talid tal, Entity ltid lt, Entity tid t, project)
-
 getSharerTicketsR :: ShrIdent -> Handler TypedContent
 getSharerTicketsR shr = do
     (total, pages, mpage) <- runDB $ do
@@ -1229,7 +1167,7 @@ getSharerTicketR
     :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerTicketR shr talkhid = do
     (ticket, project, massignee) <- runDB $ do
-        (_, _, Entity _ t, tp) <- getSharerTicket shr talkhid
+        (_, _, Entity _ t, tp) <- getSharerTicket404 shr talkhid
         (,,) t
             <$> bitraverse
                     (\ (Entity _ tpl) -> do
@@ -1290,7 +1228,7 @@ getSharerTicketDiscussionR
     :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerTicketDiscussionR shr talkhid = do
     (locals, remotes) <- runDB $ do
-        (_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
+        (_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
         let did = localTicketDiscuss lt
         (,) <$> selectLocals did <*> selectRemotes did
     encodeRouteLocal <- getEncodeRouteLocal
@@ -1340,7 +1278,7 @@ getSharerTicketDeps
     :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerTicketDeps forward shr talkhid = do
     tdids <- runDB $ do
-        (_, _, Entity tid _, _) <- getSharerTicket shr talkhid
+        (_, _, Entity tid _, _) <- getSharerTicket404 shr talkhid
         let (from, to) =
                 if forward
                     then (TicketDependencyParent, TicketDependencyChild)
@@ -1384,13 +1322,13 @@ getSharerTicketFollowersR shr talkhid = getFollowersCollection here getFsid
     where
     here = SharerTicketFollowersR shr talkhid
     getFsid = do
-        (_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
+        (_, Entity _ lt, _, _) <- getSharerTicket404 shr talkhid
         return $ localTicketFollowers lt
 
 getSharerTicketTeamR
     :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerTicketTeamR shr talkhid = do
-    _ <- runDB $ getSharerTicket shr talkhid
+    _ <- runDB $ getSharerTicket404 shr talkhid
     encodeRouteLocal <- getEncodeRouteLocal
     let team = Collection
             { collectionId         = encodeRouteLocal here
@@ -1408,7 +1346,7 @@ getSharerTicketTeamR shr talkhid = do
 getSharerTicketEventsR
     :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerTicketEventsR shr talkhid = do
-    _ <- runDB $ getSharerTicket shr talkhid
+    _ <- runDB $ getSharerTicket404 shr talkhid
     encodeRouteLocal <- getEncodeRouteLocal
     let team = Collection
             { collectionId         = encodeRouteLocal here

src/Vervis/Ticket.hs

@@ -27,16 +27,29 @@ module Vervis.Ticket
     , getTicketEnumParams
     , TicketClassParam (..)
     , getTicketClasses
+    , getSharerTicket
+    , getSharerTicket404
+    , getProjectTicket
+    , getProjectTicket404
     )
 where
 
 import Control.Arrow ((***))
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Maybe
 import Data.Foldable (for_)
 import Data.Int
 import Data.Maybe (isJust)
 import Data.Text (Text)
 import Data.Traversable
 import Database.Esqueleto
+import Yesod.Core (notFound)
+
+import Yesod.Hashids
+
+import Data.Either.Local
+import Database.Persist.Local
 
 import Vervis.Foundation (AppDB)
 import Vervis.Model
@@ -408,3 +421,113 @@ getTicketClasses tid wid = fmap (map toCParam) $
             , f ^. WorkflowFieldFilterClosed
             , p ?. TicketParamClassId
             )
+
+getSharerTicket
+    :: ShrIdent
+    -> TicketAuthorLocalId
+    -> AppDB
+        ( Maybe
+            ( Entity TicketAuthorLocal
+            , Entity LocalTicket
+            , Entity Ticket
+            , Either (Entity TicketProjectLocal) ()
+            )
+        )
+getSharerTicket 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
+    project <-
+        requireEitherAlt
+            (do mtpl <- lift $ getBy $ UniqueTicketProjectLocal tid
+                for mtpl $ \ etpl@(Entity tplid tpl) -> do
+                    mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tplid
+                    mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
+                    unless (isJust mtup1 == isJust mtup2) $
+                        error "TUP points to unrelated TAL and TPL!"
+                    guard $ not $ isJust mtup1
+                    return etpl
+            )
+            (return Nothing
+            )
+            "Ticket doesn't have project"
+            "Ticket has both local and remote project"
+    return (Entity talid tal, Entity ltid lt, Entity tid t, project)
+
+getSharerTicket404
+    :: ShrIdent
+    -> KeyHashid TicketAuthorLocal
+    -> AppDB
+        ( Entity TicketAuthorLocal
+        , Entity LocalTicket
+        , Entity Ticket
+        , Either (Entity TicketProjectLocal) ()
+        )
+getSharerTicket404 shr talkhid = do
+    talid <- decodeKeyHashid404 talkhid
+    mticket <- getSharerTicket shr talid
+    case mticket of
+        Nothing -> notFound
+        Just ticket -> return ticket
+
+getProjectTicket
+    :: ShrIdent
+    -> PrjIdent
+    -> LocalTicketId
+    -> AppDB
+        ( Maybe
+            ( Entity Sharer
+            , Entity Project
+            , Entity Ticket
+            , Entity LocalTicket
+            , Entity TicketProjectLocal
+            , Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)
+            )
+        )
+getProjectTicket shr prj ltid = runMaybeT $ do
+    es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr
+    ej@(Entity jid _) <- MaybeT $ getBy $ UniqueProject prj sid
+    lt <- MaybeT $ get ltid
+    let tid = localTicketTicket lt
+    t <- MaybeT $ get tid
+    etpl@(Entity tplid tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tid
+    guard $ ticketProjectLocalProject tpl == jid
+    author <-
+        requireEitherAlt
+            (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
+                for mtal $ \ tal@(Entity talid _) -> do
+                    tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tplid
+                    tupid2 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectAuthor talid
+                    unless (tupid1 == tupid2) $
+                        error "TAL and TPL used by different TUPs!"
+                    return tal
+            )
+            (lift $ getBy $ UniqueTicketAuthorRemote tplid)
+            "Ticket doesn't have author"
+            "Ticket has both local and remote author"
+    return (es, ej, Entity tid t, Entity ltid lt, etpl, author)
+
+getProjectTicket404
+    :: ShrIdent
+    -> PrjIdent
+    -> KeyHashid LocalTicket
+    -> AppDB
+        ( Entity Sharer
+        , Entity Project
+        , Entity Ticket
+        , Entity LocalTicket
+        , Entity TicketProjectLocal
+        , Either (Entity TicketAuthorLocal) (Entity TicketAuthorRemote)
+        )
+getProjectTicket404 shr prj ltkhid = do
+    ltid <- decodeKeyHashid404 ltkhid
+    mticket <- getProjectTicket shr prj ltid
+    case mticket of
+        Nothing -> notFound
+        Just ticket -> return ticket

src/Web/ActivityPub.hs

@@ -67,6 +67,7 @@ module Web.ActivityPub
     , Activity (..)
 
       -- * Utilities
+    , emptyAudience
     , emptyActivity
     , hActivityPubActor
     , provideAP
@@ -1266,6 +1267,9 @@ instance ActivityPub Activity where
         encodeSpecific _ _ (RejectActivity a) = encodeReject a
         encodeSpecific h _ (UndoActivity a)   = encodeUndo h a
 
+emptyAudience :: Audience u
+emptyAudience = Audience [] [] [] [] [] []
+
 emptyActivity :: Activity u
 emptyActivity = Activity
     { activityId       = Nothing
@@ -1275,8 +1279,6 @@ emptyActivity = Activity
     , activitySpecific =
         RejectActivity $ Reject $ ObjURI (Authority "" Nothing) topLocalURI
     }
-    where
-    emptyAudience = Audience [] [] [] [] [] []
 
 typeActivityStreams2 :: ContentType
 typeActivityStreams2 = "application/activity+json"