mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-06 07:16:45 +09:00
8fc5c80dd6
FedURIs, until now, have been requiring HTTPS, and no port number, and DNS internet domain names. This works just fine on the forge fediverse, but it makes local dev builds much less useful. This patch introduces URI types that have a type tag specifying one of 2 modes: - `Dev`: Works with URIs like `http://localhost:3000/s/fr33` - `Fed`: Works with URIs like `https://dev.community/s/fr33` This should allow even to run multiple federating instances for development, without needing TLS or reverse proxies or editing the hosts files or anything like that.
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.FedURI
|
|
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 :: 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"
|
|
(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 (ObjURI 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 ObjURI hContext luContext = 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 p@(ObjURI hParent luParent) -> do
|
|
mrm <- lift $ runMaybeT $ do
|
|
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
|
|
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
|
|
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|
|
|
<p>
|
|
<a href=@{SharerR shrUser}>#{shr2text shrUser}
|
|
\ commented on a #
|
|
<a href=#{renderObjURI uContext}>ticket</a>.
|
|
|]
|
|
(lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary
|
|
moreRemotes <- deliverLocal pid obiid localRecips mcollections
|
|
unless (federation || null moreRemotes) $
|
|
throwE "Federation disabled but remote collection members found"
|
|
remotesHttp <- lift $ deliverRemoteDB' (objUriAuthority uContext) obiid remoteRecips moreRemotes
|
|
return (lmid, obiid, doc, remotesHttp)
|
|
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
|
|
return lmid
|
|
where
|
|
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) FedURI)
|
|
, [ShrIdent]
|
|
, Maybe (ShrIdent, PrjIdent, Int)
|
|
, [(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, 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 URIMode)
|
|
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
|
|
, noteSource = source
|
|
, noteContent = content
|
|
}
|
|
}
|
|
}
|
|
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 (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 URIMode
|
|
-> Offer URIMode
|
|
-> 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"
|
|
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 = ObjURI 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
|
|
let dont = Authority "dont-do.any-forwarding" Nothing
|
|
remotesHttp <- do
|
|
moreRemotes <- deliverLocal now sid fsid obiid
|
|
deliverRemoteDB' dont obiid [] moreRemotes
|
|
site <- askSite
|
|
liftIO $ runWorker (deliverRemoteHttp dont 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 ObjURI . bimap E.unValue E.unValue) remotes
|
|
}
|
|
provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])
|