diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 4627c8a..a6542fb 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -14,19 +14,20 @@ -} module Vervis.Federation.Ticket - ( personOfferTicketF - , deckOfferTicketF - , repoOfferTicketF + ( --personOfferTicketF + deckOfferTicketF + --, repoOfferTicketF - , repoAddBundleF + --, repoAddBundleF - , repoApplyF + --, repoApplyF + --, loomApplyF - , deckOfferDepF - , repoOfferDepF + --, deckOfferDepF + --, repoOfferDepF - , deckResolveF - , repoResolveF + --, deckResolveF + --, repoResolveF ) where @@ -90,7 +91,9 @@ import Development.PatchMediaType import Vervis.ActivityPub import Vervis.Cloth +import Vervis.Data.Ticket import Vervis.Darcs +import Vervis.Delivery import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Federation.Util @@ -244,7 +247,7 @@ personOfferTicketF -> KeyHashid Person -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.Ticket URIMode -> FedURI @@ -315,120 +318,188 @@ deckOfferTicketF -> KeyHashid Deck -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler Text -deckOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do - error "projectOfferTicketF temporarily disabled" +deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do + -- 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) -{- - (target, summary, content, source) <- checkOfferTicket author ticket uTarget - mmhttp <- for (targetRelevance target) $ \ () -> lift $ runDB $ do - Entity jid j <- do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniqueProject prjRecip sid - a <- getJust $ projectActor j - mractid <- insertToInbox now author body (actorInbox a) luOffer False - for mractid $ \ ractid -> do - mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do + -- Find recipient deck in DB, returning 404 if doesn't exist because we're + -- in the deck's inbox post handler + maybeHttp <- lift $ runDB $ do + (recipDeckActorID, recipDeckActor) <- do + deck <- get404 recipDeckID + let actorID = deckActor deck + (actorID,) <$> getJust actorID + + -- Insert the Offer to deck's inbox + mractid <- 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 <- for mfwd $ \ (localRecips, sig) -> do let sieve = makeRecipientSet [] - [ LocalPersonCollectionProjectTeam shrRecip prjRecip - , LocalPersonCollectionProjectFollowers shrRecip prjRecip - ] + [LocalStageDeckFollowers recipDeckHash] remoteRecips <- - insertRemoteActivityToLocalInboxes - False ractid $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips - (obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do - obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now - (_, ltid) <- insertLocalTicket now author (flip TicketProjectLocal jid) summary content source ractid obiidAccept - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - insertAccept shrRecip prjRecip author luOffer ltid obiidAccept - knownRemoteRecipsAccept <- - deliverLocal' - False - (LocalActorProject shrRecip prjRecip) - (actorInbox a) - obiidAccept - localRecipsAccept - (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept - return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept) - case mmhttp of - Nothing -> return "Offer target isn't me, not using" - Just mhttp -> - case mhttp of - Nothing -> return "Activity already in my inbox, doing nothing" - Just (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do - for_ mremotesHttpFwd $ \ (sig, remotes) -> - forkWorker "projectOfferTicketF inbox-forwarding" $ - deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes - forkWorker "projectOfferTicketF Accept HTTP delivery" $ - deliverRemoteHttp' fwdHosts obiid doc remotes - return $ - case mremotesHttpFwd of - Nothing -> "Accepted new ticket, no inbox-forwarding to do" - Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer" + insertRemoteActivityToLocalInboxes False offerID $ + localRecipSieve' sieve False False localRecips + remoteRecipsHttp <- + deliverRemoteDB_D + (actbBL body) offerID recipDeckID sig remoteRecips + return $ + deliverRemoteHTTP_D + now recipDeckHash (actbBL body) sig remoteRecipsHttp + + -- Insert the new ticket to our DB + acceptID <- insertEmptyOutboxItem (actorOutbox recipDeckActor) now + taskID <- insertTask now title desc source recipDeckID offerID acceptID + + -- Prepare an Accept activity and insert to deck's outbox + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAcceptToOutbox taskID acceptID + + -- Deliver the Accept to local recipients, and schedule delivery + -- for unavailable remote recipients + knownRemoteRecipsAccept <- + deliverLocal' + False (LocalActorDeck recipDeckHash) recipDeckActorID + acceptID localRecipsAccept + remoteRecipsHttpAccept <- + deliverRemoteDB'' + fwdHostsAccept acceptID remoteRecipsAccept + knownRemoteRecipsAccept + + -- Return instructions for HTTP inbox-forwarding of the Offer + -- activity, and for HTTP delivery of the Accept activity to + -- remote recipients + return + ( maybeHttpFwdOffer + , deliverRemoteHttp' + fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept + ) + + -- 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 - targetRelevance (Left (WITProject shr prj)) - | shr == shrRecip && prj == prjRecip = Just () - targetRelevance _ = Nothing - insertAccept shr prj author luOffer ltid obiidAccept = do + + 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 + , ticketStatus = TSNew + , ticketDiscuss = did + , ticketFollowers = fsid + , ticketAccept = acceptID + } + insert_ TicketAuthorRemote + { ticketAuthorRemoteTicket = tid + , ticketAuthorRemoteAuthor = remoteAuthorId author + , ticketAuthorRemoteOpen = offerID + } + insert $ TicketDeck tid deckID + + insertAcceptToOutbox + :: TicketDeckId + -> OutboxItemId + -> ReaderT SqlBackend Handler + ( AP.Doc AP.Activity URIMode + , RecipientRoutes + , [(Host, NonEmpty LocalURI)] + , [Host] + ) + insertAcceptToOutbox taskID acceptID = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - obikhidAccept <- encodeKeyHashid obiidAccept - ltkhid <- encodeKeyHashid ltid + taskHash <- encodeKeyHashid taskID + acceptHash <- encodeKeyHashid acceptID ra <- getJust $ remoteAuthorId author let ObjURI hAuthor luAuthor = remoteAuthorURI author - audAuthor = - AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) - audProject = - AudLocal [] - [ LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj - ] + audSender = + AudRemote hAuthor + [luAuthor] + (maybeToList $ remoteActorFollowers ra) + audTracker = AudLocal [] [LocalStageDeckFollowers recipDeckHash] (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audAuthor, audProject] + collectAudience [audSender, audTracker] recips = map encodeRouteHome audLocal ++ audRemote - doc = Doc hLocal Activity - { activityId = + doc = AP.Doc hLocal AP.Activity + { AP.activityId = Just $ encodeRouteLocal $ - ProjectOutboxItemR shr prj obikhidAccept - , activityActor = encodeRouteLocal $ ProjectR shr prj - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept + DeckOutboxItemR recipDeckHash acceptHash + , AP.activityActor = + encodeRouteLocal $ DeckR recipDeckHash + , AP.activityCapability = Nothing + , AP.activitySummary = Nothing + , AP.activityAudience = AP.Audience recips [] [] [] [] [] + , AP.activityFulfills = [] + , AP.activitySpecific = AP.AcceptActivity AP.Accept { acceptObject = ObjURI hAuthor luOffer , acceptResult = - Just $ encodeRouteLocal $ ProjectTicketR shr prj ltkhid + Just $ encodeRouteLocal $ + TicketR recipDeckHash taskHash } } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + + update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) --} repoOfferTicketF :: UTCTime -> KeyHashid Repo -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.Ticket URIMode -> FedURI @@ -577,7 +648,7 @@ repoAddBundleF -> KeyHashid Repo -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> NonEmpty (AP.Patch URIMode) -> FedURI @@ -739,7 +810,7 @@ repoApplyF -> KeyHashid Repo -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> FedURI -> FedURI @@ -1297,7 +1368,7 @@ personOfferDepF -> KeyHashid Person -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.TicketDependency URIMode -> FedURI @@ -1504,7 +1575,7 @@ deckOfferDepF -> KeyHashid Deck -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.TicketDependency URIMode -> FedURI @@ -1674,7 +1745,7 @@ repoOfferDepF -> KeyHashid Repo -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.TicketDependency URIMode -> FedURI @@ -1869,7 +1940,7 @@ deckResolveF -> KeyHashid Deck -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> Resolve URIMode -> ExceptT Text Handler Text @@ -2006,7 +2077,7 @@ repoResolveF -> KeyHashid Repo -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> Resolve URIMode -> ExceptT Text Handler Text diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 46c592c..34d1098 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -97,6 +97,7 @@ import Vervis.Access import Vervis.API import Vervis.Federation.Auth import Vervis.Federation.Collab +import Vervis.Federation.Ticket import Vervis.FedURI import Vervis.Form.Project import Vervis.Form.Ticket @@ -187,14 +188,16 @@ postDeckInboxR recipDeckHash = -} AP.InviteActivity invite -> topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity invite - {- OfferActivity (Offer obj target) -> case obj of OfferTicket ticket -> - (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target + (,Nothing) <$> deckOfferTicketF now recipDeckHash author body mfwd luActivity ticket target + {- OfferDep dep -> projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target - _ -> return ("Unsupported offer object type for projects", Nothing) + -} + _ -> return ("Unsupported offer object type for decks", Nothing) + {- ResolveActivity resolve -> (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve UndoActivity undo -> diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 0f8514c..9cd1620 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1418,19 +1418,21 @@ encodeAdd h (Add obj target) data Apply u = Apply { applyObject :: ObjURI u - , applyTarget :: ObjURI u + , applyTarget :: Either (ObjURI u) (Authority u, Branch u) } parseApply :: UriMode u => Object -> Parser (Apply u) parseApply o = Apply <$> o .: "object" - <*> o .: "target" + <*> (second fromDoc <$> o .:+ "target") + where + fromDoc (Doc h v) = (h, v) encodeApply :: UriMode u => Apply u -> Series encodeApply (Apply obj target) = "object" .= obj - <> "target" .= target + <> "target" .=+ second (uncurry Doc) target data CreateObject u = CreateNote (Authority u) (Note u) diff --git a/vervis.cabal b/vervis.cabal index fc1c6b9..4e8b4ef 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -151,7 +151,7 @@ library --Vervis.Federation.Discussion --Vervis.Federation.Offer --Vervis.Federation.Push - --Vervis.Federation.Ticket + Vervis.Federation.Ticket Vervis.Federation.Util Vervis.FedURI -- Vervis.Field.Key