mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-06 06:26:45 +09:00
734 lines
34 KiB
Haskell
734 lines
34 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Vervis.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|
|
|
<p>
|
|
<a href=@{SharerR shrUser}>{shr2text shrUser}
|
|
\ commented on a #
|
|
<a href=#{renderFedURI 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' (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|
|
|
<p>
|
|
<a href=@{SharerR shrUser}>
|
|
#{shr2text shrUser}
|
|
's ticket accepted by project #
|
|
<a href=@{ProjectR shrProject prjProject}>
|
|
./s/#{shr2text shrProject}/p/#{prj2text prjProject}
|
|
: #
|
|
<a href=@{TicketR shrProject prjProject num}>
|
|
#{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")])
|