diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 4f37cb7..c400291 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -14,7 +14,8 @@ -} module Vervis.API - ( noteC + ( addBundleC + , noteC , createNoteC , createTicketC , followC @@ -119,6 +120,207 @@ import Vervis.Patch import Vervis.Ticket import Vervis.WorkItem +addBundleC + :: Entity Person + -> Sharer + -> Maybe TextHtml + -> Audience URIMode + -> NonEmpty (AP.Patch URIMode) + -> FedURI + -> ExceptT Text Handler OutboxItemId +addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarget = do + let shrUser = sharerIdent sharerUser + ticket <- do + t <- parseWorkItem "Target" uTarget + bitraverse + (\ wi -> + case wi of + WorkItemSharerTicket shr talid patch -> do + unless patch $ throwE "Target is a non-MR sharer-ticket" + return $ Left (shr, talid) + WorkItemProjectTicket _ _ _ -> + throwE "Target is a project-ticket" + WorkItemRepoProposal shr rp ltid -> + return $ Right (shr, rp, ltid) + ) + pure + t + (typ, diffs) <- do + ((typ, diff) :| rest) <- + for patches $ \ (AP.Patch mlocal attrib mpub typ content) -> do + verifyNothingE mlocal "Patch with 'id'" + shrAttrib <- do + route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route" + case route of + SharerR shr -> return shr + _ -> throwE "Patch attrib not a sharer route" + unless (shrAttrib == shrUser) $ + throwE "Add and Patch attrib mismatch" + verifyNothingE mpub "Patch has 'published'" + return (typ, content) + let (typs, diffs) = unzip rest + unless (all (== typ) typs) $ throwE "Patches of different media types" + return (typ, diff :| diffs) + ParsedAudience localRecips remoteRecips blinded fwdHosts <- do + mrecips <- parseAudience audience + fromMaybeE mrecips "Add Bundle with no recipients" + federation <- asksSite $ appFederation . appSettings + unless (federation || null remoteRecips) $ + throwE "Federation disabled, but remote recipients specified" + let ticketWI = first toWorkItem ticket + verifyHosterRecip localRecips "Ticket" ticketWI + now <- liftIO getCurrentTime + ticketDetail <- runWorkerExcept $ getWorkItemDetail "Ticket" ticketWI + (obiidAdd, docAdd, remotesHttpAdd, maybeAccept) <- runDBExcept $ do + (obiid, doc, luAdd) <- lift $ insertAddToOutbox shrUser now (personOutbox personUser) blinded + remotesHttpAdd <- do + wiFollowers <- askWorkItemFollowers + let sieve = + let (ticketA, ticketC) = + workItemRecipSieve wiFollowers ticketDetail + in makeRecipientSet + ticketA + (LocalPersonCollectionSharerFollowers shrUser : + ticketC + ) + moreRemoteRecips <- + lift $ + deliverLocal' + True + (LocalActorSharer shrUser) + (personInbox personUser) + obiid + (localRecipSieve sieve False localRecips) + unless (federation || null moreRemoteRecips) $ + throwE "Federation disabled, but recipient collection remote members found" + lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips + maccept <- + case widIdent ticketDetail of + Right _ -> return Nothing + Left (wi, ltid) -> Just <$> do + let local = + case ticket of + Left l -> l + Right _ -> error "Impossible wi" + mhoster <- + case local of + Left (shr, _) -> lift $ runMaybeT $ do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + p <- MaybeT (getValBy $ UniquePersonIdent sid) + return (personOutbox p, personInbox p) + Right (shr, rp, _) -> runMaybeT $ do + sid <- MaybeT $ lift $ getKeyBy $ UniqueSharer shr + r <- MaybeT (lift $ getValBy $ UniqueRepo rp sid) + unless (repoVcs r == patchMediaTypeVCS typ) $ + lift $ throwE "Patch type and repo VCS mismatch" + return (repoOutbox r, repoInbox r) + (obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB" + obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now + tid <- lift $ localTicketTicket <$> getJust ltid + bnid <- lift $ insert $ Bundle tid + lift $ insertMany_ $ NE.toList $ NE.map (Patch bnid now typ) diffs + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + lift $ insertAccept shrUser local ticketDetail obiid obiidAccept bnid + knownRemoteRecipsAccept <- + lift $ + deliverLocal' + False + (workItemActor wi) + ibidHoster + obiidAccept + localRecipsAccept + lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + return (obiid, doc, remotesHttpAdd, maccept) + lift $ do + forkWorker "addBundleC: async HTTP Offer delivery" $ + deliverRemoteHttp' fwdHosts obiidAdd docAdd remotesHttpAdd + for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) -> + forkWorker "addBundleC: async HTTP Accept delivery" $ + deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept + return obiidAdd + where + toWorkItem (Left (shr, talid)) = WorkItemSharerTicket shr talid True + toWorkItem (Right (shr, rp, ltid)) = WorkItemRepoProposal shr rp ltid + + insertAddToOutbox shrUser now obid blinded = do + hLocal <- asksSite siteInstanceHost + obiid <- insertEmptyOutboxItem obid now + encodeRouteLocal <- getEncodeRouteLocal + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid + doc = Doc hLocal Activity + { activityId = Just luAct + , activityActor = encodeRouteLocal $ SharerR shrUser + , activitySummary = summary + , activityAudience = blinded + , activitySpecific = + AddActivity $ AP.Add (Right $ AddBundle patches) uTarget + } + update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (obiid, doc, luAct) + + workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr + workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj + workItemActor (WorkItemRepoProposal shr rp _) = LocalActorRepo shr rp + + insertAccept shrUser local (WorkItemDetail _ ctx ticketAuthor) obiidAdd obiidAccept bnid = do + let wi = toWorkItem local + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + wiFollowers <- askWorkItemFollowers + wiBundleRoute <- getWiBundleRoute + hLocal <- asksSite siteInstanceHost + + obikhidAdd <- encodeKeyHashid obiidAdd + obikhidAccept <- encodeKeyHashid obiidAccept + bnkhid <- encodeKeyHashid bnid + + let audAuthor = + AudLocal + [LocalActorSharer shrUser] + [LocalPersonCollectionSharerFollowers shrUser] + audTicketContext = contextAudience ctx + audTicketAuthor = authorAudience ticketAuthor + audTicketFollowers = AudLocal [] [wiFollowers wi] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience $ + audAuthor : + audTicketAuthor : + audTicketFollowers : + audTicketContext + + actor = workItemActor wi + recips = map encodeRouteHome audLocal ++ audRemote + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + actorOutboxItem actor obikhidAccept + , activityActor = encodeRouteLocal $ renderLocalActor actor + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = + encodeRouteHome $ SharerOutboxItemR shrUser obikhidAdd + , acceptResult = + Just $ encodeRouteLocal $ wiBundleRoute local bnkhid + } + } + + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + where + getWiBundleRoute = do + hashLTID <- getEncodeKeyHashid + hashTALID <- getEncodeKeyHashid + return $ \ wi -> + case wi of + Left (shr, talid) -> + SharerProposalBundleR shr $ hashTALID talid + Right (shr, rp, ltid) -> + RepoProposalBundleR shr rp $ hashLTID ltid + parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId) parseComment luParent = do route <- case decodeRouteLocal luParent of diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 637f00c..5e80170 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -375,6 +375,11 @@ postSharerOutboxR shr = do Just (SharerR shr') | shr' == shr -> return () _ -> throwE "Can't post activity sttributed to someone else" case specific of + AddActivity (AP.Add obj target) -> + case obj of + Right (AddBundle patches) -> + addBundleC eperson sharer summary audience patches target + _ -> throwE "Unsupported Add 'object' type" CreateActivity (Create obj mtarget) -> case obj of CreateNote note ->