1139 lines
42 KiB
Haskell
1139 lines
42 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2019, 2020, 2022, 2023 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.Client
|
|
( makeServerInput
|
|
|
|
, comment
|
|
--, createThread
|
|
--, createReply
|
|
--, follow
|
|
--, followSharer
|
|
--, followProject
|
|
--, followTicket
|
|
--, followRepo
|
|
, offerIssue
|
|
--, resolve
|
|
--, undoFollowSharer
|
|
--, undoFollowProject
|
|
--, undoFollowTicket
|
|
--, undoFollowRepo
|
|
--, unresolve
|
|
, offerPatches
|
|
, offerMerge
|
|
, applyPatches
|
|
, createDeck
|
|
, createLoom
|
|
, createRepo
|
|
, createProject
|
|
, invite
|
|
, remove
|
|
)
|
|
where
|
|
|
|
import Control.Exception.Base
|
|
import Control.Monad
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Reader
|
|
import Data.Bifunctor
|
|
import Data.Bitraversable
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import Data.Maybe
|
|
import Data.Text (Text)
|
|
import Database.Persist
|
|
import Database.Persist.Sql
|
|
import Text.Blaze.Html (preEscapedToHtml)
|
|
import Text.Blaze.Html.Renderer.Text
|
|
import Text.Hamlet
|
|
import Yesod.Core
|
|
import Yesod.Core.Handler
|
|
import Yesod.Persist.Core
|
|
|
|
import qualified Data.List.NonEmpty as NE
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy as TL
|
|
|
|
import Development.PatchMediaType
|
|
import Network.FedURI
|
|
import Web.ActivityPub hiding (Follow, Ticket, Project (..), Repo, ActorLocal (..))
|
|
import Web.Text
|
|
import Yesod.ActivityPub
|
|
import Yesod.FedURI
|
|
import Yesod.Hashids
|
|
import Yesod.MonadSite
|
|
|
|
import qualified Web.ActivityPub as AP
|
|
|
|
import Control.Monad.Trans.Except.Local
|
|
import Data.Either.Local
|
|
import Database.Persist.Local
|
|
|
|
import Vervis.ActivityPub
|
|
import Vervis.Actor
|
|
import Vervis.Actor2
|
|
import Vervis.Cloth
|
|
import Vervis.Data.Collab
|
|
import Vervis.Data.Ticket
|
|
import Vervis.FedURI
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Recipient
|
|
import Vervis.RemoteActorStore
|
|
import Vervis.Ticket
|
|
|
|
makeServerInput
|
|
:: (MonadSite m, SiteEnv m ~ App)
|
|
=> Maybe FedURI
|
|
-> Maybe HTML
|
|
-> [Aud URIMode]
|
|
-> AP.SpecificActivity URIMode
|
|
-> m ( RecipientRoutes
|
|
, [(Host, NonEmpty LocalURI)]
|
|
, [Host]
|
|
, AP.Action URIMode
|
|
)
|
|
makeServerInput maybeCapURI maybeSummary audience specific = do
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
|
collectAudience audience
|
|
recips = map encodeRouteHome audLocal ++ audRemote
|
|
action = AP.Action
|
|
{ AP.actionCapability = maybeCapURI
|
|
, AP.actionSummary = maybeSummary
|
|
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
|
, AP.actionFulfills = []
|
|
, AP.actionSpecific = specific
|
|
}
|
|
return (recipientSet, remoteActors, fwdHosts, action)
|
|
|
|
comment
|
|
:: KeyHashid Person
|
|
-> PandocMarkdown
|
|
-> [LocalActorBy KeyHashid]
|
|
-> [LocalStageBy KeyHashid]
|
|
-> Route App
|
|
-> Maybe FedURI
|
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Note URIMode)
|
|
comment senderHash source actors stages topicR muParent = do
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
content <- ExceptT . pure $ renderPandocMarkdown source
|
|
let audience = [AudLocal actors stages]
|
|
uTopic = encodeRouteHome topicR
|
|
note = AP.Note
|
|
{ AP.noteId = Nothing
|
|
, AP.noteAttrib = encodeRouteLocal $ PersonR senderHash
|
|
, AP.noteAudience = emptyAudience
|
|
, AP.noteReplyTo = Just $ fromMaybe uTopic muParent
|
|
, AP.noteContext = Just uTopic
|
|
, AP.notePublished = Nothing
|
|
, AP.noteSource = source
|
|
, AP.noteContent = content
|
|
}
|
|
return (Nothing, audience, note)
|
|
|
|
{-
|
|
createThread
|
|
:: KeyHashid Person
|
|
-> PandocMarkdown
|
|
-> Host
|
|
-> [Route App]
|
|
-> [Route App]
|
|
-> Route App
|
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Note URIMode)
|
|
createThread senderHash source hDest recipsA recipsC context = runExceptT $ do
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
|
|
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
|
|
let uContext = encodeRecipRoute context
|
|
recips = recipsA ++ recipsC
|
|
return Note
|
|
{ noteId = Nothing
|
|
, noteAttrib = encodeRouteLocal $ SharerR shrAuthor
|
|
, noteAudience = Audience
|
|
{ audienceTo = map encodeRecipRoute recips
|
|
, audienceBto = []
|
|
, audienceCc = []
|
|
, audienceBcc = []
|
|
, audienceGeneral = []
|
|
, audienceNonActors = map encodeRecipRoute recipsC
|
|
}
|
|
, noteReplyTo = Just uContext
|
|
, noteContext = Just uContext
|
|
, notePublished = Nothing
|
|
, noteSource = msg
|
|
, noteContent = contentHtml
|
|
}
|
|
|
|
createReply
|
|
:: ShrIdent
|
|
-> TextPandocMarkdown
|
|
-> Host
|
|
-> [Route App]
|
|
-> [Route App]
|
|
-> Route App
|
|
-> MessageId
|
|
-> Handler (Either Text (Note URIMode))
|
|
createReply shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context midParent = runExceptT $ do
|
|
error "Temporarily disabled"
|
|
{-
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
|
|
uParent <- lift $ runDB $ do
|
|
_m <- get404 midParent
|
|
mlocal <- getBy $ UniqueLocalMessage midParent
|
|
mremote <- getValBy $ UniqueRemoteMessage midParent
|
|
case (mlocal, mremote) of
|
|
(Nothing, Nothing) -> error "Message with no author"
|
|
(Just _, Just _) -> error "Message used as both local and remote"
|
|
(Just (Entity lmidParent lm), Nothing) -> do
|
|
p <- getJust $ localMessageAuthor lm
|
|
s <- getJust $ personIdent p
|
|
lmkhid <- encodeKeyHashid lmidParent
|
|
return $ encodeRouteHome $ MessageR (sharerIdent s) lmkhid
|
|
(Nothing, Just rm) -> do
|
|
ro <- getJust $ remoteMessageIdent rm
|
|
i <- getJust $ remoteObjectInstance ro
|
|
return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
|
|
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
|
|
let uContext = encodeRecipRoute context
|
|
recips = recipsA ++ recipsC
|
|
return Note
|
|
{ noteId = Nothing
|
|
, noteAttrib = encodeRouteLocal $ SharerR shrAuthor
|
|
, noteAudience = Audience
|
|
{ audienceTo = map encodeRecipRoute recips
|
|
, audienceBto = []
|
|
, audienceCc = []
|
|
, audienceBcc = []
|
|
, audienceGeneral = []
|
|
, audienceNonActors = map encodeRecipRoute recipsC
|
|
}
|
|
, noteReplyTo = Just uParent
|
|
, noteContext = Just uContext
|
|
, notePublished = Nothing
|
|
, noteSource = msg
|
|
, noteContent = contentHtml
|
|
}
|
|
-}
|
|
|
|
follow
|
|
:: (MonadHandler m, HandlerSite m ~ App)
|
|
=> ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
|
follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do
|
|
error "Temporarily disabled"
|
|
{-
|
|
summary <-
|
|
TextHtml . TL.toStrict . renderHtml <$>
|
|
withUrlRenderer
|
|
[hamlet|
|
|
<p>
|
|
<a href=@{SharerR shrAuthor}>
|
|
#{shr2text shrAuthor}
|
|
\ requested to follow #
|
|
<a href=#{renderObjURI uObject}>
|
|
#{renderAuthority hObject}#{localUriPath luObject}
|
|
\.
|
|
|]
|
|
let followAP = AP.Follow
|
|
{ followObject = uObject
|
|
, followContext =
|
|
if uObject == uRecip
|
|
then Nothing
|
|
else Just uRecip
|
|
, followHide = hide
|
|
}
|
|
audience = Audience [uRecip] [] [] [] [] []
|
|
return (summary, audience, followAP)
|
|
-}
|
|
|
|
followSharer
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
|
followSharer shrAuthor shrObject hide = do
|
|
error "Temporarily disabled"
|
|
{-
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
let uObject = encodeRouteHome $ SharerR shrObject
|
|
follow shrAuthor uObject uObject hide
|
|
-}
|
|
|
|
followProject
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent -> ShrIdent -> PrjIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
|
followProject shrAuthor shrObject prjObject hide = do
|
|
error "Temporarily disabled"
|
|
{-
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
let uObject = encodeRouteHome $ ProjectR shrObject prjObject
|
|
follow shrAuthor uObject uObject hide
|
|
-}
|
|
|
|
followTicket
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent -> ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
|
followTicket shrAuthor shrObject prjObject numObject hide = do
|
|
error "Temporarily disabled"
|
|
{-
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
let uObject = encodeRouteHome $ ProjectTicketR shrObject prjObject numObject
|
|
uRecip = encodeRouteHome $ ProjectR shrObject prjObject
|
|
follow shrAuthor uObject uRecip hide
|
|
-}
|
|
|
|
followRepo
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent -> ShrIdent -> RpIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
|
followRepo shrAuthor shrObject rpObject hide = do
|
|
error "Temporarily disabled"
|
|
{-
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
let uObject = encodeRouteHome $ RepoR shrObject rpObject
|
|
follow shrAuthor uObject uObject hide
|
|
-}
|
|
-}
|
|
|
|
offerIssue
|
|
:: KeyHashid Person -> Text -> PandocMarkdown -> FedURI
|
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode)
|
|
offerIssue senderHash title desc uTracker = do
|
|
|
|
tracker <- do
|
|
tracker <- checkTracker uTracker
|
|
case tracker of
|
|
TrackerDeck deckID -> Left <$> encodeKeyHashid deckID
|
|
TrackerLoom _ -> throwE "Local patch tracker doesn't take issues"
|
|
TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do
|
|
instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker)
|
|
result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker
|
|
case result of
|
|
Left Nothing -> throwE "Tracker @id mismatch"
|
|
Left (Just err) -> throwE $ T.pack $ displayException err
|
|
Right Nothing -> throwE "Tracker isn't an actor"
|
|
Right (Just actor) -> return (entityVal actor, uTracker)
|
|
|
|
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
hLocal <- asksSite siteInstanceHost
|
|
|
|
let audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
audTracker =
|
|
case tracker of
|
|
Left deckHash ->
|
|
AudLocal
|
|
[LocalActorDeck deckHash]
|
|
[LocalStageDeckFollowers deckHash]
|
|
Right (remoteActor, ObjURI hTracker luTracker) ->
|
|
AudRemote hTracker
|
|
[luTracker]
|
|
(maybeToList $ remoteActorFollowers remoteActor)
|
|
|
|
audience = [audAuthor, audTracker]
|
|
|
|
ticket = AP.Ticket
|
|
{ AP.ticketLocal = Nothing
|
|
, AP.ticketAttributedTo = encodeRouteLocal $ PersonR senderHash
|
|
, AP.ticketPublished = Nothing
|
|
, AP.ticketUpdated = Nothing
|
|
, AP.ticketContext = Nothing
|
|
, AP.ticketSummary = encodeEntities title
|
|
, AP.ticketContent = descHtml
|
|
, AP.ticketSource = desc
|
|
, AP.ticketAssignedTo = Nothing
|
|
, AP.ticketResolved = Nothing
|
|
, AP.ticketAttachment = Nothing
|
|
}
|
|
|
|
return (Nothing, audience, ticket)
|
|
|
|
{-
|
|
{-
|
|
resolve
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent
|
|
-> FedURI
|
|
-> m (Either Text (Maybe TextHtml, Audience URIMode, Resolve URIMode))
|
|
resolve shrUser uObject = runExceptT $ do
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
wiFollowers <- askWorkItemFollowers
|
|
object <- parseWorkItem "Resolve object" uObject
|
|
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Object" object
|
|
let audAuthor =
|
|
AudLocal
|
|
[LocalActorSharer shrUser]
|
|
[LocalPersonCollectionSharerFollowers shrUser]
|
|
audTicketContext = contextAudience context
|
|
audTicketAuthor = authorAudience author
|
|
audTicketFollowers =
|
|
case ident of
|
|
Left (wi, _ltid) -> AudLocal [] [wiFollowers wi]
|
|
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
|
|
|
|
(_, _, _, audLocal, audRemote) =
|
|
collectAudience $
|
|
audAuthor :
|
|
audTicketAuthor :
|
|
audTicketFollowers :
|
|
audTicketContext
|
|
|
|
recips = map encodeRouteHome audLocal ++ audRemote
|
|
return (Nothing, Audience recips [] [] [] [] [], Resolve uObject)
|
|
-}
|
|
|
|
undoFollow
|
|
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent
|
|
-> PersonId
|
|
-> ExceptT Text (ReaderT SqlBackend m) FollowerSetId
|
|
-> Text
|
|
-> Route App
|
|
-> Route App
|
|
-> m (Either Text (TextHtml, Audience URIMode, Undo URIMode))
|
|
undoFollow shrAuthor pidAuthor getFsid typ objRoute recipRoute = runExceptT $ do
|
|
error "Temporarily disabled"
|
|
{-
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
obiidFollow <- runSiteDBExcept $ do
|
|
fsid <- getFsid
|
|
mf <- lift $ getValBy $ UniqueFollow pidAuthor fsid
|
|
followFollow <$> fromMaybeE mf ("Not following this " <> typ)
|
|
obikhidFollow <- encodeKeyHashid obiidFollow
|
|
summary <- do
|
|
hLocal <- asksSite siteInstanceHost
|
|
TextHtml . TL.toStrict . renderHtml <$>
|
|
withUrlRenderer
|
|
[hamlet|
|
|
<p>
|
|
<a href=@{SharerR shrAuthor}>
|
|
#{shr2text shrAuthor}
|
|
\ unfollowed #
|
|
<a href=@{objRoute}>
|
|
#{renderAuthority hLocal}#{localUriPath $ encodeRouteLocal objRoute}
|
|
\.
|
|
|]
|
|
let undo = Undo
|
|
{ undoObject =
|
|
encodeRouteHome $ SharerOutboxItemR shrAuthor obikhidFollow
|
|
}
|
|
audience = Audience [encodeRouteHome recipRoute] [] [] [] [] []
|
|
return (summary, audience, undo)
|
|
-}
|
|
|
|
undoFollowSharer
|
|
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent
|
|
-> PersonId
|
|
-> ShrIdent
|
|
-> m (Either Text (TextHtml, Audience URIMode, Undo URIMode))
|
|
undoFollowSharer shrAuthor pidAuthor shrFollowee =
|
|
error "Temporarily disabled"
|
|
{-
|
|
undoFollow shrAuthor pidAuthor getFsid "sharer" objRoute objRoute
|
|
where
|
|
objRoute = SharerR shrFollowee
|
|
getFsid = do
|
|
sidFollowee <- do
|
|
msid <- lift $ getKeyBy $ UniqueSharer shrFollowee
|
|
fromMaybeE msid "No such local sharer"
|
|
mp <- lift $ getValBy $ UniquePersonIdent sidFollowee
|
|
personFollowers <$>
|
|
fromMaybeE mp "Unfollow target local sharer isn't a person"
|
|
|
|
undoFollowProject
|
|
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent
|
|
-> PersonId
|
|
-> ShrIdent
|
|
-> PrjIdent
|
|
-> m (Either Text (TextHtml, Audience URIMode, Undo URIMode))
|
|
undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee =
|
|
undoFollow shrAuthor pidAuthor getFsid "project" objRoute objRoute
|
|
where
|
|
objRoute = ProjectR shrFollowee prjFollowee
|
|
getFsid = do
|
|
sidFollowee <- do
|
|
msid <- lift $ getKeyBy $ UniqueSharer shrFollowee
|
|
fromMaybeE msid "No such local sharer"
|
|
mj <- lift $ getValBy $ UniqueProject prjFollowee sidFollowee
|
|
j <- fromMaybeE mj "Unfollow target no such local project"
|
|
lift $ actorFollowers <$> getJust (projectActor j)
|
|
-}
|
|
|
|
undoFollowTicket
|
|
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent
|
|
-> PersonId
|
|
-> ShrIdent
|
|
-> PrjIdent
|
|
-> KeyHashid LocalTicket
|
|
-> m (Either Text (TextHtml, Audience URIMode, Undo URIMode))
|
|
undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee =
|
|
error "Temporarily disabled"
|
|
{-
|
|
undoFollow shrAuthor pidAuthor getFsid "project" objRoute recipRoute
|
|
where
|
|
objRoute = ProjectTicketR shrFollowee prjFollowee numFollowee
|
|
recipRoute = ProjectR shrFollowee prjFollowee
|
|
getFsid = do
|
|
sid <- do
|
|
msid <- lift $ getKeyBy $ UniqueSharer shrFollowee
|
|
fromMaybeE msid "No such local sharer"
|
|
jid <- do
|
|
mjid <- lift $ getKeyBy $ UniqueProject prjFollowee sid
|
|
fromMaybeE mjid "No such local project"
|
|
ltid <- decodeKeyHashidE numFollowee "Invalid hashid for context"
|
|
mlt <- lift $ get ltid
|
|
lt <- fromMaybeE mlt "Unfollow target no such local ticket"
|
|
tclid <- do
|
|
mtclid <-
|
|
lift $ getKeyBy $
|
|
UniqueTicketContextLocal $ localTicketTicket lt
|
|
fromMaybeE mtclid "Unfollow target ticket isn't of local context"
|
|
tpl <- do
|
|
mtpl <- lift $ getValBy $ UniqueTicketProjectLocal tclid
|
|
fromMaybeE mtpl "Unfollow target ticket local ctx isn't a project"
|
|
unless (ticketProjectLocalProject tpl == jid) $
|
|
throwE "Hashid doesn't match sharer/project"
|
|
return $ localTicketFollowers lt
|
|
-}
|
|
|
|
undoFollowRepo
|
|
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent
|
|
-> PersonId
|
|
-> ShrIdent
|
|
-> RpIdent
|
|
-> m (Either Text (TextHtml, Audience URIMode, Undo URIMode))
|
|
undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee =
|
|
error "Temporarily disabled"
|
|
{-
|
|
undoFollow shrAuthor pidAuthor getFsid "repo" objRoute objRoute
|
|
where
|
|
objRoute = RepoR shrFollowee rpFollowee
|
|
getFsid = do
|
|
sidFollowee <- do
|
|
msid <- lift $ getKeyBy $ UniqueSharer shrFollowee
|
|
fromMaybeE msid "No such local sharer"
|
|
mr <- lift $ getValBy $ UniqueRepo rpFollowee sidFollowee
|
|
repoFollowers <$>
|
|
fromMaybeE mr "Unfollow target no such local repo"
|
|
-}
|
|
|
|
unresolve
|
|
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> ShrIdent
|
|
-> FedURI
|
|
-> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode))
|
|
unresolve shrUser uTicket = runExceptT $ do
|
|
error "Temporarily disabled"
|
|
{-
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
wiFollowers <- askWorkItemFollowers
|
|
ticket <- parseWorkItem "Ticket" uTicket
|
|
WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Ticket" ticket
|
|
uResolve <-
|
|
case ident of
|
|
Left (_, ltid) -> runSiteDBExcept $ do
|
|
mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid
|
|
trid <- fromMaybeE mtrid "Ticket already isn't resolved"
|
|
trx <-
|
|
lift $
|
|
requireEitherAlt
|
|
(getValBy $ UniqueTicketResolveLocal trid)
|
|
(getValBy $ UniqueTicketResolveRemote trid)
|
|
"No TRX"
|
|
"Both TRL and TRR"
|
|
case trx of
|
|
Left trl -> lift $ do
|
|
let obiid = ticketResolveLocalActivity trl
|
|
obid <- outboxItemOutbox <$> getJust obiid
|
|
ent <- getOutboxActorEntity obid
|
|
obikhid <- encodeKeyHashid obiid
|
|
encodeRouteHome . flip outboxItemRoute obikhid <$>
|
|
actorEntityPath ent
|
|
Right trr -> lift $ do
|
|
roid <-
|
|
remoteActivityIdent <$>
|
|
getJust (ticketResolveRemoteActivity trr)
|
|
ro <- getJust roid
|
|
i <- getJust $ remoteObjectInstance ro
|
|
return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
|
|
Right (u, _) -> do
|
|
manager <- asksSite appHttpManager
|
|
Doc _ t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
|
|
case ticketResolved t of
|
|
Nothing -> throwE "Ticket already isn't resolved"
|
|
Just (muBy, _) -> fromMaybeE muBy "Ticket doesn't specify 'resolvedBy'"
|
|
let audAuthor =
|
|
AudLocal
|
|
[LocalActorSharer shrUser]
|
|
[LocalPersonCollectionSharerFollowers shrUser]
|
|
audTicketContext = contextAudience context
|
|
audTicketAuthor = authorAudience author
|
|
audTicketFollowers =
|
|
case ident of
|
|
Left (wi, _ltid) -> AudLocal [] [wiFollowers wi]
|
|
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
|
|
|
|
(_, _, _, audLocal, audRemote) =
|
|
collectAudience $
|
|
audAuthor :
|
|
audTicketAuthor :
|
|
audTicketFollowers :
|
|
audTicketContext
|
|
|
|
recips = map encodeRouteHome audLocal ++ audRemote
|
|
return (Nothing, Audience recips [] [] [] [] [], Undo uResolve)
|
|
-}
|
|
-}
|
|
|
|
offerPatches
|
|
:: KeyHashid Person
|
|
-> Text
|
|
-> PandocMarkdown
|
|
-> FedURI
|
|
-> FedURI
|
|
-> Maybe Text
|
|
-> PatchMediaType
|
|
-> NonEmpty Text
|
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode)
|
|
offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do
|
|
|
|
tracker <- do
|
|
tracker <- checkTracker uTracker
|
|
case tracker of
|
|
TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches"
|
|
TrackerLoom loomID -> Left <$> encodeKeyHashid loomID
|
|
TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do
|
|
instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker)
|
|
result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker
|
|
case result of
|
|
Left Nothing -> throwE "Tracker @id mismatch"
|
|
Left (Just err) -> throwE $ T.pack $ displayException err
|
|
Right Nothing -> throwE "Tracker isn't an actor"
|
|
Right (Just actor) -> return (entityVal actor, uTracker)
|
|
|
|
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
hLocal <- asksSite siteInstanceHost
|
|
|
|
let audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
audTracker =
|
|
case tracker of
|
|
Left loomHash ->
|
|
AudLocal
|
|
[LocalActorLoom loomHash]
|
|
[LocalStageLoomFollowers loomHash]
|
|
Right (remoteActor, ObjURI hTracker luTracker) ->
|
|
AudRemote hTracker
|
|
[luTracker]
|
|
(maybeToList $ remoteActorFollowers remoteActor)
|
|
|
|
audience = [audAuthor, audTracker]
|
|
|
|
luSender = encodeRouteLocal $ PersonR senderHash
|
|
ObjURI hTargetRepo luTargetRepo = uTargetRepo
|
|
ticket = AP.Ticket
|
|
{ AP.ticketLocal = Nothing
|
|
, AP.ticketAttributedTo = luSender
|
|
, AP.ticketPublished = Nothing
|
|
, AP.ticketUpdated = Nothing
|
|
, AP.ticketContext = Nothing
|
|
, AP.ticketSummary = encodeEntities title
|
|
, AP.ticketContent = descHtml
|
|
, AP.ticketSource = desc
|
|
, AP.ticketAssignedTo = Nothing
|
|
, AP.ticketResolved = Nothing
|
|
, AP.ticketAttachment = Just
|
|
( hTargetRepo
|
|
, MergeRequest
|
|
{ mrOrigin = Nothing
|
|
, mrTarget =
|
|
case maybeBranch of
|
|
Nothing -> Left luTargetRepo
|
|
Just b -> Right AP.Branch
|
|
{ AP.branchName = b
|
|
, AP.branchRef = "refs/heads/" <> b
|
|
, AP.branchRepo = luTargetRepo
|
|
}
|
|
, mrBundle = Just $ Right
|
|
( hLocal
|
|
, BundleOffer Nothing $ NE.reverse $ NE.map
|
|
(\ diff -> AP.Patch
|
|
{ AP.patchLocal = Nothing
|
|
, AP.patchAttributedTo = luSender
|
|
, AP.patchPublished = Nothing
|
|
, AP.patchType = typ
|
|
, AP.patchContent = diff
|
|
}
|
|
)
|
|
diffs
|
|
)
|
|
}
|
|
)
|
|
}
|
|
|
|
return (Nothing, audience, ticket)
|
|
|
|
offerMerge
|
|
:: KeyHashid Person
|
|
-> Text
|
|
-> PandocMarkdown
|
|
-> FedURI
|
|
-> FedURI
|
|
-> Maybe Text
|
|
-> FedURI
|
|
-> Maybe Text
|
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode)
|
|
offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do
|
|
|
|
tracker <- do
|
|
tracker <- checkTracker uTracker
|
|
case tracker of
|
|
TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches"
|
|
TrackerLoom loomID -> Left <$> encodeKeyHashid loomID
|
|
TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do
|
|
instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker)
|
|
result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker
|
|
case result of
|
|
Left Nothing -> throwE "Tracker @id mismatch"
|
|
Left (Just err) -> throwE $ T.pack $ displayException err
|
|
Right Nothing -> throwE "Tracker isn't an actor"
|
|
Right (Just actor) -> return (entityVal actor, uTracker)
|
|
|
|
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
hLocal <- asksSite siteInstanceHost
|
|
|
|
let audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
audTracker =
|
|
case tracker of
|
|
Left loomHash ->
|
|
AudLocal
|
|
[LocalActorLoom loomHash]
|
|
[LocalStageLoomFollowers loomHash]
|
|
Right (remoteActor, ObjURI hTracker luTracker) ->
|
|
AudRemote hTracker
|
|
[luTracker]
|
|
(maybeToList $ remoteActorFollowers remoteActor)
|
|
|
|
audience = [audAuthor, audTracker]
|
|
|
|
ObjURI hTargetRepo luTargetRepo = uTargetRepo
|
|
ObjURI hOriginRepo luOriginRepo = uOriginRepo
|
|
ticket = AP.Ticket
|
|
{ AP.ticketLocal = Nothing
|
|
, AP.ticketAttributedTo = encodeRouteLocal $ PersonR senderHash
|
|
, AP.ticketPublished = Nothing
|
|
, AP.ticketUpdated = Nothing
|
|
, AP.ticketContext = Nothing
|
|
, AP.ticketSummary = encodeEntities title
|
|
, AP.ticketContent = descHtml
|
|
, AP.ticketSource = desc
|
|
, AP.ticketAssignedTo = Nothing
|
|
, AP.ticketResolved = Nothing
|
|
, AP.ticketAttachment = Just
|
|
( hTargetRepo
|
|
, MergeRequest
|
|
{ mrOrigin =
|
|
Just $ case maybeOriginBranch of
|
|
Nothing -> Left uOriginRepo
|
|
Just b -> Right
|
|
( hOriginRepo
|
|
, AP.Branch
|
|
{ AP.branchName = b
|
|
, AP.branchRef = "refs/heads/" <> b
|
|
, AP.branchRepo = luOriginRepo
|
|
}
|
|
)
|
|
, mrTarget =
|
|
case maybeTargetBranch of
|
|
Nothing -> Left luTargetRepo
|
|
Just b -> Right AP.Branch
|
|
{ AP.branchName = b
|
|
, AP.branchRef = "refs/heads/" <> b
|
|
, AP.branchRepo = luTargetRepo
|
|
}
|
|
, mrBundle = Nothing
|
|
}
|
|
)
|
|
}
|
|
|
|
return (Nothing, audience, ticket)
|
|
|
|
applyPatches
|
|
:: KeyHashid Person
|
|
-> FedURI
|
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode)
|
|
applyPatches senderHash uObject = do
|
|
|
|
bundle <- parseBundleRoute "Apply object" uObject
|
|
mrInfo <-
|
|
bifor bundle
|
|
(\ (loomID, clothID, _) -> do
|
|
maybeCloth <- lift $ runDB $ getCloth loomID clothID
|
|
(Entity _ loom, Entity _ cloth, _, _, _, _) <-
|
|
fromMaybeE maybeCloth "Local bundle not found in DB"
|
|
return (loomID, clothID, loomRepo loom, ticketLoomBranch cloth)
|
|
)
|
|
(\ uBundle -> do
|
|
manager <- asksSite appHttpManager
|
|
Doc h b <- AP.fetchAP_T manager $ Left uBundle
|
|
let mlocal =
|
|
case b of
|
|
BundleHosted ml _ -> (h,) <$> ml
|
|
BundleOffer ml _ -> ml
|
|
(hBundle, blocal) <-
|
|
fromMaybeE mlocal "Remote bundle doesn't have 'context'"
|
|
unless (hBundle == h) $
|
|
throwE "Bundle @id mismatch!"
|
|
|
|
Doc _ ticket <-
|
|
AP.fetchAP_T manager $
|
|
Left $ ObjURI hBundle $ AP.bundleContext blocal
|
|
(hMR, mr) <- fromMaybeE (AP.ticketAttachment ticket) "Ticket doesn't have attachment"
|
|
(hT, tlocal) <- fromMaybeE (AP.ticketLocal ticket) "Ticket doesn't have followers"
|
|
unless (hT == hBundle) $
|
|
throwE "Ticket @id mismatch!"
|
|
uContext@(ObjURI hC _) <- fromMaybeE (AP.ticketContext ticket) "Ticket doesn't have context"
|
|
unless (hC == hT) $
|
|
throwE "Ticket and tracker on different instances"
|
|
|
|
Doc hC' (AP.Actor aloc adet) <- AP.fetchAP_T manager $ Left uContext
|
|
unless (hC' == hC) $
|
|
throwE "Tracker @id mismatch!"
|
|
unless (AP.actorType adet == AP.ActorTypePatchTracker) $
|
|
throwE "Ticket context isn't a PatchTracker"
|
|
return
|
|
( uContext
|
|
, AP.actorFollowers aloc
|
|
, AP.ticketParticipants tlocal
|
|
, bimap (ObjURI hMR) (hMR,) $ AP.mrTarget mr
|
|
)
|
|
)
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
hashRepo <- getEncodeKeyHashid
|
|
hashLoom <- getEncodeKeyHashid
|
|
hashCloth <- getEncodeKeyHashid
|
|
hLocal <- asksSite siteInstanceHost
|
|
|
|
let target =
|
|
case mrInfo of
|
|
Left (_, _, repoID, maybeBranch) ->
|
|
let luRepo = encodeRouteLocal $ RepoR $ hashRepo repoID
|
|
in case maybeBranch of
|
|
Nothing -> Left $ ObjURI hLocal luRepo
|
|
Just b ->
|
|
Right
|
|
( hLocal
|
|
, AP.Branch
|
|
{ AP.branchName = b
|
|
, AP.branchRef = "/refs/heads/" <> b
|
|
, AP.branchRepo = luRepo
|
|
}
|
|
)
|
|
Right (_, _, _, remoteTarget) -> remoteTarget
|
|
|
|
audAuthor =
|
|
AudLocal
|
|
[]
|
|
[LocalStagePersonFollowers senderHash]
|
|
audCloth =
|
|
case mrInfo of
|
|
Left (loomID, clothID, _, _) ->
|
|
let loomHash = hashLoom loomID
|
|
clothHash = hashCloth clothID
|
|
in AudLocal
|
|
[LocalActorLoom loomHash]
|
|
[ LocalStageLoomFollowers loomHash
|
|
, LocalStageClothFollowers loomHash clothHash
|
|
]
|
|
Right (ObjURI h luTracker, mluFollowers, luTicketFollowers, _) ->
|
|
AudRemote h
|
|
[luTracker]
|
|
(catMaybes [mluFollowers, Just luTicketFollowers])
|
|
|
|
audience = [audAuthor, audCloth]
|
|
|
|
return (Nothing, audience, Apply uObject target)
|
|
|
|
createDeck
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> KeyHashid Person
|
|
-> Text
|
|
-> Text
|
|
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
|
createDeck senderHash name desc = do
|
|
let audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
|
|
audience = [audAuthor]
|
|
|
|
detail = AP.ActorDetail
|
|
{ AP.actorType = AP.ActorTypeTicketTracker
|
|
, AP.actorUsername = Nothing
|
|
, AP.actorName = Just name
|
|
, AP.actorSummary = Just desc
|
|
}
|
|
|
|
return (Nothing, audience, detail)
|
|
|
|
createLoom
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> KeyHashid Person
|
|
-> Text
|
|
-> Text
|
|
-> KeyHashid Repo
|
|
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail, NonEmpty FedURI)
|
|
createLoom senderHash name desc repoHash = do
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
|
|
let audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
audRepo =
|
|
AudLocal
|
|
[LocalActorRepo repoHash]
|
|
[LocalStageRepoFollowers repoHash]
|
|
|
|
audience = [audAuthor, audRepo]
|
|
|
|
detail = AP.ActorDetail
|
|
{ AP.actorType = AP.ActorTypePatchTracker
|
|
, AP.actorUsername = Nothing
|
|
, AP.actorName = Just name
|
|
, AP.actorSummary = Just desc
|
|
}
|
|
repo = encodeRouteHome $ RepoR repoHash
|
|
|
|
return (Nothing, audience, detail, repo :| [])
|
|
|
|
createRepo
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> KeyHashid Person
|
|
-> Text
|
|
-> Text
|
|
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
|
createRepo senderHash name desc = do
|
|
let audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
|
|
audience = [audAuthor]
|
|
|
|
detail = AP.ActorDetail
|
|
{ AP.actorType = AP.ActorTypeRepo
|
|
, AP.actorUsername = Nothing
|
|
, AP.actorName = Just name
|
|
, AP.actorSummary = Just desc
|
|
}
|
|
|
|
return (Nothing, audience, detail)
|
|
|
|
createProject
|
|
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
|
=> KeyHashid Person
|
|
-> Text
|
|
-> Text
|
|
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
|
createProject senderHash name desc = do
|
|
let audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
|
|
audience = [audAuthor]
|
|
|
|
detail = AP.ActorDetail
|
|
{ AP.actorType = AP.ActorTypeProject
|
|
, AP.actorUsername = Nothing
|
|
, AP.actorName = Just name
|
|
, AP.actorSummary = Just desc
|
|
}
|
|
|
|
return (Nothing, audience, detail)
|
|
|
|
invite
|
|
:: PersonId
|
|
-> FedURI
|
|
-> FedURI
|
|
-> AP.Role
|
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Invite URIMode)
|
|
invite personID uRecipient uResource role = do
|
|
|
|
theater <- asksSite appTheater
|
|
env <- asksSite appEnv
|
|
|
|
let activity = AP.Invite role uRecipient uResource
|
|
(_role, resource, recipient) <-
|
|
runActE $ parseInvite (Left $ LocalActorPerson personID) activity
|
|
|
|
-- If resource is remote, we need to get it from DB/HTTP to determine its
|
|
-- managing actor & followers collection
|
|
resourceDB <-
|
|
bitraverse
|
|
hashGrantResource
|
|
(\ u@(ObjURI h lu) -> do
|
|
instanceID <-
|
|
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
|
result <-
|
|
ExceptT $ first (T.pack . show) <$>
|
|
runAct (fetchRemoteResource instanceID h lu)
|
|
case result of
|
|
Left (Entity _ actor) ->
|
|
return (actor, u)
|
|
Right (_objectID, luManager, (Entity _ actor)) ->
|
|
return (actor, ObjURI h luManager)
|
|
)
|
|
resource
|
|
|
|
-- If target is remote, get it via HTTP/DB to determine its followers
|
|
-- collection
|
|
recipientDB <-
|
|
bitraverse
|
|
(runActE . hashGrantRecip)
|
|
(\ u@(ObjURI h lu) -> do
|
|
instanceID <-
|
|
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
|
result <-
|
|
ExceptT $ first (T.pack . displayException) <$>
|
|
fetchRemoteActor instanceID h lu
|
|
case result of
|
|
Left Nothing -> throwE "Recipient @id mismatch"
|
|
Left (Just err) -> throwE $ T.pack $ displayException err
|
|
Right Nothing -> throwE "Recipient isn't an actor"
|
|
Right (Just actor) -> return (entityVal actor, u)
|
|
)
|
|
recipient
|
|
|
|
senderHash <- encodeKeyHashid personID
|
|
|
|
let audResource =
|
|
case resourceDB of
|
|
Left (GrantResourceRepo r) ->
|
|
AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
|
|
Left (GrantResourceDeck d) ->
|
|
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
|
|
Left (GrantResourceLoom l) ->
|
|
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
|
|
Left (GrantResourceProject l) ->
|
|
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
|
|
Right (remoteActor, ObjURI h lu) ->
|
|
AudRemote h
|
|
[lu]
|
|
(maybeToList $ remoteActorFollowers remoteActor)
|
|
audRecipient =
|
|
case recipientDB of
|
|
Left (GrantRecipPerson p) ->
|
|
AudLocal [LocalActorPerson p] [LocalStagePersonFollowers p]
|
|
Right (remoteActor, ObjURI h lu) ->
|
|
AudRemote h
|
|
[lu]
|
|
(maybeToList $ remoteActorFollowers remoteActor)
|
|
audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
|
|
audience = [audResource, audRecipient, audAuthor]
|
|
|
|
return (Nothing, audience, activity)
|
|
|
|
remove
|
|
:: PersonId
|
|
-> FedURI
|
|
-> FedURI
|
|
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Remove URIMode)
|
|
remove personID uRecipient uResource = do
|
|
|
|
theater <- asksSite appTheater
|
|
env <- asksSite appEnv
|
|
|
|
let activity = AP.Remove uRecipient uResource
|
|
(resource, recipient) <-
|
|
runActE $ parseRemove (Left $ LocalActorPerson personID) activity
|
|
|
|
-- If resource is remote, we need to get it from DB/HTTP to determine its
|
|
-- managing actor & followers collection
|
|
resourceDB <-
|
|
bitraverse
|
|
hashGrantResource
|
|
(\ u@(ObjURI h lu) -> do
|
|
instanceID <-
|
|
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
|
result <-
|
|
ExceptT $ first (T.pack . show) <$>
|
|
runAct (fetchRemoteResource instanceID h lu)
|
|
case result of
|
|
Left (Entity _ actor) ->
|
|
return (actor, u)
|
|
Right (_objectID, luManager, (Entity _ actor)) ->
|
|
return (actor, ObjURI h luManager)
|
|
)
|
|
resource
|
|
|
|
-- If target is remote, get it via HTTP/DB to determine its followers
|
|
-- collection
|
|
recipientDB <-
|
|
bitraverse
|
|
(runActE . hashGrantRecip)
|
|
(\ u@(ObjURI h lu) -> do
|
|
instanceID <-
|
|
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
|
result <-
|
|
ExceptT $ first (T.pack . displayException) <$>
|
|
fetchRemoteActor instanceID h lu
|
|
case result of
|
|
Left Nothing -> throwE "Recipient @id mismatch"
|
|
Left (Just err) -> throwE $ T.pack $ displayException err
|
|
Right Nothing -> throwE "Recipient isn't an actor"
|
|
Right (Just actor) -> return (entityVal actor, u)
|
|
)
|
|
recipient
|
|
|
|
senderHash <- encodeKeyHashid personID
|
|
|
|
let audResource =
|
|
case resourceDB of
|
|
Left (GrantResourceRepo r) ->
|
|
AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
|
|
Left (GrantResourceDeck d) ->
|
|
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
|
|
Left (GrantResourceLoom l) ->
|
|
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
|
|
Left (GrantResourceProject l) ->
|
|
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
|
|
Right (remoteActor, ObjURI h lu) ->
|
|
AudRemote h
|
|
[lu]
|
|
(maybeToList $ remoteActorFollowers remoteActor)
|
|
audRecipient =
|
|
case recipientDB of
|
|
Left (GrantRecipPerson p) ->
|
|
AudLocal [] [LocalStagePersonFollowers p]
|
|
Right (remoteActor, ObjURI h lu) ->
|
|
AudRemote h
|
|
[lu]
|
|
(maybeToList $ remoteActorFollowers remoteActor)
|
|
audAuthor =
|
|
AudLocal [] [LocalStagePersonFollowers senderHash]
|
|
|
|
audience = [audResource, audRecipient, audAuthor]
|
|
|
|
return (Nothing, audience, activity)
|