{- This file is part of Vervis. - - Written in 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - - The author(s) have dedicated all copyright and related and neighboring - rights to this software to the public domain worldwide. This software is - distributed without any warranty. - - You should have received a copy of the CC0 Public Domain Dedication along - with this software. If not, see - . -} module Vervis.API ( createNoteC , offerTicketC , getFollowersCollection ) where import Control.Applicative import Control.Concurrent.MVar import Control.Concurrent.STM.TVar import Control.Exception hiding (Handler, try) import Control.Monad import Control.Monad.Logger.CallStack import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Crypto.Hash import Data.Aeson import Data.Bifunctor import Data.ByteString (ByteString) import Data.Either import Data.Foldable import Data.Function import Data.List (sort, deleteBy, nub, union, unionBy, partition) import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Maybe import Data.Semigroup import Data.Text (Text) import Data.Text.Encoding import Data.Time.Calendar import Data.Time.Clock import Data.Time.Units import Data.Traversable import Data.Tuple import Database.Persist hiding (deleteBy) import Database.Persist.Sql hiding (deleteBy) import Network.HTTP.Client import Network.HTTP.Types.Header import Network.HTTP.Types.URI import Network.TLS hiding (SHA256) import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import UnliftIO.Exception (try) import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Persist.Core import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.List.Ordered as LO import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Database.Esqueleto as E import qualified Network.Wai as W import Data.Time.Interval import Network.HTTP.Signature hiding (requestHeaders) import Yesod.HttpSignature import Crypto.PublicVerifKey import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest import Web.ActivityPub hiding (Follow, Ticket) import Yesod.ActivityPub import Yesod.Auth.Unverified import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Data.Aeson.Local import Data.Either.Local import Data.List.Local import Data.List.NonEmpty.Local import Data.Maybe.Local import Data.Tuple.Local import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub import Vervis.ActorKey import Vervis.API.Recipient import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Ticket import Vervis.RemoteActorStore import Vervis.Settings verifyIsLoggedInUser :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, OutboxId, ShrIdent) verifyIsLoggedInUser lu t = do Entity pid p <- requireVerifiedAuth s <- lift $ getJust $ personIdent p route2local <- getEncodeRouteLocal let shr = sharerIdent s if route2local (SharerR shr) == lu then return (pid, personOutbox p, shr) else throwE t verifyAuthor :: ShrIdent -> LocalURI -> Text -> ExceptT Text AppDB (PersonId, OutboxId) verifyAuthor shr lu t = ExceptT $ do Entity sid s <- getBy404 $ UniqueSharer shr Entity pid p <- getBy404 $ UniquePersonIdent sid encodeRouteLocal <- getEncodeRouteLocal return $ if encodeRouteLocal (SharerR shr) == lu then Right (pid, personOutbox p) else Left t parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId) parseComment luParent = do route <- case decodeRouteLocal luParent of Nothing -> throwE "Not a local route" Just r -> return r case route of MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid" _ -> throwE "Not a local message route" -- | 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 :: Text -> Note -> 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" (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, num) -> do mt <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid t <- MaybeT $ getValBy $ UniqueTicket jid num return (sid, projectInbox j, projectFollowers j, t) (sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket" let did = ticketDiscuss t mmidParent <- for mparent $ \ parent -> case parent of Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent Right (hParent, luParent) -> do mrm <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hParent MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent 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 lift $ insertUnique_ $ Follow pid (ticketFollowers t) False return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject)) Nothing -> do (rd, rdnew) <- lift $ do let (hContext, luContext) = f2l uContext iid <- either entityKey id <$> insertBy' (Instance hContext) mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext case mrd of Just rd -> return (rd, False) Nothing -> do did <- insert Discussion let rd = RemoteDiscussion iid luContext 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 (hParent, luParent) -> do mrm <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hParent MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent case mrm of Nothing -> return $ Right $ l2f hParent luParent 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' (furiHost uContext) obiid remoteRecips moreRemotes return (lmid, obiid, doc, remotesHttp) lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obiid doc remotesHttp return lmid where nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a) nonEmptyE l e = case nonEmpty l of Nothing -> throwE e Just ne -> return ne parseRecipsContextParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)) , [ShrIdent] , Maybe (ShrIdent, PrjIdent, Int) , [(Text, NonEmpty LocalURI)] ) parseRecipsContextParent uContext muParent = do (localsSet, remotes) <- do mrecips <- parseAudience aud fromMaybeE mrecips "Note without recipients" let (hContext, luContext) = f2l 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) (Text, LocalURI))) parseParent _ Nothing = return Nothing parseParent uContext (Just uParent) = if uParent == uContext then return Nothing else Just <$> do let (hParent, luParent) = f2l uParent parentLocal <- hostIsLocal hParent if parentLocal then Left <$> parseComment luParent else return $ Right (hParent, luParent) parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int) parseContextTicket luContext = do route <- case decodeRouteLocal luContext of Nothing -> throwE "Local context isn't a valid route" Just r -> return r case route of TicketR 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, Int) -> 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 (localRecipTicketRelated 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) insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary = do now <- liftIO getCurrentTime mid <- insert Message { messageCreated = now , messageSource = source , messageContent = content , messageParent = case meparent of Just (Left midParent) -> Just midParent _ -> Nothing , messageRoot = did } let activity luAct luNote = Doc host Activity { activityId = Just luAct , activityActor = luAttrib , activitySummary = Just $ TextHtml $ TL.toStrict $ renderHtml summary , activityAudience = aud , activitySpecific = CreateActivity Create { createObject = Note { noteId = Just luNote , noteAttrib = luAttrib , noteAudience = aud , noteReplyTo = Just $ fromMaybe uContext muParent , noteContext = Just uContext , notePublished = Just now , noteContent = content } } } tempUri = LocalURI "" "" 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, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] 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" -} offerTicketC :: ShrIdent -> TextHtml -> Audience -> Offer -> Handler (Either Text OutboxItemId) offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do (hProject, shrProject, prjProject) <- parseTarget uTarget deps <- checkOffer hProject shrProject prjProject (localRecips, remoteRecips) <- do mrecips <- parseAudience audience fromMaybeE mrecips "Offer with no recipients" federation <- asksSite $ appFederation . appSettings unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients specified" checkRecips hProject shrProject prjProject localRecips now <- liftIO getCurrentTime (obiid, doc, remotesHttp) <- runDBExcept $ do (pidAuthor, obidAuthor) <- verifyAuthor shrUser (AP.ticketAttributedTo ticket) "Ticket attributed to different actor" mprojAndDeps <- do targetIsLocal <- hostIsLocal hProject if targetIsLocal then Just <$> getProjectAndDeps shrProject prjProject deps else return Nothing (obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor moreRemotes <- lift $ deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer localRecips unless (federation || null moreRemotes) $ throwE "Federation disabled but remote collection members found" remotesHttp <- lift $ deliverRemoteDB' hProject obiid remoteRecips moreRemotes return (obiid, doc, remotesHttp) lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp hProject obiid doc remotesHttp return obiid where checkOffer hProject shrProject prjProject = do verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'" verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'" verifyNothingE (AP.ticketName ticket) "Ticket with 'name'" verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'" when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved" unless (null $ AP.ticketDependedBy ticket) $ throwE "Ticket has rdeps" traverse checkDep' $ AP.ticketDependsOn ticket where checkDep' = checkDep hProject shrProject prjProject checkRecips hProject shrProject prjProject localRecips = do local <- hostIsLocal hProject if local then traverse (verifyOfferRecips shrProject prjProject) localRecips else traverse (verifyOnlySharer . snd) localRecips where verifyOfferRecips shr prj (shr', lsrSet) = if shr == shr' then unless (lsrSet == offerRecips prj) $ throwE "Unexpected offer target recipient set" else verifyOnlySharer lsrSet where offerRecips prj = LocalSharerRelatedSet { localRecipSharerDirect = LocalSharerDirectSet False , localRecipProjectRelated = [ ( prj , LocalProjectRelatedSet { localRecipProjectDirect = LocalProjectDirectSet True True True , localRecipTicketRelated = [] } ) ] } verifyOnlySharer lsrSet = unless (null $ localRecipProjectRelated lsrSet) $ throwE "Unexpected recipients unrelated to offer target" insertToOutbox now obid = do hLocal <- asksSite siteInstanceHost let activity mluAct = Doc hLocal Activity { activityId = mluAct , activityActor = AP.ticketAttributedTo ticket , activitySummary = Just summary , activityAudience = audience , activitySpecific = OfferActivity offer } obiid <- insert OutboxItem { outboxItemOutbox = obid , outboxItemActivity = persistJSONObjectFromDoc $ activity Nothing , outboxItemPublished = now } encodeRouteLocal <- getEncodeRouteLocal obikhid <- encodeKeyHashid obiid let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid doc = activity $ Just luAct update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc, luAct) deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects) -> do (pids, remotes) <- traverseCollect (uncurry $ deliverLocalProject shr) projects pids' <- do mpid <- if localRecipSharer sharer then runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr MaybeT $ getKeyBy $ UniquePersonIdent sid else return Nothing return $ case mpid of Nothing -> pids Just pid -> LO.insertSet pid pids return (pids', remotes) for_ (L.delete pidAuthor pids) $ \ pid -> do ibid <- personInbox <$> getJust pid ibiid <- insert $ InboxItem True insert_ $ InboxItemLocal ibid obiid ibiid return remotes where traverseCollect action values = bimap collectPids collectRemotes . unzip <$> traverse action values where collectPids = foldl' LO.union [] collectRemotes = foldl' unionRemotes [] forCollect = flip traverseCollect deliverLocalProject shr prj (LocalProjectRelatedSet project _) = case mprojAndDeps of Just (sid, jid, ibid, fsid, tids) | shr == shrProject && prj == prjProject && localRecipProject project -> do insertToInbox ibid num <- ((subtract 1) . projectNextTicket) <$> updateGet jid [ProjectNextTicket +=. 1] (obiidAccept, docAccept) <- insertAccept pidAuthor sid jid fsid luOffer num insertTicket jid tids num obiidAccept publishAccept pidAuthor sid jid fsid luOffer num obiidAccept docAccept (pidsTeam, remotesTeam) <- if localRecipProjectTeam project then getProjectTeam sid else return ([], []) (pidsFollowers, remotesFollowers) <- if localRecipProjectFollowers project then getFollowers fsid else return ([], []) return ( LO.union pidsTeam pidsFollowers , unionRemotes remotesTeam remotesFollowers ) _ -> return ([], []) where insertToInbox ibid = do ibiid <- insert $ InboxItem False insert_ $ InboxItemLocal ibid obiid ibiid insertAccept pidAuthor sid jid fsid luOffer num = do now <- liftIO getCurrentTime obid <- projectOutbox <$> getJust jid insertToOutbox now obid where insertToOutbox now obid = do summary <- TextHtml . TL.toStrict . renderHtml <$> withUrlRenderer [hamlet|

#{shr2text shrUser} 's ticket accepted by project # ./s/#{shr2text shrProject}/p/#{prj2text prjProject} : # #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. |] hLocal <- asksSite siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome let recips = map encodeRouteHome [ SharerR shrUser , ProjectTeamR shrProject prjProject , ProjectFollowersR shrProject prjProject ] accept luAct = Doc hLocal Activity { activityId = luAct , activityActor = encodeRouteLocal $ ProjectR shrProject prjProject , activitySummary = Just summary , activityAudience = Audience recips [] [] [] [] [] , activitySpecific = AcceptActivity Accept { acceptObject = l2f hLocal luOffer , acceptResult = encodeRouteLocal $ TicketR shrProject prjProject num } } obiid <- insert OutboxItem { outboxItemOutbox = obid , outboxItemActivity = persistJSONObjectFromDoc $ accept Nothing , outboxItemPublished = now } encodeRouteLocal <- getEncodeRouteLocal obikhid <- encodeKeyHashid obiid let luAct = encodeRouteLocal $ ProjectOutboxItemR shrProject prjProject obikhid doc = accept $ Just luAct update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc) insertTicket jid tidsDeps next obiidAccept = do did <- insert Discussion fsid <- insert FollowerSet tid <- insert Ticket { ticketProject = jid , ticketNumber = next , ticketCreated = now , ticketTitle = unTextHtml $ AP.ticketSummary ticket , ticketSource = unTextPandocMarkdown $ AP.ticketSource ticket , ticketDescription = unTextHtml $ AP.ticketContent ticket , ticketAssignee = Nothing , ticketStatus = TSNew , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 , ticketCloser = Nothing , ticketDiscuss = did , ticketFollowers = fsid , ticketAccept = obiidAccept } insert TicketAuthorLocal { ticketAuthorLocalTicket = tid , ticketAuthorLocalAuthor = pidAuthor , ticketAuthorLocalOffer = obiid } insertMany_ $ map (TicketDependency tid) tidsDeps insert_ $ Follow pidAuthor fsid False publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do now <- liftIO getCurrentTime remotesHttp <- do moreRemotes <- deliverLocal now sid fsid obiid deliverRemoteDB' "dont-do.any-forwarding" obiid [] moreRemotes site <- askSite liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site where deliverLocal now sid fsid obiid = do (pidsTeam, remotesTeam) <- getProjectTeam sid (pidsFollowers, remotesFollowers) <- getFollowers fsid let pids = LO.insertSet pidAuthor $ LO.union pidsTeam pidsFollowers remotes = unionRemotes remotesTeam remotesFollowers for_ pids $ \ pid -> do ibid <- personInbox <$> getJust pid ibiid <- insert $ InboxItem True insert_ $ InboxItemLocal ibid obiid ibiid return remotes getFollowersCollection :: Route App -> AppDB FollowerSetId -> Handler TypedContent getFollowersCollection here getFsid = do (locals, remotes) <- runDB $ do fsid <- getFsid (,) <$> do pids <- map (followPerson . entityVal) <$> selectList [FollowTarget ==. fsid] [] sids <- map (personIdent . entityVal) <$> selectList [PersonId <-. pids] [] map (sharerIdent . entityVal) <$> selectList [SharerId <-. sids] [] <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid return ( i E.^. InstanceHost , ra E.^. RemoteActorIdent ) encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome let followersAP = Collection { collectionId = encodeRouteLocal here , collectionType = CollectionTypeUnordered , collectionTotalItems = Just $ length locals + length remotes , collectionCurrent = Nothing , collectionFirst = Nothing , collectionLast = Nothing , collectionItems = map (encodeRouteHome . SharerR) locals ++ map (uncurry l2f . bimap E.unValue E.unValue) remotes } provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])