S2S: Deck: Port the Offer{Ticket} handler from the old code
This commit is contained in:
Pere Lev
parent
7edb7a9760
commit
1694d77705
9 changed files with 247 additions and 209 deletions
|
|
@ -130,6 +130,8 @@ import Vervis.Ticket
|
|||
import Vervis.Web.Delivery
|
||||
import Vervis.Web.Repo
|
||||
|
||||
import qualified Vervis.Actor2 as VA2
|
||||
|
||||
handleViaActor
|
||||
:: PersonId
|
||||
-> Maybe
|
||||
|
|
@ -626,7 +628,7 @@ applyC
|
|||
applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action apply = do
|
||||
|
||||
-- Check input
|
||||
maybeLocalTarget <- checkApplyLocalLoom apply
|
||||
maybeLocalTarget <- VA2.runActE $ checkApplyLocalLoom apply
|
||||
capID <- fromMaybeE maybeCap "No capability provided"
|
||||
|
||||
-- Verify that the bundle's loom is addressed
|
||||
|
|
@ -1530,7 +1532,7 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
|
||||
-- Check input
|
||||
verifyNothingE maybeCap "Capability not needed"
|
||||
(followee, hide) <- parseFollow follow
|
||||
(followee, hide) <- VA2.runActE $ parseFollow follow
|
||||
case followee of
|
||||
Left (FolloweeActor (LocalActorPerson personID))
|
||||
| personID == senderPersonID ->
|
||||
|
|
@ -1672,7 +1674,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localReci
|
|||
verifyNothingE maybeCap "Capability not needed"
|
||||
(title, desc, source, tam) <- do
|
||||
hostLocal <- asksSite siteInstanceHost
|
||||
WorkItemOffer {..} <- checkOfferTicket hostLocal ticket uTarget
|
||||
WorkItemOffer {..} <- VA2.runActE $ checkOfferTicket hostLocal ticket uTarget
|
||||
unless (wioAuthor == Left senderPersonID) $
|
||||
throwE "Offering a Ticket attributed to someone else"
|
||||
return (wioTitle, wioDesc, wioSource, wioRest)
|
||||
|
|
@ -2345,7 +2347,7 @@ resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips r
|
|||
(\ r -> do
|
||||
wiByHash <-
|
||||
fromMaybeE (parseWorkItem r) "Not a work item route"
|
||||
unhashWorkItemE wiByHash "Work item invalid keyhashid"
|
||||
VA2.runActE $ unhashWorkItemE wiByHash "Work item invalid keyhashid"
|
||||
)
|
||||
pure
|
||||
routeOrRemote
|
||||
|
|
@ -2593,7 +2595,7 @@ undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remo
|
|||
return Nothing
|
||||
Just (Right (updateDB, ticketID)) -> do
|
||||
wiByKey <- lift $ getWorkItem ticketID
|
||||
wiByHash <- hashWorkItem wiByKey
|
||||
wiByHash <- lift $ lift $ VA2.runAct $ hashWorkItem wiByKey
|
||||
let resource = workItemResource wiByKey
|
||||
actorByKey = workItemActor wiByKey
|
||||
actorByHash = workItemActor wiByHash
|
||||
|
|
|
|||
|
|
@ -63,11 +63,12 @@ import Vervis.Cloth
|
|||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Data.Discussion
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Util
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model hiding (deckCreate)
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
|
||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers)
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Persist.Discussion
|
||||
|
|
@ -314,6 +315,176 @@ deckCreate now deckID verse (AP.Create obj _muTarget) =
|
|||
|
||||
_ -> throwE "Unsupported Create object for Deck"
|
||||
|
||||
-- Meaning: An actor A is offering a ticket or a ticket dependency
|
||||
-- Behavior:
|
||||
-- * Verify I'm the target
|
||||
-- * Insert the Offer to my inbox
|
||||
-- * Create the new ticket in my DB
|
||||
-- * Forward the Offer to my followers
|
||||
-- * Publish an Accept to:
|
||||
-- - My followers
|
||||
-- - Offer sender+followers
|
||||
deckOffer
|
||||
:: UTCTime
|
||||
-> DeckId
|
||||
-> Verse
|
||||
-> AP.Offer URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
|
||||
|
||||
-- Check input
|
||||
(title, desc, source) <- do
|
||||
ticket <-
|
||||
case object of
|
||||
AP.OfferTicket t -> pure t
|
||||
_ -> throwE "Unsupported Offer.object type"
|
||||
ObjURI hAuthor _ <- lift $ getActorURI authorIdMsig
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
|
||||
unless (bimap LocalActorPerson id wioAuthor == author) $
|
||||
throwE "Offering a Ticket attributed to someone else"
|
||||
case wioRest of
|
||||
TAM_Task deckID' ->
|
||||
if deckID' == deckID
|
||||
then return ()
|
||||
else throwE
|
||||
"Offer target is some other local deck, so I have \
|
||||
\no use for this Offer. Was I supposed to receive \
|
||||
\it?"
|
||||
TAM_Merge _ _ ->
|
||||
throwE
|
||||
"Offer target is some local loom, so I have no use for \
|
||||
\this Offer. Was I supposed to receive it?"
|
||||
TAM_Remote _ _ ->
|
||||
throwE
|
||||
"Offer target is some remote tracker, so I have no use \
|
||||
\for this Offer. Was I supposed to receive it?"
|
||||
return (wioTitle, wioDesc, wioSource)
|
||||
|
||||
-- Verify the capability URI, if provided, is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
maybeCapability <-
|
||||
for (AP.activityCapability $ actbActivity body) $ \ uCap ->
|
||||
nameExceptT "Offer.capability" $
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI' uCap
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(deckRecip, actorRecip) <- lift $ do
|
||||
d <- getJust deckID
|
||||
(d,) <$> getJust (deckActor d)
|
||||
|
||||
-- Insert the Offer to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
for mractid $ \ offerDB -> do
|
||||
|
||||
-- If a capability is provided, check it
|
||||
for_ maybeCapability $ \ cap -> do
|
||||
lcap <-
|
||||
case cap of
|
||||
Left c -> pure c
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
|
||||
verifyCapability'
|
||||
lcap
|
||||
authorIdMsig
|
||||
(GrantResourceDeck deckID)
|
||||
AP.RoleReport
|
||||
|
||||
-- Prepare forwarding the Offer to my followers
|
||||
let recipByID = grantResourceLocalActor $ GrantResourceDeck deckID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
-- Insert the new ticket to our DB
|
||||
acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
offerDB' <-
|
||||
bitraverse
|
||||
(traverseOf _1 $ \case
|
||||
LocalActorPerson personID -> pure personID
|
||||
_ -> throwE "Local non-Person ticket authors not allowed"
|
||||
)
|
||||
pure
|
||||
offerDB
|
||||
taskID <- lift $ insertTask now title desc source deckID offerDB' acceptID
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
accept@(actionAccept, _, _, _) <- lift $ prepareAccept taskID
|
||||
let recipByKey = LocalActorDeck deckID
|
||||
_luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept
|
||||
|
||||
return (deckActor deckRecip, sieve, acceptID, accept)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (deckActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
|
||||
forwardActivity
|
||||
authorIdMsig body (LocalActorDeck deckID) deckActorID sieve
|
||||
lift $ sendActivity
|
||||
(LocalActorDeck deckID) deckActorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
done "Opened a ticket and forwarded the Offer"
|
||||
|
||||
where
|
||||
|
||||
insertTask now title desc source deckID offerDB acceptID = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = title
|
||||
, ticketSource = source
|
||||
, ticketDescription = desc
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
, ticketAccept = acceptID
|
||||
}
|
||||
case offerDB of
|
||||
Left (personID, _, offerID) ->
|
||||
insert_ TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = tid
|
||||
, ticketAuthorLocalAuthor = personID
|
||||
, ticketAuthorLocalOpen = offerID
|
||||
}
|
||||
Right (author, _, offerID) ->
|
||||
insert_ TicketAuthorRemote
|
||||
{ ticketAuthorRemoteTicket = tid
|
||||
, ticketAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketAuthorRemoteOpen = offerID
|
||||
}
|
||||
insert $ TicketDeck tid deckID
|
||||
|
||||
prepareAccept taskID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
audSender <- makeAudSenderWithFollowers authorIdMsig
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
let audDeck = AudLocal [] [LocalStageDeckFollowers deckHash]
|
||||
uOffer <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audSender, audDeck]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uOffer]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uOffer
|
||||
, AP.acceptResult =
|
||||
Just $ encodeRouteLocal $ TicketR deckHash taskHash
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Following
|
||||
------------------------------------------------------------------------------
|
||||
|
|
@ -746,6 +917,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
|
|||
AP.GrantActivity grant -> deckGrant now deckID verse grant
|
||||
AP.InviteActivity invite -> deckInvite now deckID verse invite
|
||||
AP.JoinActivity join -> deckJoin now deckID verse join
|
||||
AP.OfferActivity offer -> deckOffer now deckID verse offer
|
||||
AP.RejectActivity reject -> deckReject now deckID verse reject
|
||||
AP.RemoveActivity remove -> deckRemove now deckID verse remove
|
||||
AP.UndoActivity undo -> deckUndo now deckID verse undo
|
||||
|
|
|
|||
|
|
@ -315,7 +315,7 @@ offerIssue
|
|||
offerIssue senderHash title desc uTracker = do
|
||||
|
||||
tracker <- do
|
||||
tracker <- checkTracker uTracker
|
||||
tracker <- runActE $ checkTracker uTracker
|
||||
case tracker of
|
||||
TrackerDeck deckID -> Left <$> encodeKeyHashid deckID
|
||||
TrackerLoom _ -> throwE "Local patch tracker doesn't take issues"
|
||||
|
|
@ -619,7 +619,7 @@ offerPatches
|
|||
offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do
|
||||
|
||||
tracker <- do
|
||||
tracker <- checkTracker uTracker
|
||||
tracker <- runActE $ checkTracker uTracker
|
||||
case tracker of
|
||||
TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches"
|
||||
TrackerLoom loomID -> Left <$> encodeKeyHashid loomID
|
||||
|
|
@ -709,7 +709,7 @@ offerMerge
|
|||
offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do
|
||||
|
||||
tracker <- do
|
||||
tracker <- checkTracker uTracker
|
||||
tracker <- runActE $ checkTracker uTracker
|
||||
case tracker of
|
||||
TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches"
|
||||
TrackerLoom loomID -> Left <$> encodeKeyHashid loomID
|
||||
|
|
@ -790,7 +790,7 @@ applyPatches
|
|||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode)
|
||||
applyPatches senderHash uObject = do
|
||||
|
||||
bundle <- parseBundleRoute "Apply object" uObject
|
||||
bundle <- runActE $ parseBundleRoute "Apply object" uObject
|
||||
mrInfo <-
|
||||
bifor bundle
|
||||
(\ (loomID, clothID, _) -> do
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ module Vervis.Data.Actor
|
|||
, parseLocalURI
|
||||
, parseFedURIOld
|
||||
, parseLocalActorE
|
||||
, parseLocalActorE'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -189,3 +190,8 @@ parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
|
|||
parseLocalActorE route = do
|
||||
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
|
||||
unhashLocalActorE actorByHash "Invalid actor keyhashid"
|
||||
|
||||
parseLocalActorE' :: Route App -> VA.ActE (LocalActorBy Key)
|
||||
parseLocalActorE' route = do
|
||||
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
|
||||
VA.unhashLocalActorE actorByHash "Invalid actor keyhashid"
|
||||
|
|
|
|||
|
|
@ -29,7 +29,10 @@ import Data.Maybe
|
|||
import Data.Text (Text)
|
||||
import Database.Persist.Types
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Network.FedURI
|
||||
import Web.Actor
|
||||
import Web.Actor.Persist
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
|
@ -39,12 +42,13 @@ import qualified Web.ActivityPub as AP
|
|||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Recipient
|
||||
import Vervis.Recipient (parseLocalActor)
|
||||
|
||||
data FolloweeBy f
|
||||
= FolloweeActor (LocalActorBy f)
|
||||
|
|
@ -59,10 +63,9 @@ unhashFolloweeE (FolloweeWorkItem wi) e = FolloweeWorkItem <$> unhashWorkItemE w
|
|||
|
||||
parseFollow
|
||||
:: AP.Follow URIMode
|
||||
-> ExceptT Text Handler
|
||||
(Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
|
||||
-> ActE (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
|
||||
parseFollow (AP.Follow uObject mluContext hide) = do
|
||||
routeOrRemote <- parseFedURIOld uObject
|
||||
routeOrRemote <- parseFedURI uObject
|
||||
(,hide) <$>
|
||||
bitraverse
|
||||
(parseLocal mluContext)
|
||||
|
|
@ -76,8 +79,8 @@ parseFollow (AP.Follow uObject mluContext hide) = do
|
|||
byHash <- fromMaybeE (parseFollowee r) "Not a followee route"
|
||||
byKey <- unhashFolloweeE byHash "Followee invalid keyhashid"
|
||||
for_ mlu $ \ lu -> nameExceptT "Follow context" $ do
|
||||
actorR <-parseLocalURI lu
|
||||
actorByKey <- parseLocalActorE actorR
|
||||
actorR <- parseLocalURI lu
|
||||
actorByKey <- parseLocalActorE' actorR
|
||||
unless (actorByKey == followeeActor byKey) $
|
||||
throwE "Isn't object's actor"
|
||||
return byKey
|
||||
|
|
|
|||
|
|
@ -62,8 +62,11 @@ import Yesod.Core
|
|||
|
||||
import qualified Control.Monad.Fail as F
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.Actor
|
||||
import Web.Actor.Persist
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Actor
|
||||
|
|
@ -72,9 +75,11 @@ import Yesod.Hashids
|
|||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
import qualified Web.Actor.Persist as WAP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Foundation
|
||||
import Vervis.FedURI
|
||||
|
|
@ -112,25 +117,25 @@ data WorkItemOffer = WorkItemOffer
|
|||
, wioRest :: TrackerAndMerge
|
||||
}
|
||||
|
||||
checkAuthor :: FedURI -> ExceptT Text Handler (Either PersonId FedURI)
|
||||
checkAuthor :: FedURI -> ActE (Either PersonId FedURI)
|
||||
checkAuthor u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocalOld h
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route"
|
||||
case route of
|
||||
PersonR personHash -> Left <$> decodeKeyHashidE personHash "Local author invalid person hash"
|
||||
PersonR personHash -> Left <$> WAP.decodeKeyHashidE personHash "Local author invalid person hash"
|
||||
_ -> throwE "Local author not a person route"
|
||||
else pure $ Right u
|
||||
|
||||
checkPatch :: Host -> AP.Patch URIMode -> ExceptT Text Handler (Either PersonId FedURI, PatchMediaType, Text)
|
||||
checkPatch :: Host -> AP.Patch URIMode -> ActE (Either PersonId FedURI, PatchMediaType, Text)
|
||||
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
|
||||
verifyNothingE mlocal "Patch has 'id'"
|
||||
author <- checkAuthor $ ObjURI h attrib
|
||||
verifyNothingE mpub "Patch has 'published'"
|
||||
return (author, typ, content)
|
||||
|
||||
checkBundle :: Host -> AP.Bundle URIMode -> ExceptT Text Handler (Either PersonId FedURI, Material)
|
||||
checkBundle :: Host -> AP.Bundle URIMode -> ActE (Either PersonId FedURI, Material)
|
||||
checkBundle _ (AP.BundleHosted _ _) = throwE "Patches specified as URIs"
|
||||
checkBundle h (AP.BundleOffer mlocal patches) = do
|
||||
verifyNothingE mlocal "Bundle has 'id'"
|
||||
|
|
@ -142,30 +147,29 @@ checkBundle h (AP.BundleOffer mlocal patches) = do
|
|||
unless (all (== typ) typs) $ throwE "Different patch types"
|
||||
return (author, Material typ (content :| contents))
|
||||
|
||||
checkTipURI :: FedURI -> ExceptT Text Handler (Either RepoId FedURI)
|
||||
checkTipURI :: FedURI -> ActE (Either RepoId FedURI)
|
||||
checkTipURI u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocalOld h
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route"
|
||||
case route of
|
||||
RepoR repoHash -> decodeKeyHashidE repoHash "URI is local repo route but repo hash is invalid"
|
||||
RepoR repoHash -> WAP.decodeKeyHashidE repoHash "URI is local repo route but repo hash is invalid"
|
||||
_ -> throwE "URI is local route but not a repo route"
|
||||
else pure $ Right u
|
||||
|
||||
checkBranch :: Host -> AP.Branch URIMode -> ExceptT Text Handler (Either RepoId FedURI, Text)
|
||||
checkBranch :: Host -> AP.Branch URIMode -> ActE (Either RepoId FedURI, Text)
|
||||
checkBranch h (AP.Branch name _ luRepo) =
|
||||
(,name) <$> nameExceptT "Branch repo" (checkTipURI $ ObjURI h luRepo)
|
||||
|
||||
checkTip :: Either FedURI (Host, AP.Branch URIMode) -> ExceptT Text Handler Tip
|
||||
checkTip :: Either FedURI (Host, AP.Branch URIMode) -> ActE Tip
|
||||
checkTip (Left u) = either TipLocalRepo TipRemote <$> checkTipURI u
|
||||
checkTip (Right (h, b)) = uncurry ($) . first (either TipLocalBranch TipRemoteBranch) <$> checkBranch h b
|
||||
|
||||
checkMR
|
||||
:: Host
|
||||
-> AP.MergeRequest URIMode
|
||||
-> ExceptT Text Handler
|
||||
(Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip)
|
||||
-> ActE (Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip)
|
||||
checkMR h (AP.MergeRequest muOrigin target mbundle) =
|
||||
(,,)
|
||||
<$> traverse checkTip muOrigin
|
||||
|
|
@ -176,22 +180,22 @@ checkMR h (AP.MergeRequest muOrigin target mbundle) =
|
|||
)
|
||||
<*> checkTip (bimap (ObjURI h) (h,) target)
|
||||
|
||||
checkTracker :: FedURI -> ExceptT Text Handler Tracker
|
||||
checkTracker :: FedURI -> ActE Tracker
|
||||
checkTracker u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocalOld h
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route"
|
||||
case route of
|
||||
DeckR deckHash -> TrackerDeck <$> decodeKeyHashidE deckHash "Local tracker invalid deck hash"
|
||||
LoomR loomHash -> TrackerLoom <$> decodeKeyHashidE loomHash "Local tracker invalid loom hash"
|
||||
DeckR deckHash -> TrackerDeck <$> WAP.decodeKeyHashidE deckHash "Local tracker invalid deck hash"
|
||||
LoomR loomHash -> TrackerLoom <$> WAP.decodeKeyHashidE loomHash "Local tracker invalid loom hash"
|
||||
_ -> throwE "Local tracker not a deck/loom route"
|
||||
else pure $ TrackerRemote u
|
||||
|
||||
checkTicket
|
||||
:: Host
|
||||
-> AP.Ticket URIMode
|
||||
-> ExceptT Text Handler
|
||||
-> ActE
|
||||
( Either PersonId FedURI
|
||||
, Text, HTML, PandocMarkdown
|
||||
, Maybe Tracker
|
||||
|
|
@ -214,14 +218,14 @@ checkTicket h (AP.Ticket mlocal attrib mpublished mupdated muContext summary con
|
|||
return $ Merge maybeOriginTip maybeBundle targetTip
|
||||
return (author, decodeEntities summary, content, source, maybeTracker, maybeMerge)
|
||||
|
||||
checkTrackerAndMerge :: Tracker -> Maybe Merge -> ExceptT Text Handler TrackerAndMerge
|
||||
checkTrackerAndMerge :: Tracker -> Maybe Merge -> ActE TrackerAndMerge
|
||||
checkTrackerAndMerge (TrackerDeck deckID) Nothing = pure $ TAM_Task deckID
|
||||
checkTrackerAndMerge (TrackerDeck _) (Just _) = throwE "Deck & MR"
|
||||
checkTrackerAndMerge (TrackerLoom _) Nothing = throwE "Loom & no MR"
|
||||
checkTrackerAndMerge (TrackerLoom loomID) (Just merge) = pure $ TAM_Merge loomID merge
|
||||
checkTrackerAndMerge (TrackerRemote uTracker) maybeMerge = pure $ TAM_Remote uTracker maybeMerge
|
||||
|
||||
checkOfferTicket :: Host -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler WorkItemOffer
|
||||
checkOfferTicket :: Host -> AP.Ticket URIMode -> FedURI -> ActE WorkItemOffer
|
||||
checkOfferTicket host ticket uTarget = do
|
||||
target <- checkTracker uTarget
|
||||
(author, title, desc, source, maybeTracker, maybeBundle) <- checkTicket host ticket
|
||||
|
|
@ -231,7 +235,7 @@ checkOfferTicket host ticket uTarget = do
|
|||
return $ WorkItemOffer author title desc source tam
|
||||
|
||||
parseBundleRoute name u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocalOld h
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <-
|
||||
|
|
@ -240,24 +244,22 @@ parseBundleRoute name u@(ObjURI h lu) = do
|
|||
case route of
|
||||
BundleR loom ticket bundle ->
|
||||
(,,)
|
||||
<$> decodeKeyHashidE loom (name <> ": Invalid lkhid")
|
||||
<*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
|
||||
<*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid")
|
||||
<$> WAP.decodeKeyHashidE loom (name <> ": Invalid lkhid")
|
||||
<*> WAP.decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
|
||||
<*> WAP.decodeKeyHashidE bundle (name <> ": Invalid bnkhid")
|
||||
_ -> throwE $ name <> ": not a bundle route"
|
||||
else return $ Right u
|
||||
|
||||
checkApply
|
||||
:: AP.Apply URIMode
|
||||
-> ExceptT Text Handler
|
||||
(Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
|
||||
-> ActE (Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
|
||||
checkApply (AP.Apply uObject target) =
|
||||
(,) <$> parseBundleRoute "Apply object" uObject
|
||||
<*> nameExceptT "Apply target" (checkTip target)
|
||||
|
||||
checkApplyLocalLoom
|
||||
:: AP.Apply URIMode
|
||||
-> ExceptT Text Handler
|
||||
(Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId))
|
||||
-> ActE (Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId))
|
||||
checkApplyLocalLoom apply = do
|
||||
(bundle, targetTip) <- checkApply apply
|
||||
let maybeLocal =
|
||||
|
|
@ -286,14 +288,14 @@ hashWorkItemPure ctx = f
|
|||
WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c)
|
||||
|
||||
getHashWorkItem
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
:: (MonadActor m, StageHashids (ActorEnv m))
|
||||
=> m (WorkItemBy Key -> WorkItemBy KeyHashid)
|
||||
getHashWorkItem = do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
ctx <- asksEnv stageHashidsContext
|
||||
return $ hashWorkItemPure ctx
|
||||
|
||||
hashWorkItem
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
:: (MonadActor m, StageHashids (ActorEnv m))
|
||||
=> WorkItemBy Key -> m (WorkItemBy KeyHashid)
|
||||
hashWorkItem actor = do
|
||||
hash <- getHashWorkItem
|
||||
|
|
@ -313,24 +315,24 @@ unhashWorkItemPure ctx = f
|
|||
<*> decodeKeyHashidPure ctx c
|
||||
|
||||
unhashWorkItem
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
:: (MonadActor m, StageHashids (ActorEnv m))
|
||||
=> WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key))
|
||||
unhashWorkItem actor = do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
ctx <- asksEnv stageHashidsContext
|
||||
return $ unhashWorkItemPure ctx actor
|
||||
|
||||
unhashWorkItemF
|
||||
:: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m))
|
||||
:: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m))
|
||||
=> WorkItemBy KeyHashid -> String -> m (WorkItemBy Key)
|
||||
unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor
|
||||
|
||||
unhashWorkItemM
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
:: (MonadActor m, StageHashids (ActorEnv m))
|
||||
=> WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key)
|
||||
unhashWorkItemM = MaybeT . unhashWorkItem
|
||||
|
||||
unhashWorkItemE
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
:: (MonadActor m, StageHashids (ActorEnv m))
|
||||
=> WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key)
|
||||
unhashWorkItemE actor e =
|
||||
ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor
|
||||
|
|
@ -344,6 +346,10 @@ unhashWorkItem404
|
|||
=> WorkItemBy KeyHashid
|
||||
-> m (WorkItemBy Key)
|
||||
unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor
|
||||
where
|
||||
unhashWorkItem byHash = do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
return $ unhashWorkItemPure ctx byHash
|
||||
|
||||
workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck
|
||||
workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom
|
||||
|
|
|
|||
|
|
@ -18,8 +18,7 @@
|
|||
|
||||
module Vervis.Federation.Ticket
|
||||
( --personOfferTicketF
|
||||
deckOfferTicketF
|
||||
, loomOfferTicketF
|
||||
loomOfferTicketF
|
||||
|
||||
--, repoAddBundleF
|
||||
|
||||
|
|
@ -323,159 +322,6 @@ insertLocalTicket now author txl summary content source ractidOffer obiidAccept
|
|||
return (tid, ltid)
|
||||
-}
|
||||
|
||||
deckOfferTicketF
|
||||
:: UTCTime
|
||||
-> KeyHashid Deck
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler Text
|
||||
deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
||||
error "deckOfferTicketF disabled for refactoring"
|
||||
{-
|
||||
-- Check input
|
||||
recipDeckID <- decodeKeyHashid404 recipDeckHash
|
||||
(title, desc, source) <- do
|
||||
let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author
|
||||
WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
|
||||
unless (wioAuthor == Right (remoteAuthorURI author)) $
|
||||
throwE "Offering a Ticket attributed to someone else"
|
||||
case wioRest of
|
||||
TAM_Task deckID ->
|
||||
if deckID == recipDeckID
|
||||
then return ()
|
||||
else throwE
|
||||
"Offer target is some other local deck, so I have \
|
||||
\no use for this Offer. Was I supposed to receive \
|
||||
\it?"
|
||||
TAM_Merge _ _ ->
|
||||
throwE
|
||||
"Offer target is some local loom, so I have no use for \
|
||||
\this Offer. Was I supposed to receive it?"
|
||||
TAM_Remote _ _ ->
|
||||
throwE
|
||||
"Offer target is some remote tracker, so I have no use \
|
||||
\for this Offer. Was I supposed to receive it?"
|
||||
return (wioTitle, wioDesc, wioSource)
|
||||
|
||||
-- Find recipient deck in DB, returning 404 if doesn't exist because we're
|
||||
-- in the deck's inbox post handler
|
||||
maybeHttp <- runDBExcept $ do
|
||||
(recipDeckActorID, recipDeckActor) <- lift $ do
|
||||
deck <- get404 recipDeckID
|
||||
let actorID = deckActor deck
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Insert the Offer to deck's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luOffer False
|
||||
for mractid $ \ offerID -> do
|
||||
|
||||
-- Forward the Offer activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalStageDeckFollowers recipDeckHash]
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipDeckActorID
|
||||
(LocalActorDeck recipDeckHash) sieve offerID
|
||||
|
||||
-- Insert the new ticket to our DB
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
|
||||
taskID <- lift $ insertTask now title desc source recipDeckID offerID acceptID
|
||||
|
||||
-- Prepare an Accept activity and insert to deck's outbox
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift $ prepareAccept taskID
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorDeck recipDeckHash) recipDeckActorID
|
||||
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Offer
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients
|
||||
return (maybeHttpFwdOffer, deliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
||||
-- delivery of the Accept activity
|
||||
case maybeHttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just (maybeHttpFwdOffer, deliverHttpAccept) -> do
|
||||
forkWorker "deckOfferTicketF Accept HTTP delivery" deliverHttpAccept
|
||||
case maybeHttpFwdOffer of
|
||||
Nothing -> return "Opened a ticket, no inbox-forwarding to do"
|
||||
Just forwardHttpOffer -> do
|
||||
forkWorker "deckOfferTicketF inbox-forwarding" forwardHttpOffer
|
||||
return "Opened a ticket and ran inbox-forwarding of the Offer"
|
||||
|
||||
where
|
||||
|
||||
insertTask now title desc source deckID offerID acceptID = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = title
|
||||
, ticketSource = source
|
||||
, ticketDescription = desc
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
, ticketAccept = acceptID
|
||||
}
|
||||
insert_ TicketAuthorRemote
|
||||
{ ticketAuthorRemoteTicket = tid
|
||||
, ticketAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketAuthorRemoteOpen = offerID
|
||||
}
|
||||
insert $ TicketDeck tid deckID
|
||||
|
||||
prepareAccept taskID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
|
||||
audSender =
|
||||
AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
audTracker = AudLocal [] [LocalStageDeckFollowers recipDeckHash]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audSender, audTracker]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luOffer
|
||||
, AP.acceptResult =
|
||||
Just $ encodeRouteLocal $
|
||||
TicketR recipDeckHash taskHash
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
||||
activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
|
||||
instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
|
||||
remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luAct
|
||||
|
|
|
|||
|
|
@ -96,6 +96,7 @@ import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
|
|||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..))
|
||||
import Vervis.Actor2
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
|
|
@ -453,7 +454,7 @@ getFollowingCollection here actor hash = do
|
|||
<*> getRemotes followerActorID
|
||||
|
||||
hashActor <- getHashLocalActor
|
||||
hashItem <- getHashWorkItem
|
||||
hashItem <- runAct getHashWorkItem
|
||||
let locals =
|
||||
map (renderLocalActor . hashActor) localActors ++
|
||||
map (workItemRoute . hashItem) workItems
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019, 2020, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -76,6 +77,7 @@ import Vervis.Settings
|
|||
import Vervis.Ticket
|
||||
import Vervis.Widget.Discussion
|
||||
|
||||
import qualified Vervis.Actor2 as VA2
|
||||
import qualified Vervis.Client as C
|
||||
|
||||
getRepliesCollection
|
||||
|
|
@ -240,7 +242,7 @@ serveMessage authorHash localMessageHash = do
|
|||
case topic of
|
||||
Left ticketID -> do
|
||||
wiByKey <- getWorkItem ticketID
|
||||
wiByHash <- hashWorkItem wiByKey
|
||||
wiByHash <- lift $ VA2.runAct $ hashWorkItem wiByKey
|
||||
return $ encodeRouteHome $ workItemRoute wiByHash
|
||||
Right rd -> do
|
||||
ro <- getJust $ remoteDiscussionIdent rd
|
||||
|
|
|
|||
Loading…
Reference in a new issue