diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index 22c6032..d44402f 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2020 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index e928b86..b2b663c 100644 --- a/src/Vervis/API.hs +++ b/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,195 +149,268 @@ 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| +

+ #{shr2text shrUser} + $maybe uContext <- noteContext note + \ commented under a # + topic. + $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 host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do - verifyHostLocal host "Attributed to non-local actor" - verifyNothingE mluNote "Note specifies an id" - verifyNothingE mpublished "Note specifies published" - uContext <- fromMaybeE muContext "Note without context" - (mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent uContext muParent - federation <- getsYesod $ appFederation . appSettings - unless (federation || null remoteRecips) $ - throwE "Federation disabled, but remote recipients specified" +createNoteC + :: Entity Person + -> 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 - (pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor" - (did, meparent, mcollections) <- case mticket of - Just (shr, prj, ltkhid) -> do - mt <- lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid - ltid <- decodeKeyHashidM ltkhid - lt <- MaybeT $ get ltid - tpl <- - MaybeT $ getValBy $ - UniqueTicketProjectLocal $ localTicketTicket lt - guard $ ticketProjectLocalProject tpl == jid - return (sid, projectInbox j, projectFollowers j, lt) - (sid, ibidProject, fsidProject, lt) <- fromMaybeE mt "Context: No such local ticket" - let did = localTicketDiscuss lt - mmidParent <- for mparent $ \ parent -> - case parent of - Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent - Right (ObjURI hParent luParent) -> do - mrm <- lift $ runMaybeT $ do - iid <- MaybeT $ getKeyBy $ UniqueInstance hParent - roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent - MaybeT $ getValBy $ UniqueRemoteMessageIdent roid - rm <- fromMaybeE mrm "Remote parent unknown locally" + 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" + context <- parseNoteContext uContext + 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 found" + verifyContextRecip (Right (ObjURI h _)) _ remoteRecips = + unless (any ((== h) . fst) remoteRecips) $ + throwE + "Context is remote but no recipients of that host are listed" + verifyContextRecip (Left (NoteContextSharerTicket shr _)) localRecips _ = + fromMaybeE + verify + "Local context ticket's hosting sharer isn't listed as a recipient" + where + verify = do + sharerSet <- lookup shr localRecips + guard $ localRecipSharer $ localRecipSharerDirect sharerSet + verifyContextRecip (Left (NoteContextProjectTicket shr prj _)) localRecips _ = + fromMaybeE + verify + "Local context ticket's hosting project isn't listed as a recipient" + where + verify = do + sharerSet <- lookup shr localRecips + projectSet <- lookup prj $ localRecipProjectRelated sharerSet + guard $ localRecipProject $ localRecipProjectDirect projectSet + 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 + Right (ObjURI hParent luParent) -> do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent roid + rm <- fromMaybeE mrm "Remote parent unknown locally" + let mid = remoteMessageRest rm + m <- lift $ getJust mid + unless (messageRoot m == did) $ + throwE "Remote parent belongs to a different discussion" + return mid + return (mproject, did, Left <$> mmidParent) + getTopicAndParent (Right u@(ObjURI h lu)) mparent = do + (mproject, rd, rdnew) <- lift $ do + iid <- either entityKey id <$> insertBy' (Instance h) + roid <- either entityKey id <$> insertBy' (RemoteObject iid lu) + merd <- getBy $ UniqueRemoteDiscussionIdent roid + case merd of + Just (Entity rdid rd) -> do + mproj <- do + 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 + (rd, rdnew) <- valAndNew <$> insertByEntity' (RemoteDiscussion roid did) + unless rdnew $ delete did + return (Nothing, rd, rdnew) + 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 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 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 - -- lift $ insertUnique_ $ Follow pid (ticketFollowers t) False True - return (did, Left <$> mmidParent, Just (sid, localTicketFollowers lt, ibidProject, fsidProject)) - Nothing -> do - (rd, rdnew) <- lift $ do - let ObjURI hContext luContext = uContext - iid <- either entityKey id <$> insertBy' (Instance hContext) - roid <- either entityKey id <$> insertBy' (RemoteObject iid luContext) - mrd <- getValBy $ UniqueRemoteDiscussionIdent roid - case mrd of - Just rd -> return (rd, False) - Nothing -> do - did <- insert Discussion - let rd = RemoteDiscussion roid did - erd <- insertBy' rd - case erd of - 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 - 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 - 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) - summary <- - withUrlRenderer - [hamlet| -

- #{shr2text shrUser} - \ commented on a # - ticket. - |] - (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 + return (mproject, did, meparent) + insertMessage now content source obiidCreate did meparent = do 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 - { activityId = Just luAct + insert LocalMessage + { 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 = - Just $ TextHtml $ TL.toStrict $ renderHtml summary - , activityAudience = aud + , activitySummary = Just summary + , activityAudience = audience , 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 - obiid <- insert OutboxItem - { 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" - -} + update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] + return create -- | 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 @@ -983,8 +990,9 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT else verifyOnlySharer lsrSet where offerRecips prj = LocalSharerRelatedSet - { localRecipSharerDirect = LocalSharerDirectSet False False - , localRecipProjectRelated = + { localRecipSharerDirect = LocalSharerDirectSet False False + , localRecipSharerTicketRelated = [] + , localRecipProjectRelated = [ ( prj , LocalProjectRelatedSet { localRecipProjectDirect = @@ -993,7 +1001,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT } ) ] - , localRecipRepoRelated = [] + , localRecipRepoRelated = [] } verifyOnlySharer lsrSet = do unless (null $ localRecipProjectRelated lsrSet) $ diff --git a/src/Vervis/ActivityPub/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs index 816b9c4..35f8251 100644 --- a/src/Vervis/ActivityPub/Recipient.hs +++ b/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') diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index d8f0909..410d42a 100644 --- a/src/Vervis/Handler/Client.hs +++ b/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 diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index cc2426c..843cbf9 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/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 - Entity _ p <- requireVerifiedAuth - runDB $ sharerIdent <$> get404 (personIdent p) + (eperson, sharer) <- do + ep@(Entity _ p) <- requireVerifiedAuth + 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 - Entity _ p <- requireVerifiedAuth - runDB $ sharerIdent <$> get404 (personIdent p) + (eperson, sharer) <- do + ep@(Entity _ p) <- requireVerifiedAuth + 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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index ad9f6d2..b19286c 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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 diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index 6599ae1..e1f2d26 100644 --- a/src/Vervis/Ticket.hs +++ b/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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index b2704b2..53dcad7 100644 --- a/src/Web/ActivityPub.hs +++ b/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"