diff --git a/config/settings-default.yaml b/config/settings-default.yaml index ddc2bd9..ecf30a8 100644 --- a/config/settings-default.yaml +++ b/config/settings-default.yaml @@ -40,6 +40,9 @@ actor-key-rotation: amount: 1 unit: days +# Whether to use personal actor keys, or an instance-wide key +per-actor-keys: false + ############################################################################### # Development ############################################################################### diff --git a/migrations/497_2022-09-29_sigkey.model b/migrations/497_2022-09-29_sigkey.model new file mode 100644 index 0000000..47da10d --- /dev/null +++ b/migrations/497_2022-09-29_sigkey.model @@ -0,0 +1,5 @@ +SigKey + actor ActorId + material ActorKey + + UniqueSigKey actor diff --git a/migrations/498_2022-10-03_forwarder.model b/migrations/498_2022-10-03_forwarder.model new file mode 100644 index 0000000..db961dc --- /dev/null +++ b/migrations/498_2022-10-03_forwarder.model @@ -0,0 +1,121 @@ +RemoteActor +RemoteActivity +Role +OutboxItem +Workflow + +Forwarding + recipient RemoteActorId + activity RemoteActivityId + activityRaw ByteString + signature ByteString + forwarder ActorId + running Bool + + UniqueForwarding recipient activity + +ForwarderPerson + task ForwardingId + sender PersonId + + UniqueForwarderPerson task + +ForwarderGroup + task ForwardingId + sender GroupId + + UniqueForwarderGroup task + +ForwarderRepo + task ForwardingId + sender RepoId + + UniqueForwarderRepo task + +ForwarderLoom + task ForwardingId + sender LoomId + + UniqueForwarderLoom task + +ForwarderDeck + task ForwardingId + sender DeckId + + UniqueForwarderDeck task + +Person + username Username + login Text + passphraseHash ByteString + email EmailAddress + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + actor ActorId +-- reviewFollow Bool + + UniquePersonUsername username + UniquePersonLogin login + UniquePersonEmail email + UniquePersonActor actor + +Group + actor ActorId + + UniqueGroupActor actor + +Repo + vcs VersionControlSystem + project DeckId Maybe + mainBranch Text + collabUser RoleId Maybe + collabAnon RoleId Maybe + actor ActorId + create OutboxItemId + loom LoomId Maybe + + UniqueRepoActor actor + UniqueRepoCreate create + +Deck + actor ActorId + workflow WorkflowId + nextTicket Int + wiki RepoId Maybe + collabUser RoleId Maybe + collabAnon RoleId Maybe + create OutboxItemId + + UniqueDeckActor actor + UniqueDeckCreate create + +Loom + nextTicket Int + actor ActorId + repo RepoId + create OutboxItemId + + UniqueLoomActor actor + UniqueLoomRepo repo + UniqueLoomCreate create + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +Outbox + +Inbox + +FollowerSet diff --git a/src/Vervis/ActorKey.hs b/src/Crypto/ActorKey.hs similarity index 96% rename from src/Vervis/ActorKey.hs rename to src/Crypto/ActorKey.hs index cc0b05d..2ac7338 100644 --- a/src/Vervis/ActorKey.hs +++ b/src/Crypto/ActorKey.hs @@ -13,13 +13,13 @@ - . -} -module Vervis.ActorKey +module Crypto.ActorKey ( ActorKey () , generateActorKey , actorKeyRotator , actorKeyPublicBin , actorKeySign - -- , actorKeyVerify + , actorKeyVerify ) where @@ -195,3 +195,7 @@ actorKeyPublicBin = fromEd25519 . actorKeyPublic actorKeySign :: ActorKey -> ByteString -> Signature actorKeySign (ActorKey sec pub) = Signature . convert . sign sec pub + +actorKeyVerify :: ActorKey -> ByteString -> Signature -> Either String Bool +actorKeyVerify akey input (Signature sig) = + verifySignature (actorKeyPublicBin akey) input sig diff --git a/src/Data/Tuple/Local.hs b/src/Data/Tuple/Local.hs index d1bbebd..a947e1f 100644 --- a/src/Data/Tuple/Local.hs +++ b/src/Data/Tuple/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -17,6 +17,7 @@ module Data.Tuple.Local ( fst3 , fst4 , fst5 + , fst6 , thd3 , fourth4 , fourth5 @@ -32,6 +33,9 @@ fst4 (x, _, _, _) = x fst5 :: (a, b, c, d, e) -> a fst5 (x, _, _, _, _) = x +fst6 :: (a, b, c, d, e, f) -> a +fst6 (x, _, _, _, _, _) = x + thd3 :: (a, b, c) -> c thd3 (_, _, z) = z diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs index 54d1974..52b6a0d 100644 --- a/src/Network/FedURI.hs +++ b/src/Network/FedURI.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written 2019 by fr33domlover . + - Written 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -35,6 +35,7 @@ module Network.FedURI , PageURI (..) , RefURI (..) , parseRefURI + , renderRefURI ) where @@ -570,6 +571,9 @@ parseRefURI = toRefURI <=< toFullRefURI <=< parseFullURI uriFromRefURI :: UriMode t => RefURI t -> URI uriFromRefURI = fromFullURI . fromFullRefURI . fromRefURI +renderRefURI :: UriMode t => RefURI t -> Text +renderRefURI = renderFullURI . fromFullRefURI . fromRefURI + instance UriMode t => FromJSON (RefURI t) where parseJSON = either fail return . toRefURI <=< parseJSON diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 032d3c0..7665ed6 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -18,20 +18,20 @@ module Vervis.API ( acceptC - , addBundleC + --, addBundleC , applyC - , noteC - , createNoteC + --, noteC + --, createNoteC , createPatchTrackerC , createRepositoryC , createTicketTrackerC - , followC + --, followC , inviteC , offerTicketC - , offerDepC - , resolveC - , undoC - , pushCommitsC + --, offerDepC + --, resolveC + --, undoC + --, pushCommitsC ) where @@ -102,7 +102,7 @@ import Vervis.Darcs import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Data.Ticket -import Vervis.Delivery +import Vervis.Web.Delivery import Vervis.FedURI import Vervis.Fetch import Vervis.Foundation @@ -153,19 +153,22 @@ verifyRemoteAddressed remoteRecips u = acceptC :: Entity Person -> Actor - -> Maybe HTML - -> Audience URIMode - -> Accept URIMode + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode + -> AP.Accept URIMode -> ExceptT Text Handler OutboxItemId -acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept = do +acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action accept = do -- Check input + verifyNothingE maybeCap "Capability not needed" acceptee <- parseAccept accept - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - recips <- fromMaybeE mrecips "Accept with no recipients" - checkFederation $ paudRemoteActors recips - return recips now <- liftIO getCurrentTime senderHash <- encodeKeyHashid senderPersonID @@ -179,7 +182,6 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept -- See if the accepted activity is an Invite to a local resource maybeCollab <- - --(collabID, collabSender) <- case accepteeDB of Left (actorByKey, actorEntity, itemID) -> do maybeSender <- @@ -234,33 +236,33 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept throwE "This Collab already has an Accept by recip" -- Insert the Accept activity to author's outbox - docAccept <- lift $ insertAcceptToOutbox senderHash now blinded acceptID + _luAccept <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) acceptID action -- Deliver the Accept activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpAccept <- do - let maybeTopicActor = (\ (_, _, t, _) -> t) <$> maybeCollabMore - maybeCollabSender = (\ (_, _, _, s) -> s) <$> maybeCollabMore - maybeTopicHash <- traverse hashGrantResource maybeTopicActor - maybeSenderHash <- - case maybeCollabSender of - Just (Left (actor, _)) -> Just <$> hashLocalActor actor - _ -> pure Nothing - let sieveActors = catMaybes - [ grantResourceLocalActor <$> maybeTopicHash - , maybeSenderHash - ] - sieveStages = catMaybes - [ Just $ LocalStagePersonFollowers senderHash - , localActorFollowers . grantResourceLocalActor <$> maybeTopicHash - , localActorFollowers <$> maybeSenderHash - ] - sieve = makeRecipientSet sieveActors sieveStages - moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) acceptID $ - localRecipSieve sieve False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts acceptID remoteRecips moreRemoteRecips + deliverHttpAccept <- do + sieve <- do + let maybeTopicActor = (\ (_, _, t, _) -> t) <$> maybeCollabMore + maybeCollabSender = (\ (_, _, _, s) -> s) <$> maybeCollabMore + maybeTopicHash <- traverse hashGrantResource maybeTopicActor + maybeSenderHash <- + case maybeCollabSender of + Just (Left (actor, _)) -> Just <$> hashLocalActor actor + _ -> pure Nothing + let sieveActors = catMaybes + [ grantResourceLocalActor <$> maybeTopicHash + , maybeSenderHash + ] + sieveStages = catMaybes + [ Just $ LocalStagePersonFollowers senderHash + , localActorFollowers . grantResourceLocalActor <$> maybeTopicHash + , localActorFollowers <$> maybeSenderHash + ] + return $ makeRecipientSet sieveActors sieveStages + let localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor senderPerson) + localRecipsFinal remoteRecips fwdHosts acceptID action -- If resource is local, approve the Collab and deliver a Grant deliverHttpGrant <- for maybeCollabMore $ \ (collabID, _, resource, sender) -> do @@ -273,7 +275,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept -- If Collab sender is local, verify it has received the Accept case sender of - Left (_, (Entity actorID _)) -> + Left (_, Entity actorID _) -> verifyActorHasItem actorID acceptID "Local Collab sender didn't receive the Accept" Right _ -> pure () @@ -284,25 +286,22 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept lift $ insert_ $ CollabEnable collabID grantID -- Insert the Grant to resource's outbox - (docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- - lift $ insertGrantToOutbox senderHash sender resource grantID + (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- + lift . lift $ prepareGrant senderHash sender resource + _luGrant <- lift $ updateOutboxItem (grantResourceLocalActor resource) grantID actionGrant -- Deliver the Grant to local recipients, and schedule delivery -- for unavailable remote recipients - remoteRecipsHttpGrant <- do - moreRemoteRecips <- do - resourceHash <- hashGrantResource resource - lift $ deliverLocal' True (grantResourceLocalActor resourceHash) resourceActorID grantID localRecipsGrant - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant moreRemoteRecips - - -- Return instructions for HTTP delivery to remote recipients - return $ deliverRemoteHttp' fwdHostsGrant grantID docGrant remoteRecipsHttpGrant + resourceHash <- + grantResourceLocalActor <$> hashGrantResource resource + deliverActivityDB + resourceHash resourceActorID localRecipsGrant remoteRecipsGrant + fwdHostsGrant grantID actionGrant -- Return instructions for HTTP delivery to remote recipients return ( acceptID - , deliverRemoteHttp' fwdHosts acceptID docAccept remoteRecipsHttpAccept + , deliverHttpAccept , deliverHttpGrant ) @@ -321,43 +320,21 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept unless (actorIsAddressed localRecips actorByHash) $ throwE "Collab sender not addressed" - insertAcceptToOutbox senderHash now blinded acceptID = do - encodeRouteLocal <- getEncodeRouteLocal - hLocal <- asksSite siteInstanceHost - acceptHash <- encodeKeyHashid acceptID - let doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - PersonOutboxItemR senderHash acceptHash - , activityActor = encodeRouteLocal $ PersonR senderHash - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activityFulfills = [] - , activitySpecific = AcceptActivity accept - } - update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return doc - - insertGrantToOutbox + prepareGrant :: KeyHashid Person -> Either (LocalActorBy Key, Entity Actor) (FedURI, Maybe LocalURI) -> GrantResourceBy Key - -> OutboxItemId - -> ReaderT SqlBackend Handler - ( Doc Activity URIMode + -> Handler + ( AP.Action URIMode , RecipientRoutes , [(Host, NonEmpty LocalURI)] , [Host] ) - insertGrantToOutbox recipHash sender topic grantID = do - encodeRouteLocal <- getEncodeRouteLocal + prepareGrant recipHash sender topic = do encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost topicHash <- grantResourceLocalActor <$> hashGrantResource topic - grantHash <- encodeKeyHashid grantID senderHash <- bitraverse (hashLocalActor . fst) pure sender let audSender = @@ -374,22 +351,19 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept collectAudience [audSender, audRecip, audTopic] recips = map encodeRouteHome audLocal ++ audRemote - doc = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ activityRoute topicHash grantHash - , activityActor = encodeRouteLocal $ renderLocalActor topicHash - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activityFulfills = [] - , activitySpecific = GrantActivity Grant + action = Action + { actionCapability = Nothing + , actionSummary = Nothing + , actionAudience = Audience recips [] [] [] [] [] + , actionFulfills = [AP.acceptObject accept] + , actionSpecific = GrantActivity Grant { grantObject = Left RoleAdmin , grantContext = encodeRouteHome $ renderLocalActor topicHash , grantTarget = encodeRouteHome $ PersonR recipHash } } - update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) + return (action, recipientSet, remoteActors, fwdHosts) addBundleC :: Entity Person @@ -460,7 +434,7 @@ addBundleC (Entity pidUser personUser) summary audience patches uTarget = do (localRecipSieve sieve False localRecips) unless (federation || null moreRemoteRecips) $ throwE "Federation disabled, but recipient collection remote members found" - lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips + lift $ deliverRemoteDB fwdHosts obiid remoteRecips moreRemoteRecips maccept <- case ticket of Right _ -> return Nothing @@ -492,7 +466,7 @@ addBundleC (Entity pidUser personUser) summary audience patches uTarget = do acceptID localRecipsAccept lift $ (acceptID,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept acceptID remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept acceptID remoteRecipsAccept knownRemoteRecipsAccept return (obiid, doc, remotesHttpAdd, maccept) lift $ do forkWorker "addBundleC: async HTTP Offer delivery" $ @@ -593,19 +567,22 @@ addBundleC (Entity pidUser personUser) summary audience patches uTarget = do applyC :: Entity Person -> Actor - -> Maybe FedURI - -> Maybe HTML - -> Audience URIMode - -> Apply URIMode + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode + -> AP.Apply URIMode -> ExceptT Text Handler OutboxItemId -applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience apply = do +applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action apply = do -- Check input maybeLocalTarget <- checkApplyLocalLoom apply - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Apply with no recipients" - checkFederation remoteRecips + capID <- fromMaybeE maybeCap "No capability provided" -- Verify that the bundle's loom is addressed for_ maybeLocalTarget $ \ (_, _, loomID, _, _) -> do @@ -613,13 +590,6 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience a unless (actorIsAddressed localRecips $ LocalActorLoom loomHash) $ throwE "Bundle's loom not addressed by the Apply" - -- Verify the capability URI is one of: - -- * Outbox item URI of a local actor, i.e. a local activity - -- * A remote URI - capID <- do - uCap <- fromMaybeE muCap "No capability provided" - nameExceptT "Apply capability" $ parseActivityURI uCap - maybeLocalTargetDB <- for maybeLocalTarget $ \ (repoID, maybeBranch, loomID, clothID, bundleID) -> runDBExcept $ do @@ -648,32 +618,31 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience a -- Insert Apply to sender's outbox applyID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now - (luApply, docApply) <- - lift $ insertApplyToOutbox senderHash blinded applyID + luApply <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) applyID action -- Deliver the Apply activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpApply <- do - hashLoom <- getEncodeKeyHashid - hashCloth <- getEncodeKeyHashid - let maybeLoom = - maybeLocalTargetDB <&> - \ (Entity loomID _, clothID, _, _, _, _) -> - (hashLoom loomID, hashCloth clothID) - sieveActors = catMaybes - [ LocalActorLoom . fst <$> maybeLoom - ] - sieveStages = catMaybes - [ LocalStageLoomFollowers . fst <$> maybeLoom - , uncurry LocalStageClothFollowers <$> maybeLoom - , Just $ LocalStagePersonFollowers senderHash - ] - sieve = makeRecipientSet sieveActors sieveStages - moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) applyID $ - localRecipSieve sieve False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts applyID remoteRecips moreRemoteRecips + deliverHttpApply <- do + sieve <- do + hashLoom <- getEncodeKeyHashid + hashCloth <- getEncodeKeyHashid + let maybeLoom = + maybeLocalTargetDB <&> + \ (Entity loomID _, clothID, _, _, _, _) -> + (hashLoom loomID, hashCloth clothID) + sieveActors = catMaybes + [ LocalActorLoom . fst <$> maybeLoom + ] + sieveStages = catMaybes + [ LocalStageLoomFollowers . fst <$> maybeLoom + , uncurry LocalStageClothFollowers <$> maybeLoom + , Just $ LocalStagePersonFollowers senderHash + ] + return $ makeRecipientSet sieveActors sieveStages + let localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor senderPerson) + localRecipsFinal remoteRecips fwdHosts applyID action -- Verify that the loom has received the Apply, resolve the Ticket in -- DB, and publish Accept @@ -698,28 +667,22 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience a , LocalStageClothFollowers loomHash clothHash , LocalStagePersonFollowers senderHash ] - docAccept <- - lift $ insertAcceptToOutbox senderHash loomHash luApply acceptID acceptRecipActors acceptRecipStages + actionAccept <- prepareAccept luApply acceptRecipActors acceptRecipStages + _ <- lift $ updateOutboxItem (LocalActorLoom loomID) acceptID actionAccept -- Deliver the Accept activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpAccept <- do - remoteRecips <- - lift $ deliverLocal' True (LocalActorLoom loomHash) loomActorID acceptID $ - makeRecipientSet acceptRecipActors acceptRecipStages - checkFederation remoteRecips - lift $ deliverRemoteDB'' [] acceptID [] remoteRecips - - -- Return instructions for HTTP delivery of the Accept to remote - -- recipients - return $ - deliverRemoteHttp' [] acceptID docAccept remoteRecipsHttpAccept + let localRecipsAccept = + makeRecipientSet acceptRecipActors acceptRecipStages + deliverActivityDB + (LocalActorLoom loomHash) loomActorID localRecipsAccept [] [] + acceptID actionAccept -- Return instructions for HTTP delivery or Apply and Accept to remote -- recipients return ( applyID - , deliverRemoteHttp' fwdHosts applyID docApply remoteRecipsHttpApply + , deliverHttpApply , maybeDeliverHttpAccept ) @@ -733,23 +696,6 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience a where - insertApplyToOutbox senderHash blinded applyID = do - encodeRouteLocal <- getEncodeRouteLocal - hLocal <- asksSite siteInstanceHost - applyHash <- encodeKeyHashid applyID - let luApply = encodeRouteLocal $ PersonOutboxItemR senderHash applyHash - doc = Doc hLocal Activity - { activityId = Just luApply - , activityActor = encodeRouteLocal $ PersonR senderHash - , activityCapability = muCap - , activitySummary = summary - , activityAudience = blinded - , activityFulfills = [] - , activitySpecific = ApplyActivity apply - } - update applyID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (luApply, doc) - insertResolve ticketID applyID acceptID = do trid <- insert TicketResolve { ticketResolveTicket = ticketID @@ -761,31 +707,23 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience a } update ticketID [TicketStatus =. TSClosed] - insertAcceptToOutbox personHash loomHash luApply acceptID actors stages = do - encodeRouteLocal <- getEncodeRouteLocal + prepareAccept luApply actors stages = do encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost - acceptHash <- encodeKeyHashid acceptID let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalStage stages - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - LoomOutboxItemR loomHash acceptHash - , activityActor = encodeRouteLocal $ LoomR loomHash - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activityFulfills = [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hLocal luApply - , acceptResult = Nothing - } + return AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = ObjURI hLocal luApply + , AP.acceptResult = Nothing } - update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return doc + } parseComment :: LocalURI -> ExceptT Text Handler (PersonId, LocalMessageId) parseComment luParent = do @@ -879,7 +817,7 @@ createNoteC (Entity pidUser personUser) summary audience note muTarget = do lift $ deliverLocal' True (LocalActorPerson senderHash) (personInbox personUser) obiidCreate $ localRecipSieve' sieve True False localRecips checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips + lift $ deliverRemoteDB fwdHosts obiidCreate remoteRecips moreRemoteRecips return (obiidCreate, docCreate, remoteRecipsHttpCreate) lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp return obiid @@ -1057,26 +995,30 @@ checkFederation remoteRecips = do createPatchTrackerC :: Entity Person -> Actor - -> Maybe HTML - -> Audience URIMode + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode -> AP.ActorDetail -> NonEmpty FedURI -> Maybe (Host, AP.ActorLocal URIMode) -> Maybe FedURI -> ExceptT Text Handler OutboxItemId -createPatchTrackerC (Entity pidUser personUser) senderActor summary audience detail repos mlocal muTarget = do +createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips remoteRecips fwdHosts action detail repos mlocal muTarget = do -- Check input + verifyNothingE maybeCap "Capability not needed" verifyNothingE mlocal "'id' not allowed in new PatchTracker to create" (name, msummary) <- parseDetail detail repoID <- parseRepo repos senderHash <- encodeKeyHashid pidUser now <- liftIO getCurrentTime verifyNothingE muTarget "'target' not supported in Create PatchTracker" - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Create PatchTracker with no recipients" - checkFederation remoteRecips (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do @@ -1108,22 +1050,22 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det -- Insert the Create activity to author's outbox loomHash <- encodeKeyHashid loomID repoHash <- encodeKeyHashid repoID - docCreate <- lift $ insertCreateToOutbox senderHash now blinded name msummary obiidCreate loomHash repoHash + actionCreate <- prepareCreate name msummary loomHash repoHash + _luCreate <- lift $ updateOutboxItem (LocalActorPerson pidUser) obiidCreate actionCreate -- Deliver the Create activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpCreate <- do + deliverHttpCreate <- do let sieve = makeRecipientSet [LocalActorRepo repoHash] [ LocalStagePersonFollowers senderHash , LocalStageRepoFollowers repoHash ] - moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) obiidCreate $ - localRecipSieve sieve False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips + localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor personUser) + localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate -- Insert collaboration access for loom's creator let loomOutboxID = actorOutbox loomActor @@ -1133,17 +1075,18 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det -- Insert a Grant activity to loom's outbox let grantRecipActors = [LocalActorPerson senderHash] grantRecipStages = [LocalStagePersonFollowers senderHash] - docGrant <- - lift $ insertGrantToOutbox senderHash loomHash obiidCreate obiidGrant grantRecipActors grantRecipStages + actionGrant <- + prepareGrant senderHash loomHash obiidCreate grantRecipActors grantRecipStages + _luGrant <- lift $ updateOutboxItem (LocalActorLoom loomID) obiidGrant actionGrant -- Deliver the Grant activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpGrant <- do - remoteRecips <- - lift $ deliverLocal' True (LocalActorLoom loomHash) loomActorID obiidGrant $ + deliverHttpGrant <- do + let localRecipsGrant = makeRecipientSet grantRecipActors grantRecipStages - checkFederation remoteRecips - lift $ deliverRemoteDB'' [] obiidGrant [] remoteRecips + deliverActivityDB + (LocalActorLoom loomHash) loomActorID localRecipsGrant [] [] + obiidGrant actionGrant -- Insert follow record obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now @@ -1164,11 +1107,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA -- Return instructions for HTTP delivery to remote recipients - return - ( obiidCreate - , deliverRemoteHttp' fwdHosts obiidCreate docCreate remoteRecipsHttpCreate - , deliverRemoteHttp' [] obiidGrant docGrant remoteRecipsHttpGrant - ) + return (obiidCreate, deliverHttpCreate, deliverHttpGrant) -- Launch asynchronous HTTP delivery of Create and Grant lift $ do @@ -1206,11 +1145,10 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det } return (loomID, actor) - insertCreateToOutbox senderHash now blinded name msummary obiidCreate loomHash repoHash = do + prepareCreate name msummary loomHash repoHash = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost - obikhid <- encodeKeyHashid obiidCreate let ptdetail = AP.ActorDetail { AP.actorType = AP.ActorTypePatchTracker , AP.actorUsername = Nothing @@ -1227,20 +1165,11 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det , AP.actorSshKeys = [] } repo = encodeRouteHome $ RepoR repoHash - create = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid - , activityActor = encodeRouteLocal $ PersonR senderHash - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activityFulfills = [] - , activitySpecific = CreateActivity Create - { createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal)) - , createTarget = Nothing - } + specific = CreateActivity Create + { createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal)) + , createTarget = Nothing } - update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] - return create + return action { actionSpecific = specific } insertCollab loomID obiidGrant = do cid <- insert Collab @@ -1249,34 +1178,25 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det insert_ $ CollabRecipLocal cid pidUser insert_ $ CollabFulfillsLocalTopicCreation cid - insertGrantToOutbox adminHash loomHash obiidCreate obiidGrant actors stages = do - encodeRouteLocal <- getEncodeRouteLocal + prepareGrant adminHash loomHash obiidCreate actors stages = do encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost obikhidCreate <- encodeKeyHashid obiidCreate - obikhidGrant <- encodeKeyHashid obiidGrant let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalStage stages - grant = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - LoomOutboxItemR loomHash obikhidGrant - , activityActor = encodeRouteLocal $ LoomR loomHash - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activityFulfills = - [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] - , activitySpecific = GrantActivity Grant - { grantObject = Left RoleAdmin - , grantContext = encodeRouteHome $ LoomR loomHash - , grantTarget = encodeRouteHome $ PersonR adminHash - } + return Action + { actionCapability = Nothing + , actionSummary = Nothing + , actionAudience = Audience recips [] [] [] [] [] + , actionFulfills = + [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] + , actionSpecific = GrantActivity Grant + { grantObject = Left RoleAdmin + , grantContext = encodeRouteHome $ LoomR loomHash + , grantTarget = encodeRouteHome $ PersonR adminHash } - update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant] - return grant + } insertFollowToOutbox senderHash loomHash obiidFollow = do encodeRouteLocal <- getEncodeRouteLocal @@ -1327,25 +1247,29 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det createRepositoryC :: Entity Person -> Actor - -> Maybe HTML - -> Audience URIMode + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode -> AP.ActorDetail -> VersionControlSystem -> Maybe (Host, AP.ActorLocal URIMode) -> Maybe FedURI -> ExceptT Text Handler OutboxItemId -createRepositoryC (Entity pidUser personUser) senderActor summary audience detail vcs mlocal muTarget = do +createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips remoteRecips fwdHosts action detail vcs mlocal muTarget = do -- Check input + verifyNothingE maybeCap "Capability not needed" verifyNothingE mlocal "'id' not allowed in new Repository to create" (name, msummary) <- parseDetail detail senderHash <- encodeKeyHashid pidUser now <- liftIO getCurrentTime verifyNothingE muTarget "'target' not supported in Create Repository" - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Create Repository with no recipients" - checkFederation remoteRecips (obiid, newRepoHash, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do @@ -1357,18 +1281,18 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai -- Insert the Create activity to author's outbox repoHash <- encodeKeyHashid repoID - docCreate <- lift $ insertCreateToOutbox senderHash now blinded name msummary obiidCreate repoHash + actionCreate <- prepareCreate now name msummary repoHash + _luCreate <- lift $ updateOutboxItem (LocalActorPerson pidUser) obiidCreate actionCreate -- Deliver the Create activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpCreate <- do + deliverHttpCreate <- do let sieve = makeRecipientSet [] [LocalStagePersonFollowers senderHash] - moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) obiidCreate $ - localRecipSieve sieve False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips + localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor personUser) + localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate -- Insert collaboration access for repo's creator let repoOutboxID = actorOutbox repoActor @@ -1378,17 +1302,17 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai -- Insert a Grant activity to repo's outbox let grantRecipActors = [LocalActorPerson senderHash] grantRecipStages = [LocalStagePersonFollowers senderHash] - docGrant <- - lift $ insertGrantToOutbox senderHash repoHash obiidCreate grantID grantRecipActors grantRecipStages + actionGrant <- prepareGrant senderHash repoHash obiidCreate grantRecipActors grantRecipStages + _luGrant <- lift $ updateOutboxItem (LocalActorRepo repoID) grantID actionGrant -- Deliver the Grant activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpGrant <- do - remoteRecips <- - lift $ deliverLocal' True (LocalActorRepo repoHash) repoActorID grantID $ + deliverHttpGrant <- do + let localRecipsGrant = makeRecipientSet grantRecipActors grantRecipStages - checkFederation remoteRecips - lift $ deliverRemoteDB'' [] grantID [] remoteRecips + deliverActivityDB + (LocalActorRepo repoHash) repoActorID localRecipsGrant [] [] + grantID actionGrant -- Insert follow record obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now @@ -1409,12 +1333,7 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA -- Return instructions for HTTP delivery to remote recipients - return - ( obiidCreate - , repoHash - , deliverRemoteHttp' fwdHosts obiidCreate docCreate remoteRecipsHttpCreate - , deliverRemoteHttp' [] grantID docGrant remoteRecipsHttpGrant - ) + return (obiidCreate, repoHash, deliverHttpCreate, deliverHttpGrant) -- Insert new repo to filesystem lift $ createRepo newRepoHash @@ -1450,10 +1369,9 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai } return (repoID, actor) - insertCreateToOutbox senderHash now blinded name msummary obiidCreate repoHash = do + prepareCreate now name msummary repoHash = do encodeRouteLocal <- getEncodeRouteLocal hLocal <- asksSite siteInstanceHost - obikhid <- encodeKeyHashid obiidCreate let rdetail = AP.ActorDetail { AP.actorType = AP.ActorTypeRepo , AP.actorUsername = Nothing @@ -1469,20 +1387,11 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai , AP.actorPublicKeys = [] , AP.actorSshKeys = [] } - create = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid - , activityActor = encodeRouteLocal $ PersonR senderHash - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activityFulfills = [] - , activitySpecific = CreateActivity Create - { createObject = CreateRepository rdetail vcs (Just (hLocal, rlocal)) - , createTarget = Nothing - } + specific = CreateActivity Create + { createObject = CreateRepository rdetail vcs (Just (hLocal, rlocal)) + , createTarget = Nothing } - update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] - return create + return action { actionSpecific = specific } insertCollab repoID grantID = do collabID <- insert Collab @@ -1491,34 +1400,25 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai insert_ $ CollabRecipLocal collabID pidUser insert_ $ CollabFulfillsLocalTopicCreation collabID - insertGrantToOutbox adminHash repoHash obiidCreate obiidGrant actors stages = do - encodeRouteLocal <- getEncodeRouteLocal + prepareGrant adminHash repoHash obiidCreate actors stages = do encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost obikhidCreate <- encodeKeyHashid obiidCreate - obikhidGrant <- encodeKeyHashid obiidGrant let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalStage stages - grant = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - RepoOutboxItemR repoHash obikhidGrant - , activityActor = encodeRouteLocal $ RepoR repoHash - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activityFulfills = - [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] - , activitySpecific = GrantActivity Grant - { grantObject = Left RoleAdmin - , grantContext = encodeRouteHome $ RepoR repoHash - , grantTarget = encodeRouteHome $ PersonR adminHash - } + return Action + { actionCapability = Nothing + , actionSummary = Nothing + , actionAudience = Audience recips [] [] [] [] [] + , actionFulfills = + [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] + , actionSpecific = GrantActivity Grant + { grantObject = Left RoleAdmin + , grantContext = encodeRouteHome $ RepoR repoHash + , grantTarget = encodeRouteHome $ PersonR adminHash } - update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant] - return grant + } insertFollowToOutbox senderHash repoHash obiidFollow = do encodeRouteLocal <- getEncodeRouteLocal @@ -1591,24 +1491,29 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai createTicketTrackerC :: Entity Person -> Actor - -> Maybe HTML - -> Audience URIMode + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode -> AP.ActorDetail -> Maybe (Host, AP.ActorLocal URIMode) -> Maybe FedURI -> ExceptT Text Handler OutboxItemId -createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tracker mlocal muTarget = do +createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips remoteRecips fwdHosts action tracker mlocal muTarget = do -- Check input + verifyNothingE maybeCap "Capability not needed" verifyNothingE mlocal "'id' not allowed in new TicketTracker to create" (name, msummary) <- parseTracker tracker senderHash <- encodeKeyHashid pidUser now <- liftIO getCurrentTime verifyNothingE muTarget "'target' not supported in Create TicketTracker" - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Create TicketTracker with no recipients" - checkFederation remoteRecips + (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do -- Insert new deck to DB @@ -1618,18 +1523,18 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr -- Insert the Create activity to author's outbox deckHash <- encodeKeyHashid jid - docCreate <- lift $ insertCreateToOutbox senderHash now blinded name msummary obiidCreate deckHash + actionCreate <- prepareCreate name msummary deckHash + _luCreate <- lift $ updateOutboxItem (LocalActorPerson pidUser) obiidCreate actionCreate -- Deliver the Create activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpCreate <- do + deliverHttpCreate <- do let sieve = makeRecipientSet [] [LocalStagePersonFollowers senderHash] - moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) obiidCreate $ - localRecipSieve sieve False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips + localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor personUser) + localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate -- Insert collaboration access for deck's creator obiidGrant <- lift $ insertEmptyOutboxItem obidDeck now @@ -1638,17 +1543,17 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr -- Insert a Grant activity to deck's outbox let grantRecipActors = [LocalActorPerson senderHash] grantRecipStages = [LocalStagePersonFollowers senderHash] - docGrant <- - lift $ insertGrantToOutbox senderHash deckHash obiidCreate obiidGrant grantRecipActors grantRecipStages + actionGrant <- prepareGrant senderHash deckHash obiidCreate grantRecipActors grantRecipStages + _luGrant <- lift $ updateOutboxItem (LocalActorDeck jid) obiidGrant actionGrant -- Deliver the Grant activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpGrant <- do - remoteRecips <- - lift $ deliverLocal' True (LocalActorDeck deckHash) aidDeck obiidGrant $ + deliverHttpGrant <- do + let localRecipsGrant = makeRecipientSet grantRecipActors grantRecipStages - checkFederation remoteRecips - lift $ deliverRemoteDB'' [] obiidGrant [] remoteRecips + deliverActivityDB + (LocalActorDeck deckHash) aidDeck localRecipsGrant [] [] + obiidGrant actionGrant -- Insert follow record obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now @@ -1669,11 +1574,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA -- Return instructions for HTTP delivery to remote recipients - return - ( obiidCreate - , deliverRemoteHttp' fwdHosts obiidCreate docCreate remoteRecipsHttpCreate - , deliverRemoteHttp' [] obiidGrant docGrant remoteRecipsHttpGrant - ) + return (obiidCreate, deliverHttpCreate, deliverHttpGrant) -- Launch asynchronous HTTP delivery of Create and Grant lift $ do @@ -1716,10 +1617,9 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr } return (did, obid, ibid, aid, fsid) - insertCreateToOutbox senderHash now blinded name msummary obiidCreate deckHash = do + prepareCreate name msummary deckHash = do encodeRouteLocal <- getEncodeRouteLocal hLocal <- asksSite siteInstanceHost - obikhid <- encodeKeyHashid obiidCreate let ttdetail = AP.ActorDetail { AP.actorType = AP.ActorTypeTicketTracker , AP.actorUsername = Nothing @@ -1735,20 +1635,11 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr , AP.actorPublicKeys = [] , AP.actorSshKeys = [] } - create = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid - , activityActor = encodeRouteLocal $ PersonR senderHash - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activityFulfills = [] - , activitySpecific = CreateActivity Create - { createObject = CreateTicketTracker ttdetail (Just (hLocal, ttlocal)) - , createTarget = Nothing - } + specific = CreateActivity Create + { createObject = CreateTicketTracker ttdetail (Just (hLocal, ttlocal)) + , createTarget = Nothing } - update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create] - return create + return action { actionSpecific = specific } insertCollab did obiidGrant = do cid <- insert Collab @@ -1757,34 +1648,25 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr insert_ $ CollabRecipLocal cid pidUser insert_ $ CollabFulfillsLocalTopicCreation cid - insertGrantToOutbox adminHash deckHash obiidCreate obiidGrant actors stages = do - encodeRouteLocal <- getEncodeRouteLocal + prepareGrant adminHash deckHash obiidCreate actors stages = do encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost obikhidCreate <- encodeKeyHashid obiidCreate - obikhidGrant <- encodeKeyHashid obiidGrant let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalStage stages - grant = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - DeckOutboxItemR deckHash obikhidGrant - , activityActor = encodeRouteLocal $ DeckR deckHash - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activityFulfills = - [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] - , activitySpecific = GrantActivity Grant - { grantObject = Left RoleAdmin - , grantContext = encodeRouteHome $ DeckR deckHash - , grantTarget = encodeRouteHome $ PersonR adminHash - } + return Action + { actionCapability = Nothing + , actionSummary = Nothing + , actionAudience = Audience recips [] [] [] [] [] + , actionFulfills = + [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] + , actionSpecific = GrantActivity Grant + { grantObject = Left RoleAdmin + , grantContext = encodeRouteHome $ DeckR deckHash + , grantTarget = encodeRouteHome $ PersonR adminHash } - update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant] - return grant + } insertFollowToOutbox senderHash deckHash obiidFollow = do encodeRouteLocal <- getEncodeRouteLocal @@ -1832,6 +1714,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr } update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] +{- data Followee = FolloweePerson (KeyHashid Person) | FolloweeGroup (KeyHashid Group) @@ -1843,17 +1726,20 @@ data Followee followC :: Entity Person - -> Maybe HTML - -> Audience URIMode + -> Actor + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode -> AP.Follow URIMode -> ExceptT Text Handler OutboxItemId -followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObject muContext hide) = do - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Follow with no recipients" - federation <- asksSite $ appFederation . appSettings - unless (federation || null remoteRecips) $ - throwE "Federation disabled, but remote recipients specified" +followC (Entity pidSender personSender) _senderActor maybeCap localRecips remoteRecips fwdHosts action follow@(AP.Follow uObject muContext hide) = do + verifyNothingE maybeCap "Capability not needed" now <- liftIO getCurrentTime senderHash <- encodeKeyHashid pidSender mfollowee <- do @@ -1886,7 +1772,8 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje actorSender <- lift $ getJust actorSenderID let ibidSender = actorInbox actorSender obidSender = actorOutbox actorSender - (obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox now senderHash obidSender blinded + obiidFollow <- lift $ insertEmptyOutboxItem obidSender now + luFollow <- lift $ updateOutboxItem (LocalActorPerson pidSender) obiidFollow action case mfollowee of Nothing -> lift $ insert_ $ FollowRemoteRequest pidSender uObject muContext (not hide) obiidFollow Just (followee, actorRecip) -> do @@ -1898,7 +1785,7 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje fsid = fromMaybe (actorFollowers actorRecipDB) mfsid deliverFollowLocal now actorSenderID fsid unread obiidFollow obiidAccept ibidRecip lift $ deliverAcceptLocal now obiidAccept ibidSender - remotesHttp <- lift $ deliverRemoteDB'' fwdHosts obiidFollow remoteRecips [] + remotesHttp <- lift $ deliverRemoteDB fwdHosts obiidFollow remoteRecips [] return (obiidFollow, doc, remotesHttp) lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidFollow doc remotesHttp return obiidFollow @@ -1952,24 +1839,6 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje fromMaybeE mticket "Follow object: No such cloth in DB" return (actor, Just $ ticketFollowers ticket, False) - insertFollowToOutbox now senderHash obid blinded = do - encodeRouteLocal <- getEncodeRouteLocal - hLocal <- asksSite siteInstanceHost - obiid <- insertEmptyOutboxItem obid now - obikhid <- encodeKeyHashid obiid - let luFollow = encodeRouteLocal $ PersonOutboxItemR senderHash obikhid - doc = Doc hLocal Activity - { activityId = Just luFollow - , activityActor = encodeRouteLocal $ PersonR senderHash - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activityFulfills = [] - , activitySpecific = FollowActivity follow - } - update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (obiid, doc, luFollow) - insertAcceptToOutbox senderHash luFollow actorRecip obidRecip = do now <- liftIO getCurrentTime summary <- @@ -2020,30 +1889,27 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje deliverAcceptLocal now obiidAccept ibidAuthor = do ibiid <- insert $ InboxItem True now insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid +-} inviteC :: Entity Person -> Actor - -> Maybe FedURI - -> Maybe HTML - -> Audience URIMode - -> Invite URIMode + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode + -> AP.Invite URIMode -> ExceptT Text Handler OutboxItemId -inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience invite = do +inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action invite = do -- Check input (resource, recipient) <- parseInvite (Left senderPersonID) invite - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - recips <- fromMaybeE mrecips "Invite with no recipients" - checkFederation $ paudRemoteActors recips - return recips - - -- Verify the capability URI is one of: - -- * Outbox item URI of a local actor, i.e. a local activity - -- * A remote URI - uCap <- fromMaybeE muCap "No capability provided" - capID <- nameExceptT "Invite capability" $ parseActivityURI uCap + capID <- fromMaybeE maybeCap "No capability provided" -- If resource is remote, HTTP GET it and its managing actor, and insert to -- our DB. If resource is local, find it in our DB. @@ -2117,40 +1983,40 @@ inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience Right _ -> pure () -- Insert the Grant activity to author's outbox - docInvite <- lift $ insertInviteToOutbox senderHash now uCap blinded inviteID + _luInvite <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) inviteID action -- Deliver the Invite activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpInvite <- do - resourceHash <- bitraverse hashGrantResource pure resource - recipientHash <- bitraverse hashGrantRecip pure recipient - let sieveActors = catMaybes - [ case resourceHash of - Left (GrantResourceRepo r) -> Just $ LocalActorRepo r - Left (GrantResourceDeck d) -> Just $ LocalActorDeck d - Left (GrantResourceLoom l) -> Just $ LocalActorLoom l - Right _ -> Nothing - , case recipientHash of - Left (GrantRecipPerson p) -> Just $ LocalActorPerson p - Right _ -> Nothing - ] - sieveStages = catMaybes - [ Just $ LocalStagePersonFollowers senderHash - , case resourceHash of - Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r - Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d - Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l - Right _ -> Nothing - , case recipientHash of - Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p - Right _ -> Nothing - ] - sieve = makeRecipientSet sieveActors sieveStages - moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) inviteID $ - localRecipSieve sieve False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts inviteID remoteRecips moreRemoteRecips + deliverHttpInvite <- do + sieve <- do + resourceHash <- bitraverse hashGrantResource pure resource + recipientHash <- bitraverse hashGrantRecip pure recipient + let sieveActors = catMaybes + [ case resourceHash of + Left (GrantResourceRepo r) -> Just $ LocalActorRepo r + Left (GrantResourceDeck d) -> Just $ LocalActorDeck d + Left (GrantResourceLoom l) -> Just $ LocalActorLoom l + Right _ -> Nothing + , case recipientHash of + Left (GrantRecipPerson p) -> Just $ LocalActorPerson p + Right _ -> Nothing + ] + sieveStages = catMaybes + [ Just $ LocalStagePersonFollowers senderHash + , case resourceHash of + Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r + Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d + Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l + Right _ -> Nothing + , case recipientHash of + Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p + Right _ -> Nothing + ] + return $ makeRecipientSet sieveActors sieveStages + let localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor senderPerson) + localRecipsFinal remoteRecips fwdHosts inviteID action -- If resource is local, verify it has received the Grant case resourceDB of @@ -2170,10 +2036,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience Right _ -> pure () -- Return instructions for HTTP delivery to remote recipients - return - ( inviteID - , deliverRemoteHttp' fwdHosts inviteID docInvite remoteRecipsHttpInvite - ) + return (inviteID, deliverHttpInvite) -- Launch asynchronous HTTP delivery of the Grant activity lift $ do @@ -2250,48 +2113,34 @@ inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience Right (remoteActorID, _) -> insert_ $ CollabRecipRemote collabID remoteActorID - insertInviteToOutbox senderHash now uCap blinded inviteID = do - encodeRouteLocal <- getEncodeRouteLocal - hLocal <- asksSite siteInstanceHost - inviteHash <- encodeKeyHashid inviteID - let doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - PersonOutboxItemR senderHash inviteHash - , activityActor = encodeRouteLocal $ PersonR senderHash - , activityCapability = Just uCap - , activitySummary = summary - , activityAudience = blinded - , activityFulfills = [] - , activitySpecific = InviteActivity invite - } - update inviteID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return doc - hashGrantRecip (GrantRecipPerson k) = GrantRecipPerson <$> encodeKeyHashid k offerTicketC :: Entity Person -> Actor - -> Maybe HTML - -> Audience URIMode + -> Maybe + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler OutboxItemId -offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience ticket uTarget = do +offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action ticket uTarget = do -- Check input + verifyNothingE maybeCap "Capability not needed" (title, desc, source, tam) <- do hostLocal <- asksSite siteInstanceHost WorkItemOffer {..} <- checkOfferTicket hostLocal ticket uTarget unless (wioAuthor == Left senderPersonID) $ throwE "Offering a Ticket attributed to someone else" return (wioTitle, wioDesc, wioSource, wioRest) - ParsedAudience localRecips remoteRecips blinded fwdHosts <- do - mrecips <- parseAudience audience - fromMaybeE mrecips "Offer Ticket with no recipients" - checkFederation remoteRecips -- Verify that the target tracker is addressed by the Offer case tam of @@ -2408,11 +2257,11 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t -- Insert Offer to sender's outbox offerID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now - docOffer <- lift $ insertOfferToOutbox senderHash blinded offerID + luOffer <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) offerID action -- Deliver the Offer activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpOffer <- do + deliverHttpOffer <- do hashRepo <- getEncodeKeyHashid let tipRepo tip = case tip of @@ -2454,11 +2303,10 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t , Just $ LocalStagePersonFollowers senderHash ] sieve = makeRecipientSet sieveActors sieveStages - moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) offerID $ - localRecipSieve sieve False localRecips - checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts offerID remoteRecips moreRemoteRecips + localRecipsFinal = localRecipSieve sieve False localRecips + deliverActivityDB + (LocalActorPerson senderHash) (personActor senderPerson) + localRecipsFinal remoteRecips fwdHosts offerID action -- If Offer target is a local deck/loom, verify that it has received -- the Offer, insert a new Ticket to DB, and publish Accept @@ -2502,38 +2350,35 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t LocalStageLoomFollowers $ hashLoom loomID , LocalStagePersonFollowers senderHash ] - docAccept <- - lift $ insertAcceptToOutbox senderHash tracker ticketRoute offerID acceptID acceptRecipActors acceptRecipStages + actionAccept <- prepareAccept ticketRoute luOffer acceptRecipActors acceptRecipStages + let trackerByKey = + case tracker of + Left (deckID, _) -> LocalActorDeck deckID + Right (loomID, _, _, _, _, _) -> LocalActorLoom loomID + _luAccept <- lift $ updateOutboxItem trackerByKey acceptID actionAccept -- Deliver the Accept activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpAccept <- do + deliverHttpAccept <- do let trackerLocalActor = case tracker of Left (deckID, _) -> LocalActorDeck $ hashDeck deckID Right (loomID, _, _, _, _, _) -> LocalActorLoom $ hashLoom loomID - remoteRecips <- - lift $ deliverLocal' True trackerLocalActor trackerActorID acceptID $ + localRecipsAccept = makeRecipientSet acceptRecipActors acceptRecipStages - checkFederation remoteRecips - lift $ deliverRemoteDB'' [] acceptID [] remoteRecips + deliverActivityDB + trackerLocalActor trackerActorID localRecipsAccept [] [] + acceptID actionAccept -- Return instructions for HTTP delivery to remote recipients, and -- info for pulling origin branch to generate patches - return - ( deliverRemoteHttp' [] acceptID docAccept remoteRecipsHttpAccept - , maybePull - ) + return (deliverHttpAccept, maybePull) -- Return instructions for HTTP delivery to remote recipients, and info -- for pulling origin branch to generate patches - return - ( offerID - , deliverRemoteHttp' fwdHosts offerID docOffer remoteRecipsHttpOffer - , maybeAcceptMaybePull - ) + return (offerID, deliverHttpOffer, maybeAcceptMaybePull) -- Launch asynchronous HTTP delivery of Offer and Accept, and generate -- patches if we opened a local MR that mentions just an origin @@ -2546,25 +2391,6 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t where - insertOfferToOutbox senderHash blinded offerID = do - encodeRouteLocal <- getEncodeRouteLocal - hLocal <- asksSite siteInstanceHost - offerHash <- encodeKeyHashid offerID - let doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - PersonOutboxItemR senderHash offerHash - , activityActor = encodeRouteLocal $ PersonR senderHash - , activityCapability = Nothing - , activitySummary = summary - , activityAudience = blinded - , activityFulfills = [] - , activitySpecific = - OfferActivity $ Offer (OfferTicket ticket) uTarget - } - update offerID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return doc - insertTicket now title desc source offerID acceptID = do did <- insert Discussion fsid <- insert FollowerSet @@ -2618,42 +2444,24 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t route <- ClothR <$> encodeKeyHashid loomID <*> encodeKeyHashid clothID return (clothID, route) - insertAcceptToOutbox personHash tracker ticketRoute offerID acceptID actors stages = do + prepareAccept ticketRoute luOffer actors stages = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - tracker' <- - bitraverse - (\ (deckID, _) -> encodeKeyHashid deckID) - (\ (loomID, _, _, _, _, _) -> encodeKeyHashid loomID) - tracker hLocal <- asksSite siteInstanceHost - offerHash <- encodeKeyHashid offerID - acceptHash <- encodeKeyHashid acceptID let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalStage stages - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - case tracker' of - Left deckHash -> DeckOutboxItemR deckHash acceptHash - Right loomHash -> LoomOutboxItemR loomHash acceptHash - , activityActor = - encodeRouteLocal $ either DeckR LoomR tracker' - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activityFulfills = [] - , activitySpecific = AcceptActivity Accept - { acceptObject = - encodeRouteHome $ - PersonOutboxItemR personHash offerHash - , acceptResult = Just $ encodeRouteLocal ticketRoute - } + return Action + { actionCapability = Nothing + , actionSummary = Nothing + , actionAudience = Audience recips [] [] [] [] [] + , actionFulfills = [] + , actionSpecific = AcceptActivity Accept + { acceptObject = ObjURI hLocal luOffer + , acceptResult = Just $ encodeRouteLocal ticketRoute } - update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return doc + } {- verifyHosterRecip _ _ (Right _) = return () @@ -2765,7 +2573,7 @@ offerDepC (Entity pidUser personUser) summary audience dep uTarget = do (localRecipSieve sieve False localRecips) unless (federation || null moreRemoteRecips) $ throwE "Federation disabled, but recipient collection remote members found" - lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips + lift $ deliverRemoteDB fwdHosts obiid remoteRecips moreRemoteRecips maccept <- case (widIdent parentDetail, widIdent childDetail) of (Right _, Left (wi, ltid)) -> do @@ -2825,7 +2633,7 @@ offerDepC (Entity pidUser personUser) summary audience dep uTarget = do ibidHoster obiidAccept localRecipsAccept - lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (obiid, doc, remotesHttpOffer, maccept) lift $ do forkWorker "offerDepC: async HTTP Offer delivery" $ deliverRemoteHttp' fwdHosts obiidOffer docOffer remotesHttpOffer @@ -3023,7 +2831,7 @@ resolveC (Entity pidUser personUser) summary audience (Resolve uObject) = do (localRecipSieve sieve False localRecips) unless (federation || null moreRemoteRecips) $ throwE "Federation disabled, but recipient collection remote members found" - lift $ deliverRemoteDB'' fwdHosts obiidResolve remoteRecips moreRemoteRecips + lift $ deliverRemoteDB fwdHosts obiidResolve remoteRecips moreRemoteRecips maccept <- case widIdent ticketDetail of Right _ -> return Nothing @@ -3058,7 +2866,7 @@ resolveC (Entity pidUser personUser) summary audience (Resolve uObject) = do obiidAccept localRecipsAccept lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (obiidResolve, docResolve, remotesHttpResolve, maccept) lift $ do forkWorker "resolveC: async HTTP Resolve delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp @@ -3151,7 +2959,7 @@ undoC (Entity _pidUser personUser) summary audience undo@(Undo uObject) = do (localRecipSieve sieve True localRecips) unless (federation || null moreRemoteRecips) $ throwE "Federation disabled, but recipient collection remote members found" - lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips + lift $ deliverRemoteDB fwdHosts obiid remoteRecips moreRemoteRecips maccept <- for mticketDetail $ \ (wi, ticketDetail) -> do mhoster <- lift $ runMaybeT $ @@ -3182,7 +2990,7 @@ undoC (Entity _pidUser personUser) summary audience undo@(Undo uObject) = do obiidAccept localRecipsAccept lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (remotesHttpUndo, maccept) lift $ do forkWorker "undoC: async HTTP Undo delivery" $ diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 7c9cba4..0c66623 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -83,7 +83,9 @@ import Dvara import Yesod.Mail.Send (runMailer) import Control.Concurrent.ResultShare +import Crypto.ActorKey import Data.KeyFile +import Development.PatchMediaType import Network.FedURI import Yesod.Hashids import Yesod.MonadSite @@ -92,9 +94,8 @@ import Control.Concurrent.Local import Data.List.NonEmpty.Local import Web.Hashids.Local -import Vervis.ActorKey (generateActorKey, actorKeyRotator) import Vervis.Darcs -import Vervis.Delivery +import Vervis.Web.Delivery import Vervis.Foundation import Vervis.Git import Vervis.Hook @@ -122,8 +123,8 @@ import Vervis.Handler.Ticket import Vervis.Migration (migrateDB) import Vervis.Model import Vervis.Model.Ident -import Development.PatchMediaType import Vervis.Path +import Vervis.Persist.Actor import Vervis.Settings import Vervis.Ssh (runSsh) @@ -160,8 +161,14 @@ makeFoundation appSettings = do else loadFont "data/LinLibertineCut.svg" appActorKeys <- - newTVarIO =<< - (,,) <$> generateActorKey <*> generateActorKey <*> pure True + if appPerActorKeys appSettings + then pure Nothing + else Just <$> do + keys <- (,,) + <$> generateActorKey + <*> generateActorKey + <*> pure True + newTVarIO keys appInstanceMutex <- newInstanceMutex @@ -346,9 +353,9 @@ getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv develMain :: IO () develMain = develMainHelper getApplicationDev -actorKeyPeriodicRotator :: App -> IO () +actorKeyPeriodicRotator :: App -> Maybe (IO ()) actorKeyPeriodicRotator app = - actorKeyRotator (appActorKeyRotation $ appSettings app) (appActorKeys app) + actorKeyRotator (appActorKeyRotation $ appSettings app) <$> appActorKeys app deliveryRunner :: App -> IO () deliveryRunner app = @@ -399,7 +406,11 @@ appMain = do app <- makeApplication foundation -- Run actor signature key periodic generation thread - forkCheck $ actorKeyPeriodicRotator foundation + traverse_ forkCheck $ actorKeyPeriodicRotator foundation + + -- If we're using per-actor keys, generate keys for local actors that don't + -- have a key and insert to DB + runWorker fillPerActorKeys foundation -- Run periodic activity delivery retry runner when (appFederation $ appSettings foundation) $ diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 6acfe57..2b30089 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -14,7 +14,9 @@ -} module Vervis.Client - ( --createThread + ( makeServerInput + + --, createThread --, createReply --, follow --, followSharer @@ -28,7 +30,7 @@ module Vervis.Client --, undoFollowTicket --, undoFollowRepo --, unresolve - offerPatches + , offerPatches , offerMerge , applyPatches , createDeck @@ -85,6 +87,31 @@ import Vervis.RemoteActorStore import Vervis.Ticket import Vervis.WorkItem +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) + {- createThread :: (MonadSite m, SiteEnv m ~ App) @@ -547,7 +574,7 @@ offerPatches -> Maybe Text -> PatchMediaType -> NonEmpty Text - -> ExceptT Text Handler (Maybe HTML, AP.Audience URIMode, AP.Ticket URIMode) + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode) offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do tracker <- do @@ -567,7 +594,6 @@ offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = descHtml <- ExceptT . pure $ renderPandocMarkdown desc encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost let audAuthor = @@ -583,10 +609,7 @@ offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = [luTracker] (maybeToList $ remoteActorFollowers remoteActor) - - (_, _, _, audLocal, audRemote) = - collectAudience [audAuthor, audTracker] - recips = map encodeRouteHome audLocal ++ audRemote + audience = [audAuthor, audTracker] luSender = encodeRouteLocal $ PersonR senderHash ObjURI hTargetRepo luTargetRepo = uTargetRepo @@ -630,7 +653,7 @@ offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = ) } - return (Nothing, AP.Audience recips [] [] [] [] [], ticket) + return (Nothing, audience, ticket) offerMerge :: KeyHashid Person @@ -641,7 +664,7 @@ offerMerge -> Maybe Text -> FedURI -> Maybe Text - -> ExceptT Text Handler (Maybe HTML, AP.Audience URIMode, AP.Ticket URIMode) + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode) offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do tracker <- do @@ -661,7 +684,6 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR descHtml <- ExceptT . pure $ renderPandocMarkdown desc encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost let audAuthor = @@ -677,10 +699,7 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR [luTracker] (maybeToList $ remoteActorFollowers remoteActor) - - (_, _, _, audLocal, audRemote) = - collectAudience [audAuthor, audTracker] - recips = map encodeRouteHome audLocal ++ audRemote + audience = [audAuthor, audTracker] ObjURI hTargetRepo luTargetRepo = uTargetRepo ObjURI hOriginRepo luOriginRepo = uOriginRepo @@ -722,12 +741,12 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR ) } - return (Nothing, AP.Audience recips [] [] [] [] [], ticket) + return (Nothing, audience, ticket) applyPatches :: KeyHashid Person -> FedURI - -> ExceptT Text Handler (Maybe HTML, Audience URIMode, Apply URIMode) + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode) applyPatches senderHash uObject = do bundle <- parseProposalBundle "Apply object" uObject @@ -818,27 +837,21 @@ applyPatches senderHash uObject = do [luTracker] (catMaybes [mluFollowers, Just luTicketFollowers]) - (_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audCloth] + audience = [audAuthor, audCloth] - recips = map encodeRouteHome audLocal ++ audRemote - - return (Nothing, Audience recips [] [] [] [] [], Apply uObject target) + return (Nothing, audience, Apply uObject target) createDeck :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => KeyHashid Person -> Text -> Text - -> m (Maybe HTML, Audience URIMode, AP.ActorDetail) + -> m (Maybe HTML, [Aud URIMode], AP.ActorDetail) createDeck senderHash name desc = do - encodeRouteHome <- getEncodeRouteHome - let audAuthor = AudLocal [] [LocalStagePersonFollowers senderHash] - (_, _, _, audLocal, audRemote) = collectAudience [audAuthor] - - recips = map encodeRouteHome audLocal ++ audRemote + audience = [audAuthor] detail = AP.ActorDetail { AP.actorType = AP.ActorTypeTicketTracker @@ -847,7 +860,7 @@ createDeck senderHash name desc = do , AP.actorSummary = Just desc } - return (Nothing, AP.Audience recips [] [] [] [] [], detail) + return (Nothing, audience, detail) createLoom :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -855,7 +868,7 @@ createLoom -> Text -> Text -> KeyHashid Repo - -> m (Maybe HTML, Audience URIMode, AP.ActorDetail, NonEmpty FedURI) + -> m (Maybe HTML, [Aud URIMode], AP.ActorDetail, NonEmpty FedURI) createLoom senderHash name desc repoHash = do encodeRouteHome <- getEncodeRouteHome @@ -866,9 +879,7 @@ createLoom senderHash name desc repoHash = do [LocalActorRepo repoHash] [LocalStageRepoFollowers repoHash] - (_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audRepo] - - recips = map encodeRouteHome audLocal ++ audRemote + audience = [audAuthor, audRepo] detail = AP.ActorDetail { AP.actorType = AP.ActorTypePatchTracker @@ -878,23 +889,19 @@ createLoom senderHash name desc repoHash = do } repo = encodeRouteHome $ RepoR repoHash - return (Nothing, AP.Audience recips [] [] [] [] [], detail, repo :| []) + return (Nothing, audience, detail, repo :| []) createRepo :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => KeyHashid Person -> Text -> Text - -> m (Maybe HTML, Audience URIMode, AP.ActorDetail) + -> m (Maybe HTML, [Aud URIMode], AP.ActorDetail) createRepo senderHash name desc = do - encodeRouteHome <- getEncodeRouteHome - let audAuthor = AudLocal [] [LocalStagePersonFollowers senderHash] - (_, _, _, audLocal, audRemote) = collectAudience [audAuthor] - - recips = map encodeRouteHome audLocal ++ audRemote + audience = [audAuthor] detail = AP.ActorDetail { AP.actorType = AP.ActorTypeRepo @@ -903,4 +910,4 @@ createRepo senderHash name desc = do , AP.actorSummary = Just desc } - return (Nothing, AP.Audience recips [] [] [] [] [], detail) + return (Nothing, audience, detail) diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index d8039e7..826cd54 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -17,6 +17,8 @@ module Vervis.Data.Actor ( parseLocalActivityURI , parseActivityURI , activityRoute + , stampRoute + , parseStampRoute ) where @@ -80,3 +82,17 @@ activityRoute (LocalActorGroup g) = GroupOutboxItemR g activityRoute (LocalActorRepo r) = RepoOutboxItemR r activityRoute (LocalActorDeck d) = DeckOutboxItemR d activityRoute (LocalActorLoom l) = LoomOutboxItemR l + +stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App +stampRoute (LocalActorPerson p) = PersonStampR p +stampRoute (LocalActorGroup g) = GroupStampR g +stampRoute (LocalActorRepo r) = RepoStampR r +stampRoute (LocalActorDeck d) = DeckStampR d +stampRoute (LocalActorLoom l) = LoomStampR l + +parseStampRoute (PersonStampR p i) = Just (LocalActorPerson p, i) +parseStampRoute (GroupStampR g i) = Just (LocalActorGroup g, i) +parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i) +parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i) +parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i) +parseStampRoute _ = Nothing diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 2fb5f88..18a0f83 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -94,7 +94,7 @@ import Yesod.Persist.Local import Vervis.ActivityPub import Vervis.ActorKey -import Vervis.Delivery +import Vervis.Web.Delivery import Vervis.Federation.Auth import Vervis.Foundation import Vervis.Model diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index 0bea7c7..e59c7dc 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/src/Vervis/Federation/Auth.hs @@ -72,6 +72,7 @@ import Data.Time.Interval import Network.HTTP.Signature hiding (requestHeaders) import Yesod.HttpSignature +import Crypto.ActorKey import Crypto.PublicVerifKey import Database.Persist.JSON import Network.FedURI @@ -94,7 +95,7 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub -import Vervis.ActorKey +import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -261,21 +262,14 @@ verifyActorSig (Verification malgo keyid input signature) = do Right lu _ -> throwE "Multiple ActivityPub-Actor headers" -verifySelfSig - :: LocalURI +verifySelfSigIK + :: TVar (ActorKey, ActorKey, Bool) + -> LocalActorBy Key -> LocalRefURI -> ByteString -> Signature - -> ExceptT String Handler (LocalActorBy Key) -verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do - author <- do - route <- - fromMaybeE - (decodeRouteLocal luAuthor) - "Local author ID isn't a valid route" - fromMaybeE - (parseLocalActor route) - "Local author ID isn't an actor route" + -> ExceptT String Handler () +verifySelfSigIK instanceKeys authorByKey (LocalRefURI lruKey) input sig = do akey <- do route <- do luKey <- @@ -285,34 +279,82 @@ verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do fromMaybeE (decodeRouteLocal luKey) "Local key ID isn't a valid route" - (akey1, akey2, _) <- liftIO . readTVarIO =<< getsYesod appActorKeys + (akey1, akey2, _) <- liftIO $ readTVarIO instanceKeys case route of ActorKey1R -> return akey1 ActorKey2R -> return akey2 - _ -> throwE "Local key ID isn't an actor key route" - valid <- - ExceptT . pure $ verifySignature (actorKeyPublicBin akey) input sig + _ -> throwE "Local key ID isn't an instance key route" + valid <- ExceptT . pure $ actorKeyVerify akey input sig unless valid $ throwE "Self sig verification says not valid" - localAuth <- unhashLocalActorE author "No such actor" - withExceptT T.unpack $ runDBExcept $ findLocalAuthInDB localAuth - return localAuth + withExceptT T.unpack $ runDBExcept $ findLocalAuthInDB authorByKey where - findLocalAuthInDB (LocalActorPerson pid) = do - mp <- lift $ get pid - when (isNothing mp) $ throwE "No such person" - findLocalAuthInDB (LocalActorGroup gid) = do - mg <- lift $ get gid - when (isNothing mg) $ throwE "No such group" - findLocalAuthInDB (LocalActorRepo rid) = do - mr <- lift $ get rid - when (isNothing mr) $ throwE "No such repo" - findLocalAuthInDB (LocalActorDeck did) = do - md <- lift $ get did - when (isNothing md) $ throwE "No such deck" - findLocalAuthInDB (LocalActorLoom lid) = do - ml <- lift $ get lid - when (isNothing ml) $ throwE "No such loom" + findLocalAuthInDB actor = do + ma <- lift $ getLocalActorID actor + when (isNothing ma) $ throwE "No such actor in DB" + +verifySelfSigAK + :: LocalActorBy Key + -> LocalRefURI + -> ByteString + -> Signature + -> ExceptT String Handler () +verifySelfSigAK authorByKey (LocalRefURI lruKey) input sig = do + keyID <- do + luKey <- + case lruKey of + Left l -> return l + Right _ -> throwE "Local key ID has a fragment" + route <- + fromMaybeE + (decodeRouteLocal luKey) + "Local key ID isn't a valid route" + (holderByHash, keyHash) <- + fromMaybeE + (parseStampRoute route) + "Local key ID isn't an actor key route" + holderByKey <- + unhashLocalActorE + holderByHash + "Local key ID invalid holder keyhashid" + keyID <- + decodeKeyHashidE keyHash "Local key ID invalid sigkey keyhashid" + unless (holderByKey == authorByKey) $ + throwE "Key belongs to someone else" + return keyID + akey <- withExceptT T.unpack $ runDBExcept $ do + actorID <- do + ma <- lift $ getLocalActorID authorByKey + fromMaybeE ma "No such actor in DB" + SigKey holderID akey <- getE keyID "No such key in DB" + unless (actorID == holderID) $ throwE "Key belongs to someone else" + return akey + valid <- ExceptT . pure $ actorKeyVerify akey input sig + unless valid $ + throwE "Self sig verification says not valid" + +verifySelfSig + :: LocalURI + -> LocalRefURI + -> ByteString + -> Signature + -> ExceptT String Handler (LocalActorBy Key) +verifySelfSig luAuthor lruKey input sig = do + authorByKey <- do + route <- + fromMaybeE + (decodeRouteLocal luAuthor) + "Local author ID isn't a valid route" + authorByHash <- + fromMaybeE + (parseLocalActor route) + "Local author ID isn't an actor route" + unhashLocalActorE authorByHash "No such actor" + maybeKeys <- asksSite appActorKeys + case maybeKeys of + Nothing -> verifySelfSigAK authorByKey lruKey input sig + Just keys -> verifySelfSigIK keys authorByKey lruKey input sig + return authorByKey verifyForwardedSig :: Host diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index bb3d036..f6913fd 100644 --- a/src/Vervis/Federation/Collab.hs +++ b/src/Vervis/Federation/Collab.hs @@ -73,7 +73,7 @@ import Vervis.Access import Vervis.ActivityPub import Vervis.Data.Actor import Vervis.Data.Collab -import Vervis.Delivery +import Vervis.Web.Delivery import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Federation.Util @@ -163,22 +163,18 @@ personInviteF now recipHash author body mfwd luInvite invite = (,Nothing) <$> do if inviteeIsRecip then makeRecipientSet [] [LocalStagePersonFollowers recipHash] else makeRecipientSet [] [] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False inviteID $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB_P (actbBL body) inviteID personRecipID sig remoteRecips + forwardActivityDB + (actbBL body) localRecips sig (personActor personRecip) + (LocalActorPerson recipHash) sieve inviteID -- Launch asynchronous HTTP forwarding of the Invite activity case mhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" - Just mremotesHttpFwd -> do - for_ mremotesHttpFwd $ \ (sig, remotes) -> - forkWorker "personInviteF inbox-forwarding" $ - deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes + Just maybeForwardHttpInvite -> do + for_ maybeForwardHttpInvite $ + forkWorker "personInviteF inbox-forwarding" return $ - case mremotesHttpFwd of + case maybeForwardHttpInvite of Nothing -> "Inserted to inbox, no inbox-forwarding to do" Just _ -> "Inserted to inbox and ran inbox-forwarding of the Invite" @@ -282,26 +278,13 @@ topicInviteF now recipByHash author body mfwd luInvite invite = do -- and schedule delivery for unavailable remote members of -- them for mfwd $ \ (localRecips, sig) -> do - let sieve = - makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor recipByHash] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False inviteID $ - localRecipSieve' - sieve False False localRecips - case recipByKey of - GrantResourceRepo repoID -> do - repoHash <- encodeKeyHashid repoID - fwds <- deliverRemoteDB_R (actbBL body) inviteID repoID sig remoteRecips - return $ deliverRemoteHTTP_R now repoHash (actbBL body) sig fwds - GrantResourceDeck deckID -> do - deckHash <- encodeKeyHashid deckID - fwds <- deliverRemoteDB_D (actbBL body) inviteID deckID sig remoteRecips - return $ deliverRemoteHTTP_D now deckHash (actbBL body) sig fwds - GrantResourceLoom loomID -> do - loomHash <- encodeKeyHashid loomID - fwds <- deliverRemoteDB_L (actbBL body) inviteID loomID sig remoteRecips - return $ deliverRemoteHTTP_L now loomHash (actbBL body) sig fwds + let recipLocalActor = + grantResourceLocalActor recipByHash + sieve = + makeRecipientSet [] [localActorFollowers recipLocalActor] + forwardActivityDB + (actbBL body) localRecips sig recipActorID + recipLocalActor sieve inviteID -- Launch asynchronous HTTP forwarding of the Invite activity case mhttp of @@ -335,21 +318,6 @@ topicAcceptF :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ActorId) -> (forall f. f topic -> GrantResourceBy f) - -> ( BL.ByteString - -> RemoteActivityId - -> Key topic - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend Handler - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] - ) - -> ( UTCTime - -> KeyHashid topic - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] - -> Worker () - ) -> UTCTime -> KeyHashid topic -> RemoteAuthor @@ -358,7 +326,7 @@ topicAcceptF -> LocalURI -> AP.Accept URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now recipHash author body mfwd luAccept accept = (,Nothing) <$> do +topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept accept = (,Nothing) <$> do -- Check input acceptee <- parseAccept accept @@ -428,74 +396,54 @@ topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now reci -- Forward the Accept activity to relevant local stages, and -- schedule delivery for unavailable remote members of them - maybeRemotesHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do + let recipByHash = grantResourceLocalActor $ topicResource recipHash + maybeHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do let sieve = - makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor $ topicResource recipHash] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False acceptID $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB (actbBL body) acceptID recipKey sig remoteRecips + makeRecipientSet [] [localActorFollowers recipByHash] + forwardActivityDB + (actbBL body) localRecips sig recipActorID recipByHash + sieve acceptID - remotesHttpGrant <- lift $ do + deliverHttpGrant <- do -- Enable the Collab in our DB - grantID <- insertEmptyOutboxItem (actorOutbox recipActor) now - insert_ $ CollabEnable collabID grantID + grantID <- lift $ insertEmptyOutboxItem (actorOutbox recipActor) now + lift $ insert_ $ CollabEnable collabID grantID -- Prepare a Grant activity and insert to topic's outbox - (docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- - insertGrantToOutbox inviteSender grantID + (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- + lift $ prepareGrant inviteSender + let recipByKey = grantResourceLocalActor $ topicResource recipKey + _luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant -- Deliver the Grant to local recipients, and schedule delivery -- for unavailable remote recipients - (grantID, docGrant, fwdHostsGrant,) <$> do - knownRemoteRecipsGrant <- - deliverLocal' - False - (grantResourceLocalActor $ topicResource recipHash) - recipActorID - grantID - localRecipsGrant - deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant knownRemoteRecipsGrant + deliverActivityDB + recipByHash recipActorID localRecipsGrant remoteRecipsGrant + fwdHostsGrant grantID actionGrant - return (maybeRemotesHttpFwdAccept, remotesHttpGrant) + return (maybeHttpFwdAccept, deliverHttpGrant) -- Launch asynchronous HTTP forwarding of the Accept activity case mhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" - Just (mremotesHttpFwd, (grantID, docGrant, fwdHostsGrant, recipsGrant)) -> do - forkWorker "topicAcceptF Grant HTTP delivery" $ - deliverRemoteHttp' fwdHostsGrant grantID docGrant recipsGrant - case mremotesHttpFwd of + Just (mhttpFwd, deliverHttpGrant) -> do + forkWorker "topicAcceptF Grant HTTP delivery" deliverHttpGrant + case mhttpFwd of Nothing -> return "Sent a Grant, no inbox-forwarding to do" - Just (sig, remotes) -> do - forkWorker "topicAcceptF inbox-forwarding" $ - deliverRemoteHTTP now recipHash (actbBL body) sig remotes + Just forwardHttpAccept -> do + forkWorker "topicAcceptF inbox-forwarding" forwardHttpAccept return "Sent a Grant and ran inbox-forwarding of the Accept" where - insertGrantToOutbox - :: Either (LocalActorBy Key) (FedURI, Maybe LocalURI) - -> OutboxItemId - -> ReaderT SqlBackend Handler - ( AP.Doc AP.Activity URIMode - , RecipientRoutes - , [(Host, NonEmpty LocalURI)] - , [Host] - ) - insertGrantToOutbox sender grantID = do - encodeRouteLocal <- getEncodeRouteLocal + prepareGrant sender = do encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost accepter <- getJust $ remoteAuthorId author let topicByHash = grantResourceLocalActor $ topicResource recipHash senderHash <- bitraverse hashLocalActor pure sender - grantHash <- encodeKeyHashid grantID let audSender = case senderHash of @@ -511,22 +459,19 @@ topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now reci collectAudience [audSender, audRecip, audTopic] recips = map encodeRouteHome audLocal ++ audRemote - doc = AP.Doc hLocal AP.Activity - { AP.activityId = Just $ encodeRouteLocal $ activityRoute topicByHash grantHash - , AP.activityActor = encodeRouteLocal $ renderLocalActor topicByHash - , AP.activityCapability = Nothing - , AP.activitySummary = Nothing - , AP.activityAudience = AP.Audience recips [] [] [] [] [] - , AP.activityFulfills = [AP.acceptObject accept] - , AP.activitySpecific = AP.GrantActivity AP.Grant - { AP.grantObject = Left AP.RoleAdmin - , AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash - , AP.grantTarget = remoteAuthorURI author + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [AP.acceptObject accept] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = Left AP.RoleAdmin + , AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash + , AP.grantTarget = remoteAuthorURI author } } - update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) + return (action, recipientSet, remoteActors, fwdHosts) repoAcceptF :: UTCTime @@ -537,8 +482,7 @@ repoAcceptF -> LocalURI -> AP.Accept URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -repoAcceptF = - topicAcceptF repoActor GrantResourceRepo deliverRemoteDB_R deliverRemoteHTTP_R +repoAcceptF = topicAcceptF repoActor GrantResourceRepo deckAcceptF :: UTCTime @@ -549,8 +493,7 @@ deckAcceptF -> LocalURI -> AP.Accept URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -deckAcceptF = - topicAcceptF deckActor GrantResourceDeck deliverRemoteDB_D deliverRemoteHTTP_D +deckAcceptF = topicAcceptF deckActor GrantResourceDeck loomAcceptF :: UTCTime @@ -561,8 +504,7 @@ loomAcceptF -> LocalURI -> AP.Accept URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -loomAcceptF = - topicAcceptF loomActor GrantResourceLoom deliverRemoteDB_L deliverRemoteHTTP_L +loomAcceptF = topicAcceptF loomActor GrantResourceLoom personGrantF :: UTCTime @@ -616,21 +558,16 @@ personGrantF now recipHash author body mfwd luGrant grant = (,Nothing) <$> do if targetIsRecip then makeRecipientSet [] [LocalStagePersonFollowers recipHash] else makeRecipientSet [] [] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False grantID $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB_P (actbBL body) grantID personRecipID sig remoteRecips + forwardActivityDB + (actbBL body) localRecips sig (personActor personRecip) + (LocalActorPerson recipHash) sieve grantID - -- Launch asynchronous HTTP forwarding of the Invite activity + -- Launch asynchronous HTTP forwarding of the Grant activity case mhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" - Just mremotesHttpFwd -> do - for_ mremotesHttpFwd $ \ (sig, remotes) -> - forkWorker "personGrantF inbox-forwarding" $ - deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes + Just mhttpFwd -> do + for_ mhttpFwd $ forkWorker "personGrantF inbox-forwarding" return $ - case mremotesHttpFwd of + case mhttpFwd of Nothing -> "Inserted to inbox, no inbox-forwarding to do" Just _ -> "Inserted to inbox and ran inbox-forwarding of the Grant" diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index fc28528..658e7cc 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -344,7 +344,7 @@ followF iidAuthor = remoteAuthorInstance author hAuthor = objUriAuthority $ remoteAuthorURI author hostSection = ((iidAuthor, hAuthor), raInfo :| []) - (obiid, doc,) <$> deliverRemoteDB'' [] obiid [] [hostSection] + (obiid, doc,) <$> deliverRemoteDB [] obiid [] [hostSection] else do delete obiid return $ Left "You're already a follower of me" @@ -698,7 +698,7 @@ sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do obiidAccept localRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (result, mremotesHttpFwd, mremotesHttpAccept) case mmmhttp of Nothing -> return "Activity already in my inbox" @@ -802,7 +802,7 @@ projectUndoF recipHash now author body mfwd luUndo (Undo uObj) = do obiidAccept localRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (result, mremotesHttpFwd, mremotesHttpAccept) case mmmhttp of Nothing -> return "Activity already in my inbox" @@ -900,7 +900,7 @@ repoUndoF recipHash now author body mfwd luUndo (Undo uObj) = do obiidAccept localRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (result, mremotesHttpFwd, mremotesHttpAccept) case mmmhttp of Nothing -> return "Activity already in my inbox" diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 42d6fda..26c4120 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -96,7 +96,7 @@ import Vervis.Cloth import Vervis.Data.Actor import Vervis.Data.Ticket import Vervis.Darcs -import Vervis.Delivery +import Vervis.Web.Delivery import Vervis.Federation.Auth import Vervis.Federation.Util import Vervis.FedURI @@ -107,6 +107,7 @@ import Vervis.Model import Vervis.Model.Role import Vervis.Model.Ticket import Vervis.Path +import Vervis.Persist.Actor import Vervis.Persist.Ticket import Vervis.Query import Vervis.Recipient @@ -358,60 +359,48 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = 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 + 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 <- insertToInbox now author body (actorInbox recipDeckActor) luOffer False + 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 <- for mfwd $ \ (localRecips, sig) -> do + maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do let sieve = makeRecipientSet [] [LocalStageDeckFollowers recipDeckHash] - remoteRecips <- - 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 + forwardActivityDB + (actbBL body) localRecips sig recipDeckActorID + (LocalActorDeck recipDeckHash) sieve offerID -- Insert the new ticket to our DB - acceptID <- insertEmptyOutboxItem (actorOutbox recipDeckActor) now - taskID <- insertTask now title desc source recipDeckID offerID acceptID + 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 - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - insertAcceptToOutbox taskID acceptID + (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 - knownRemoteRecipsAccept <- - deliverLocal' - False (LocalActorDeck recipDeckHash) recipDeckActorID - acceptID localRecipsAccept - remoteRecipsHttpAccept <- - deliverRemoteDB'' - fwdHostsAccept acceptID remoteRecipsAccept - knownRemoteRecipsAccept + 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 - , deliverRemoteHttp' - fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept - ) + return (maybeHttpFwdOffer, deliverHttpAccept) -- Launch asynchronous HTTP forwarding of the Offer activity and HTTP -- delivery of the Accept activity @@ -448,22 +437,11 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do } insert $ TicketDeck tid deckID - insertAcceptToOutbox - :: TicketDeckId - -> OutboxItemId - -> ReaderT SqlBackend Handler - ( AP.Doc AP.Activity URIMode - , RecipientRoutes - , [(Host, NonEmpty LocalURI)] - , [Host] - ) - insertAcceptToOutbox taskID acceptID = do + prepareAccept taskID = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost taskHash <- encodeKeyHashid taskID - acceptHash <- encodeKeyHashid acceptID ra <- getJust $ remoteAuthorId author @@ -479,26 +457,20 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do collectAudience [audSender, audTracker] recips = map encodeRouteHome audLocal ++ audRemote - doc = AP.Doc hLocal AP.Activity - { AP.activityId = - Just $ encodeRouteLocal $ - 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 = + 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 } } - update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) + return (action, recipientSet, remoteActors, fwdHosts) activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct @@ -684,33 +656,28 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do return $ Right uClone return $ Right $ maybeOriginRepo - maybeHttp <- lift $ runSiteDB $ do + maybeHttp <- runSiteDBExcept $ do -- Insert the Offer to loom's inbox - mractid <- insertToInbox now author body (actorInbox recipLoomActor) luOffer False + mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) 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 + maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do let sieve = makeRecipientSet [] [LocalStageLoomFollowers recipLoomHash] - remoteRecips <- - insertRemoteActivityToLocalInboxes False offerID $ - localRecipSieve' sieve False False localRecips - remoteRecipsHttp <- - deliverRemoteDB_L - (actbBL body) offerID recipLoomID sig remoteRecips - return $ - deliverRemoteHTTP_L - now recipLoomHash (actbBL body) sig remoteRecipsHttp + forwardActivityDB + (actbBL body) localRecips sig + recipLoomActorID (LocalActorLoom recipLoomHash) + sieve offerID -- Insert the new ticket to our DB - acceptID <- insertEmptyOutboxItem (actorOutbox recipLoomActor) now - ticketID <- insertTicket now title desc source offerID acceptID - clothID <- insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle' + acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now + ticketID <- lift $ insertTicket now title desc source offerID acceptID + clothID <- lift $ insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle' let maybePull = let maybeTipInfo = case tipInfo of @@ -720,30 +687,24 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo -- Prepare an Accept activity and insert to loom's outbox - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - insertAcceptToOutbox clothID acceptID + (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + lift $ prepareAccept clothID + _luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept -- Deliver the Accept to local recipients, and schedule delivery -- for unavailable remote recipients - knownRemoteRecipsAccept <- - deliverLocal' - False (LocalActorLoom recipLoomHash) recipLoomActorID - acceptID localRecipsAccept - remoteRecipsHttpAccept <- - deliverRemoteDB'' - fwdHostsAccept acceptID remoteRecipsAccept - knownRemoteRecipsAccept + deliverHttpAccept <- + deliverActivityDB + (LocalActorLoom recipLoomHash) recipLoomActorID + 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, and for generating patches from -- the origin repo return - ( maybeHttpFwdOffer - , deliverRemoteHttp' - fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept - , maybePull - ) + (maybeHttpFwdOffer, deliverHttpAccept, maybePull) -- Launch asynchronous HTTP forwarding of the Offer activity and HTTP -- delivery of the Accept activity, and generate patches if we opened @@ -811,22 +772,11 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do NE.map (Patch bundleID now typ) diffs return clothID - insertAcceptToOutbox - :: TicketLoomId - -> OutboxItemId - -> WorkerDB - ( AP.Doc AP.Activity URIMode - , RecipientRoutes - , [(Host, NonEmpty LocalURI)] - , [Host] - ) - insertAcceptToOutbox clothID acceptID = do + prepareAccept clothID = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost clothHash <- encodeKeyHashid clothID - acceptHash <- encodeKeyHashid acceptID ra <- getJust $ remoteAuthorId author @@ -842,26 +792,20 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do collectAudience [audSender, audTracker] recips = map encodeRouteHome audLocal ++ audRemote - doc = AP.Doc hLocal AP.Activity - { AP.activityId = - Just $ encodeRouteLocal $ - LoomOutboxItemR recipLoomHash acceptHash - , AP.activityActor = - encodeRouteLocal $ LoomR recipLoomHash - , AP.activityCapability = Nothing - , AP.activitySummary = Nothing - , AP.activityAudience = AP.Audience recips [] [] [] [] [] - , AP.activityFulfills = [] - , AP.activitySpecific = AP.AcceptActivity AP.Accept - { acceptObject = ObjURI hAuthor luOffer - , acceptResult = + 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 $ ClothR recipLoomHash clothHash } } - update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) + return (action, recipientSet, remoteActors, fwdHosts) repoOfferTicketF :: UTCTime @@ -918,7 +862,7 @@ repoOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do obiidAccept localRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept) case mmhttp of Nothing -> return "Offer target isn't me, not using" @@ -1085,7 +1029,7 @@ repoAddBundleF now recipHash author body mfwd luAdd patches uTarget = do obiidAccept localRecipsAccept (obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (mremotesHttpFwd, mremotesHttpAccept) case mhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" @@ -1242,15 +1186,15 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do -- Apply patches applyPatches repoID maybeBranch diffs - maybeHttp <- lift $ runDB $ do + maybeHttp <- runDBExcept $ do -- Insert the Apply to loom's inbox - mractid <- insertToInbox now author body (actorInbox recipLoomActor) luApply False + mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) luApply False for mractid $ \ applyID -> do -- Forward the Apply activity to relevant local stages, and -- schedule delivery for unavailable remote members of them - maybeHttpFwdApply <- for mfwd $ \ (localRecips, sig) -> do + maybeHttpFwdApply <- lift $ for mfwd $ \ (localRecips, sig) -> do clothHash <- encodeKeyHashid clothID let sieve = makeRecipientSet @@ -1258,44 +1202,32 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do [ LocalStageLoomFollowers recipLoomHash , LocalStageClothFollowers recipLoomHash clothHash ] - remoteRecips <- - insertRemoteActivityToLocalInboxes False applyID $ - localRecipSieve' sieve False False localRecips - remoteRecipsHttp <- - deliverRemoteDB_L - (actbBL body) applyID recipLoomID sig remoteRecips - return $ - deliverRemoteHTTP_L - now recipLoomHash (actbBL body) sig remoteRecipsHttp + forwardActivityDB + (actbBL body) localRecips sig recipLoomActorID + (LocalActorLoom recipLoomHash) sieve applyID -- Mark ticket in DB as resolved by the Apply acceptID <- - insertEmptyOutboxItem (actorOutbox recipLoomActor) now - insertResolve ticketID applyID acceptID + lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now + lift $ insertResolve ticketID applyID acceptID -- Prepare an Accept activity and insert to loom's outbox - (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - insertAcceptToOutbox uCap clothID acceptID + (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + lift $ prepareAccept clothID + _luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept -- Deliver the Accept to local recipients, and schedule delivery -- for unavailable remote recipients - knownRemoteRecipsAccept <- - deliverLocal' - False (LocalActorLoom recipLoomHash) recipLoomActorID - acceptID localRecipsAccept - remoteRecipsHttpAccept <- - deliverRemoteDB'' - fwdHostsAccept acceptID remoteRecipsAccept - knownRemoteRecipsAccept + deliverHttpAccept <- + deliverActivityDB + (LocalActorLoom recipLoomHash) recipLoomActorID + localRecipsAccept remoteRecipsAccept fwdHostsAccept + acceptID actionAccept -- Return instructions for HTTP inbox-forwarding of the Apply -- activity, and for HTTP delivery of the Accept activity to -- remote recipients - return - ( maybeHttpFwdApply - , deliverRemoteHttp' - fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept - ) + return (maybeHttpFwdApply, deliverHttpAccept) -- Launch asynchronous HTTP forwarding of the Apply activity and HTTP -- delivery of the Accept activity @@ -1326,13 +1258,10 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do } update ticketID [TicketStatus =. TSClosed] - insertAcceptToOutbox uCap clothID acceptID = do - encodeRouteLocal <- getEncodeRouteLocal + prepareAccept clothID = do encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost clothHash <- encodeKeyHashid clothID - acceptHash <- encodeKeyHashid acceptID ra <- getJust $ remoteAuthorId author @@ -1353,24 +1282,18 @@ loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do collectAudience [audSender, audTracker] recips = map encodeRouteHome audLocal ++ audRemote - doc = AP.Doc hLocal AP.Activity - { AP.activityId = - Just $ encodeRouteLocal $ - LoomOutboxItemR recipLoomHash acceptHash - , AP.activityActor = - encodeRouteLocal $ LoomR recipLoomHash - , AP.activityCapability = Just uCap - , AP.activitySummary = Nothing - , AP.activityAudience = AP.Audience recips [] [] [] [] [] - , AP.activityFulfills = [] - , AP.activitySpecific = AP.AcceptActivity AP.Accept - { acceptObject = ObjURI hAuthor luApply - , acceptResult = Nothing + 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 luApply + , AP.acceptResult = Nothing } } - update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) + return (action, recipientSet, remoteActors, fwdHosts) personOfferDepF :: UTCTime @@ -1430,7 +1353,7 @@ personOfferDepF now recipHash author body mfwd luOffer dep uTarget = do (personInbox personRecip) obiidAccept localRecipsAccept - (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (mremotesHttpFwd, mremotesHttpAccept) case mhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" @@ -1642,7 +1565,7 @@ deckOfferDepF now recipHash author body mfwd luOffer dep uTarget = do (actorInbox actorRecip) obiidAccept localRecipsAccept - (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (mremotesHttpFwd, mremotesHttpAccept) case mhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" @@ -1810,7 +1733,7 @@ repoOfferDepF now recipHash author body mfwd luOffer dep uTarget = do (repoInbox repoRecip) obiidAccept localRecipsAccept - (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept return (mremotesHttpFwd, mremotesHttpAccept) case mhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" @@ -2007,7 +1930,7 @@ deckResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do obiidAccept localRecipsAccept (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept case mmmmhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" Just mmmhttp -> @@ -2144,7 +2067,7 @@ repoResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do obiidAccept localRecipsAccept (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> - deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept case mmmmhttp of Nothing -> return "I already have this activity in my inbox, doing nothing" Just mmmhttp -> diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs index 1be62d6..8f69e8e 100644 --- a/src/Vervis/Fetch.hs +++ b/src/Vervis/Fetch.hs @@ -86,7 +86,7 @@ import Vervis.Cloth import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Data.Ticket -import Vervis.Delivery +import Vervis.Web.Delivery import Vervis.FedURI import Vervis.Foundation import Vervis.Model diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 7eaeca3..65746b6 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -69,6 +69,7 @@ import Yesod.Mail.Send import qualified Network.HTTP.Signature as S (Algorithm (..)) +import Crypto.ActorKey import Crypto.PublicVerifKey import Network.FedURI import Web.ActivityAccess @@ -83,7 +84,6 @@ import Text.Email.Local import Text.Jasmine.Local (discardm) import Yesod.Paginate.Local -import Vervis.ActorKey import Vervis.FedURI import Vervis.Hook import Vervis.Model @@ -114,7 +114,7 @@ data App = App , appLogger :: Logger , appMailQueue :: Maybe (Chan (MailRecipe App)) , appSvgFont :: PreparedFont Double - , appActorKeys :: TVar (ActorKey, ActorKey, Bool) + , appActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool)) , appInstanceMutex :: InstanceMutex , appCapSignKey :: AccessTokenSecretKey , appHashidsContext :: HashidsContext @@ -140,6 +140,7 @@ type DeckKeyHashid = KeyHashid Deck type LoomKeyHashid = KeyHashid Loom type TicketDeckKeyHashid = KeyHashid TicketDeck type TicketLoomKeyHashid = KeyHashid TicketLoom +type SigKeyKeyHashid = KeyHashid SigKey -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: @@ -783,6 +784,7 @@ instance YesodActivityPub App where siteInstanceHost = appInstanceHost . appSettings sitePostSignedHeaders _ = hRequestTarget :| [hHost, hDate, hDigest, AP.hActivityPubActor] + {- siteGetHttpSign = do (akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys renderUrl <- askUrlRender @@ -791,6 +793,7 @@ instance YesodActivityPub App where then (renderUrl ActorKey1R, akey1) else (renderUrl ActorKey2R, akey2) return (KeyId $ encodeUtf8 keyID, actorKeySign akey) + -} instance YesodPaginate App where sitePageParamName _ = "page" @@ -837,12 +840,16 @@ instance YesodBreadcrumbs App where ReplyR _ -> ("", Nothing) + PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p) + GroupR g -> ("Team &" <> keyHashidText g, Just HomeR) GroupInboxR g -> ("Inbox", Just $ GroupR g) GroupOutboxR g -> ("Outbox", Just $ GroupR g) GroupOutboxItemR g i -> (keyHashidText i, Just $ GroupOutboxR g) GroupFollowersR g -> ("Followers", Just $ GroupR g) + GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g) + RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR) RepoInboxR r -> ("Inbox", Just $ RepoR r) RepoOutboxR r -> ("Outbox", Just $ RepoR r) @@ -871,6 +878,8 @@ instance YesodBreadcrumbs App where RepoLinkR _ _ -> ("", Nothing) + RepoStampR r k -> ("Stamp #" <> keyHashidText k, Just $ RepoR r) + DeckR d -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR) DeckInboxR d -> ("Inbox", Just $ DeckR d) DeckOutboxR d -> ("Outbox", Just $ DeckR d) @@ -886,6 +895,8 @@ instance YesodBreadcrumbs App where DeckFollowR _ -> ("", Nothing) DeckUnfollowR _ -> ("", Nothing) + DeckStampR d k -> ("Stamp #" <> keyHashidText k, Just $ DeckR d) + TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d) TicketDiscussionR d t -> ("Discussion", Just $ TicketR d t) TicketEventsR d t -> ("Events", Just $ TicketR d t) @@ -910,6 +921,8 @@ instance YesodBreadcrumbs App where LoomFollowR _ -> ("", Nothing) LoomUnfollowR _ -> ("", Nothing) + LoomStampR l k -> ("Stamp #" <> keyHashidText k, Just $ LoomR l) + ClothR l c -> ("#" <> keyHashidText c, Just $ LoomClothsR l) ClothDiscussionR l c -> ("Discussion", Just $ ClothR l c) ClothEventsR l c -> ("Events", Just $ ClothR l c) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index a375083..0306a44 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -37,43 +37,32 @@ where import Control.Applicative import Control.Concurrent.STM.TVar -import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.Trans.Except -import Data.Bitraversable import Data.List -import Data.Maybe import Data.Text (Text) import Data.Time.Clock import Data.Traversable import Database.Persist import Text.Blaze.Html (preEscapedToHtml) -import Text.Blaze.Html.Renderer.Text -import Text.HTML.SanitizeXSS import Yesod.Auth import Yesod.Auth.Account import Yesod.Auth.Account.Message import Yesod.Core -import Yesod.Core.Widget import Yesod.Form import Yesod.Persist.Core import qualified Data.ByteString.Char8 as BC import qualified Data.HashMap.Strict as M import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import qualified Database.Esqueleto as E -import Dvara - import Database.Persist.JSON import Network.FedURI import Web.Text import Yesod.ActivityPub import Yesod.Auth.Unverified -import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite import Yesod.RenderSource @@ -83,26 +72,19 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Data.Either.Local import Data.EventTime.Local -import Data.Time.Clock.Local import Database.Persist.Local import Yesod.Form.Local -import Yesod.Persist.Local -import Vervis.ActivityPub -import Vervis.ActorKey import Vervis.API import Vervis.Client +import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident -import Development.PatchMediaType -import Vervis.Path +import Vervis.Recipient import Vervis.Settings -import Vervis.Ticket - -import qualified Vervis.Darcs as D -import qualified Vervis.Git as G +import Vervis.Web.Actor -- | Account verification email resend form getResendVerifyEmailR :: Handler Html @@ -115,28 +97,11 @@ getResendVerifyEmailR = do ^{resendVerifyEmailWidget (username person) AuthR} |] -getActorKey - :: ((ActorKey, ActorKey, Bool) -> ActorKey) - -> Route App - -> Handler TypedContent -getActorKey choose route = do - actorKey <- - liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<< - getsYesod appActorKeys - encodeRouteLocal <- getEncodeRouteLocal - let key = AP.PublicKey - { AP.publicKeyId = LocalRefURI $ Left $ encodeRouteLocal route - , AP.publicKeyExpires = Nothing - , AP.publicKeyOwner = AP.OwnerInstance - , AP.publicKeyMaterial = actorKey - } - provideHtmlAndAP key $ redirectToPrettyJSON route - getActorKey1R :: Handler TypedContent -getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R +getActorKey1R = serveInstanceKey fst ActorKey1R getActorKey2R :: Handler TypedContent -getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R +getActorKey2R = serveInstanceKey snd ActorKey2R getHomeR :: Handler Html getHomeR = do @@ -1063,6 +1028,18 @@ fedUriField = Field , fieldEnctype = UrlEncoded } +capField + :: Field Handler + ( FedURI + , Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) +capField = checkMMap toCap fst fedUriField + where + toCap u = + runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u) + getSender :: Handler (Entity Person, Actor) getSender = do ep@(Entity _ p) <- requireAuth @@ -1153,7 +1130,9 @@ postPublishOfferMergeR = do senderHash omgTitle omgDesc omgTracker omgTargetRepo (Just omgTargetBranch) omgOriginRepo (Just omgOriginBranch) - offerID <- offerTicketC ep a summary audience ticket omgTracker + (localRecips, remoteRecips, fwdHosts, action) <- + makeServerInput Nothing summary audience $ AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) omgTracker + offerID <- offerTicketC ep a Nothing localRecips remoteRecips fwdHosts action ticket omgTracker if trackerLocal then nameExceptT "Offer published but" $ runDBExcept $ do ticketID <- do @@ -1175,10 +1154,9 @@ postPublishOfferMergeR = do else setMessage "Offer published" redirect dest -mergeForm :: Form (FedURI, FedURI) mergeForm = renderDivs $ (,) <$> areq fedUriField "Patch bundle to apply" Nothing - <*> areq fedUriField "Grant activity to use for authorization" Nothing + <*> areq capField "Grant activity to use for authorization" Nothing getPublishMergeR :: Handler Html getPublishMergeR = do @@ -1196,14 +1174,16 @@ postPublishMergeR = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod - (uBundle, uCap) <- runFormPostRedirect PublishMergeR mergeForm + (uBundle, (uCap, cap)) <- runFormPostRedirect PublishMergeR mergeForm (ep@(Entity pid _), a) <- getSender senderHash <- encodeKeyHashid pid result <- runExceptT $ do (maybeSummary, audience, apply) <- applyPatches senderHash uBundle - applyC ep a (Just uCap) maybeSummary audience apply + (localRecips, remoteRecips, fwdHosts, action) <- + makeServerInput (Just uCap) maybeSummary audience (AP.ApplyActivity apply) + applyC ep a (Just cap) localRecips remoteRecips fwdHosts action apply case result of Left err -> do diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index 4bede0f..bfe99cf 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -622,7 +622,7 @@ postClothApplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler () postClothApplyR loomHash clothHash = do ep@(Entity personID person) <- requireAuth - (grantIDs, proposal, actor) <- runDB $ do + (grantIDs, proposal, actor, loomID) <- runDB $ do (Entity loomID _, _, _, _, _, proposal) <- getCloth404 loomHash clothHash grantIDs <- @@ -636,7 +636,7 @@ postClothApplyR loomHash clothHash = do actor <- getJust $ personActor person - return (map E.unValue grantIDs, proposal, actor) + return (map E.unValue grantIDs, proposal, actor, loomID) result <- runExceptT $ do @@ -652,10 +652,13 @@ postClothApplyR loomHash clothHash = do personHash <- encodeKeyHashid personID (maybeSummary, audience, apply) <- C.applyPatches personHash $ encodeRouteHome bundleRoute + let cap = (LocalActorLoom loomID, LocalActorLoom loomHash, grantID) uCap <- encodeRouteHome . LoomOutboxItemR loomHash <$> encodeKeyHashid grantID - applyC ep actor (Just uCap) maybeSummary audience apply + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience (AP.ApplyActivity apply) + applyC ep actor (Just $ Left cap) localRecips remoteRecips fwdHosts action apply case result of Left e -> setMessage $ toHtml e diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 588bc73..5726f62 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -32,6 +32,7 @@ module Vervis.Handler.Deck , postDeckFollowR , postDeckUnfollowR + , getDeckStampR @@ -318,9 +319,11 @@ postDeckNewR = do personEntity@(Entity personID person) <- requireAuth personHash <- encodeKeyHashid personID (maybeSummary, audience, detail) <- C.createDeck personHash name desc + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) Nothing actor <- runDB $ getJust $ personActor person result <- - runExceptT $ createTicketTrackerC personEntity actor maybeSummary audience detail Nothing Nothing + runExceptT $ createTicketTrackerC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail Nothing Nothing case result of Left e -> do @@ -378,6 +381,8 @@ postDeckFollowR _ = error "Temporarily disabled" postDeckUnfollowR :: KeyHashid Deck -> Handler () postDeckUnfollowR _ = error "Temporarily disabled" +getDeckStampR :: KeyHashid Deck -> KeyHashid SigKey -> Handler TypedContent +getDeckStampR = servePerActorKey deckActor LocalActorDeck diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 00bbd2e..70cd969 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -21,6 +21,7 @@ module Vervis.Handler.Group , getGroupOutboxItemR , getGroupFollowersR + , getGroupStampR @@ -129,6 +130,9 @@ getGroupOutboxItemR = getOutboxItem GroupOutboxItemR groupActor getGroupFollowersR :: KeyHashid Group -> Handler TypedContent getGroupFollowersR = getActorFollowersCollection GroupFollowersR groupActor +getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent +getGroupStampR = servePerActorKey groupActor LocalActorGroup + diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 30dec83..d9f3f59 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -26,6 +26,8 @@ module Vervis.Handler.Loom , postLoomNewR , postLoomFollowR , postLoomUnfollowR + + , getLoomStampR ) where @@ -285,8 +287,10 @@ postLoomNewR = do getJust $ personActor person - result <- - runExceptT $ createPatchTrackerC personEntity actor maybeSummary audience detail repos Nothing Nothing + result <- do + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreatePatchTracker detail repos Nothing) Nothing + runExceptT $ createPatchTrackerC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail repos Nothing Nothing case result of Left e -> do @@ -306,3 +310,6 @@ postLoomFollowR _ = error "Temporarily disabled" postLoomUnfollowR :: KeyHashid Loom -> Handler () postLoomUnfollowR _ = error "Temporarily disabled" + +getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent +getLoomStampR = servePerActorKey loomActor LocalActorLoom diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 495e699..0858d58 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -29,12 +29,15 @@ module Vervis.Handler.Person , postPersonUnfollowR , postReplyR + + , getPersonStampR ) where import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Reader +import Data.List.NonEmpty (NonEmpty) import Data.Maybe import Data.Text (Text) import Data.Time.Clock @@ -67,11 +70,11 @@ import Data.Either.Local import Database.Persist.Local import Vervis.ActivityPub -import Vervis.ActorKey import Vervis.API import Vervis.Data.Actor import Vervis.Federation.Auth import Vervis.Federation.Collab +import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -272,12 +275,42 @@ postPersonOutboxR personHash = do Just (PersonR actorHash) | actorHash == personHash -> return () _ -> throwE "Can't post activity attributed to someone else" - handle eperson actorDB (AP.Activity _mid _actorAP mcap summary audience _fulfills specific) = + checkFederation remoteRecips = do + federation <- asksSite $ appFederation . appSettings + unless (federation || null remoteRecips) $ + throwE "Federation disabled, but remote recipients found" + + handle eperson actorDB (AP.Activity _mid _actorAP muCap summary audience _fulfills specific) = do + maybeCap <- traverse (nameExceptT "Capability" . parseActivityURI) muCap + ParsedAudience localRecips remoteRecips blinded fwdHosts <- do + mrecips <- parseAudience audience + fromMaybeE mrecips "No recipients" + checkFederation remoteRecips + let action = AP.Action + { AP.actionCapability = muCap + , AP.actionSummary = summary + , AP.actionAudience = blinded + , AP.actionFulfills = [] + , AP.actionSpecific = specific + } + run :: ( Entity Person + -> Actor + -> Maybe + ( Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> AP.Action URIMode + -> t + ) + -> t + run f = f eperson actorDB maybeCap localRecips remoteRecips fwdHosts action case specific of - AP.AcceptActivity accept -> - acceptC eperson actorDB summary audience accept - AP.ApplyActivity apply -> - applyC eperson actorDB mcap summary audience apply + AP.AcceptActivity accept -> run acceptC accept + AP.ApplyActivity apply -> run applyC apply AP.CreateActivity (AP.Create obj mtarget) -> case obj of {- @@ -285,14 +318,13 @@ postPersonOutboxR personHash = do createNoteC eperson sharer summary audience note mtarget -} AP.CreateTicketTracker detail mlocal -> - createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget + run createTicketTrackerC detail mlocal mtarget AP.CreateRepository detail vcs mlocal -> - createRepositoryC eperson actorDB summary audience detail vcs mlocal mtarget + run createRepositoryC detail vcs mlocal mtarget AP.CreatePatchTracker detail repos mlocal -> - createPatchTrackerC eperson actorDB summary audience detail repos mlocal mtarget + run createPatchTrackerC detail repos mlocal mtarget _ -> throwE "Unsupported Create 'object' type" - AP.InviteActivity invite -> - inviteC eperson actorDB mcap summary audience invite + AP.InviteActivity invite -> run inviteC invite {- AddActivity (AP.Add obj target) -> case obj of @@ -306,8 +338,7 @@ postPersonOutboxR personHash = do -} AP.OfferActivity (AP.Offer obj target) -> case obj of - AP.OfferTicket ticket -> - offerTicketC eperson actorDB summary audience ticket target + AP.OfferTicket ticket -> run offerTicketC ticket target {- OfferDep dep -> offerDepC eperson sharer summary audience dep target @@ -428,3 +459,6 @@ postPersonUnfollowR _ = error "Temporarily disabled" postReplyR :: KeyHashid Message -> Handler () postReplyR _ = error "Temporarily disabled" + +getPersonStampR :: KeyHashid Person -> KeyHashid SigKey -> Handler TypedContent +getPersonStampR = servePerActorKey personActor LocalActorPerson diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index a00caf2..046e5d4 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -44,6 +44,7 @@ module Vervis.Handler.Repo , postRepoLinkR + , getRepoStampR @@ -432,9 +433,11 @@ postRepoNewR = do personEntity@(Entity personID person) <- requireAuth personHash <- encodeKeyHashid personID (maybeSummary, audience, detail) <- C.createRepo personHash name desc + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateRepository detail vcs Nothing) Nothing actor <- runDB $ getJust $ personActor person result <- - runExceptT $ createRepositoryC personEntity actor maybeSummary audience detail vcs Nothing Nothing + runExceptT $ createRepositoryC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail vcs Nothing Nothing case result of Left e -> do @@ -702,6 +705,9 @@ postRepoLinkR repoHash loomHash = do Right () -> setMessage "Repo successfully linked with loom!" redirect $ RepoR repoHash +getRepoStampR :: KeyHashid Repo -> KeyHashid SigKey -> Handler TypedContent +getRepoStampR = servePerActorKey repoActor LocalActorRepo + diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index fa23bda..fb8a5f3 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -2723,6 +2723,56 @@ changes hLocal ctx = update ticketID [Ticket495Title =. plain] -- 496 , addFieldPrimRequired "Bundle" False "auto" + -- 497 + , addEntities model_497_sigkey + -- 498 + , addFieldRefRequired'' + "Forwarding" + (do ibid <- insert Inbox498 + obid <- insert Outbox498 + fsid <- insert FollowerSet498 + insertEntity $ Actor498 "" "" defaultTime ibid obid fsid + ) + (Just $ \ (Entity aidTemp aTemp) -> do + fs <- selectKeysList ([] :: [Filter Forwarding498]) [] + for_ fs $ \ forwardingID -> do + actorIDs <- + sequenceA $ map runMaybeT + [do fp <- MaybeT $ getValBy $ UniqueForwarderPerson498 forwardingID + lift $ person498Actor <$> getJust (forwarderPerson498Sender fp) + ,do fg <- MaybeT $ getValBy $ UniqueForwarderGroup498 forwardingID + lift $ group498Actor <$> getJust (forwarderGroup498Sender fg) + ,do fr <- MaybeT $ getValBy $ UniqueForwarderRepo498 forwardingID + lift $ repo498Actor <$> getJust (forwarderRepo498Sender fr) + ,do fd <- MaybeT $ getValBy $ UniqueForwarderDeck498 forwardingID + lift $ deck498Actor <$> getJust (forwarderDeck498Sender fd) + ,do fl <- MaybeT $ getValBy $ UniqueForwarderLoom498 forwardingID + lift $ loom498Actor <$> getJust (forwarderLoom498Sender fl) + ] + actorID <- + case catMaybes actorIDs of + [] -> error "No Forwarder* found!" + [a] -> return a + _ -> error "Multiple Forwarder* found!" + update forwardingID [Forwarding498Forwarder =. actorID] + + delete aidTemp + delete $ actor498Inbox aTemp + delete $ actor498Outbox aTemp + delete $ actor498Followers aTemp + ) + "forwarder" + "Actor" + -- 499 + , removeEntity "ForwarderPerson" + -- 500 + , removeEntity "ForwarderGroup" + -- 501 + , removeEntity "ForwarderRepo" + -- 502 + , removeEntity "ForwarderDeck" + -- 503 + , removeEntity "ForwarderLoom" ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 1d20b98..81e9c2c 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -298,6 +298,7 @@ import Database.Persist.Sql (SqlBackend) import Text.Email.Validate (EmailAddress) import Web.Text (HTML, PandocMarkdown) +import Crypto.ActorKey import Development.PatchMediaType import Development.PatchMediaType.Persist @@ -669,3 +670,9 @@ model_494_mr_origin = $(schema "494_2022-09-17_mr_origin") makeEntitiesMigration "495" $(modelFile "migrations/495_2022-09-21_ticket_title.model") + +model_497_sigkey :: [Entity SqlBackend] +model_497_sigkey = $(schema "497_2022-09-29_sigkey") + +makeEntitiesMigration "498" + $(modelFile "migrations/498_2022-10-03_forwarder.model") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 9262342..9b9dbc0 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -31,6 +31,7 @@ import Text.Email.Validate (EmailAddress) import Database.Persist.Schema.TH hiding (modelFile) import Yesod.Auth.Account (PersistUserCredentials (..)) +import Crypto.ActorKey import Crypto.PublicVerifKey import Database.Persist.EmailAddress import Database.Persist.Graph.Class diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index e774a01..83f5407 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -18,25 +18,44 @@ module Vervis.Persist.Actor , verifyLocalActivityExistsInDB , getRemoteActorURI , insertActor + , updateOutboxItem + , fillPerActorKeys ) where import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Logger.CallStack import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Data.Text (Text) +import Data.Traversable import Database.Persist import Database.Persist.Sql +import qualified Data.Text as T +import qualified Database.Esqueleto as E + +import Crypto.ActorKey +import Database.Persist.JSON import Network.FedURI +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 Database.Persist.Local +import Vervis.Data.Actor +import Vervis.FedURI +import Vervis.Foundation import Vervis.Model import Vervis.Recipient +import Vervis.Settings getLocalActor :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key) @@ -93,3 +112,35 @@ insertActor now name desc = do } actorID <- insert actor return $ Entity actorID actor + +updateOutboxItem + :: (MonadSite m, SiteEnv m ~ App) + => LocalActorBy Key + -> OutboxItemId + -> AP.Action URIMode + -> ReaderT SqlBackend m LocalURI +updateOutboxItem actorByKey itemID action = do + encodeRouteLocal <- getEncodeRouteLocal + hLocal <- asksSite siteInstanceHost + actorByHash <- hashLocalActor actorByKey + itemHash <- encodeKeyHashid itemID + let luId = encodeRouteLocal $ activityRoute actorByHash itemHash + luActor = encodeRouteLocal $ renderLocalActor actorByHash + doc = AP.Doc hLocal $ AP.makeActivity luId luActor action + update itemID [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return luId + +fillPerActorKeys :: Worker () +fillPerActorKeys = do + perActor <- asksSite $ appPerActorKeys . appSettings + when perActor $ do + actorIDs <- runSiteDB $ E.select $ E.from $ \ (actor `E.LeftOuterJoin` sigkey) -> do + E.on $ E.just (actor E.^. ActorId) E.==. sigkey E.?. SigKeyActor + E.where_ $ E.isNothing $ sigkey E.?. SigKeyId + return $ actor E.^. ActorId + keys <- for actorIDs $ \ (E.Value actorID) -> do + key <- liftIO generateActorKey + return $ SigKey actorID key + runSiteDB $ insertMany_ keys + logInfo $ + T.concat ["Filled ", T.pack (show $ length keys), " actor keys"] diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index b3e2ae1..82f7a6c 100644 --- a/src/Vervis/Settings.hs +++ b/src/Vervis/Settings.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019 by fr33domlover . + - Written in 2016, 2018, 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -113,6 +113,8 @@ data AppSettings = AppSettings -- How often to generate a new actor key for making HTTP signatures , appActorKeyRotation :: TimeInterval + -- | Whether to use personal actor keys, or an instance-wide key + , appPerActorKeys :: Bool -- | Use detailed request logging system , appDetailedRequestLogging :: Bool @@ -224,6 +226,7 @@ instance FromJSON AppSettings where appHttpSigTimeLimit <- interval <$> o .: "request-time-limit" appActorKeyRotation <- interval <$> o .: "actor-key-rotation" + appPerActorKeys <- o .:? "per-actor-keys" .!= False appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev appShouldLogAll <- o .:? "should-log-all" .!= defaultDev diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index b6e7950..9a1b533 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -22,6 +22,8 @@ module Vervis.Web.Actor , getActorFollowersCollection , getFollowingCollection , handleRobotInbox + , serveInstanceKey + , servePerActorKey ) where @@ -69,6 +71,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Vector as V import qualified Database.Esqueleto as E +import Crypto.ActorKey import Database.Persist.JSON import Network.FedURI import Web.ActivityPub hiding (Project (..), ActorLocal (..)) @@ -89,10 +92,11 @@ import Database.Persist.Local import Yesod.Persist.Local import qualified Data.Aeson.Encode.Pretty.ToEncoding as P +import qualified Web.ActivityPub as AP import Vervis.ActivityPub -import Vervis.ActorKey import Vervis.API +import Vervis.Data.Actor import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Foundation @@ -489,3 +493,63 @@ handleRobotInbox recipByHash handleSpecific now auth body = do msig <- checkForwarding recipByHash let mfwd = (localRecips,) <$> msig handleSpecific now remoteAuthor body mfwd luActivity (activitySpecific $ actbActivity body) + +actorKeyAP + :: ( MonadSite m, SiteEnv m ~ site + , SiteFedURI site, SiteFedURIMode site ~ u + ) + => Maybe (Route site) -> Route site -> ActorKey -> m (AP.PublicKey u) +actorKeyAP maybeHolderR keyR akey = do + encodeRouteLocal <- getEncodeRouteLocal + return AP.PublicKey + { AP.publicKeyId = LocalRefURI $ Left $ encodeRouteLocal keyR + , AP.publicKeyExpires = Nothing + , AP.publicKeyOwner = + case maybeHolderR of + Nothing -> AP.OwnerInstance + Just holderR -> AP.OwnerActor $ encodeRouteLocal holderR + , AP.publicKeyMaterial = actorKeyPublicBin akey + } + +serveInstanceKey + :: ((ActorKey, ActorKey) -> ActorKey) + -> Route App + -> Handler TypedContent +serveInstanceKey choose keyR = do + maybeKeys <- asksSite appActorKeys + case maybeKeys of + Nothing -> notFound + Just keys -> do + akey <- liftIO $ do + (akey1, akey2, _) <- readTVarIO keys + return $ choose (akey1, akey2) + keyAP <- actorKeyAP Nothing keyR akey + provideHtmlAndAP keyAP $ redirectToPrettyJSON keyR + +servePerActorKey' + :: LocalActorBy KeyHashid + -> KeyHashid SigKey + -> ActorKey + -> Handler TypedContent +servePerActorKey' holderByHash keyHash akey = do + let holderR = renderLocalActor holderByHash + keyR = stampRoute holderByHash keyHash + keyAP <- actorKeyAP (Just holderR) keyR akey + provideHtmlAndAP keyAP $ redirectToPrettyJSON keyR + +servePerActorKey + :: (PersistRecordBackend holder SqlBackend, ToBackendKey SqlBackend holder) + => (holder -> ActorId) + -> (KeyHashid holder -> LocalActorBy KeyHashid) + -> KeyHashid holder + -> KeyHashid SigKey + -> Handler TypedContent +servePerActorKey holderActor localActorHolder holderHash keyHash = do + holderID <- decodeKeyHashid404 holderHash + keyID <- decodeKeyHashid404 keyHash + akey <- runDB $ do + actorID <- holderActor <$> get404 holderID + SigKey actorID' akey <- get404 keyID + unless (actorID' == actorID) notFound + return akey + servePerActorKey' (localActorHolder holderHash) keyHash akey diff --git a/src/Vervis/Delivery.hs b/src/Vervis/Web/Delivery.hs similarity index 70% rename from src/Vervis/Delivery.hs rename to src/Vervis/Web/Delivery.hs index 0e05ce0..7bf1f6f 100644 --- a/src/Vervis/Delivery.hs +++ b/src/Vervis/Web/Delivery.hs @@ -13,34 +13,31 @@ - . -} --- These are for Barbie-related generated instances for ForwarderBy -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +module Vervis.Web.Delivery + ( --prepareSendP + --, prepareSendH + --, prepareResendP + --, prepareResendH + --, prepareForwardP + --, prepareForwardH -module Vervis.Delivery - ( deliverHttp - , deliverHttpBL - , deliverRemoteDB_D - , deliverRemoteDB_L - , deliverRemoteDB_P - , deliverRemoteDB_R - , deliverRemoteHTTP_D - , deliverRemoteHTTP_L - , deliverRemoteHTTP_P - , deliverRemoteHTTP_R - , deliverRemoteDB' - , deliverRemoteDB'' - , deliverRemoteHttp - , deliverRemoteHttp' - , deliverLocal' - , deliverLocal - , insertRemoteActivityToLocalInboxes - , fixRunningDeliveries + --, forwardRemoteDB + --, forwardRemoteHttp + --, deliverRemoteDB + --, deliverRemoteHttp + --, deliverLocal' + --, deliverLocal + --, insertRemoteActivityToLocalInboxes + fixRunningDeliveries , retryOutboxDelivery + + , deliverActivityDB + , forwardActivityDB ) where import Control.Applicative +import Control.Concurrent.STM.TVar import Control.Exception hiding (Handler, try) import Control.Monad import Control.Monad.IO.Class @@ -50,7 +47,6 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader -import Data.Barbie import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) @@ -59,169 +55,262 @@ import Data.Foldable import Data.Function import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Maybe -import Data.Semigroup import Data.Text (Text) -import Data.Text.Encoding import Data.Time.Clock import Data.Traversable import Database.Persist import Database.Persist.Sql -import GHC.Generics -import Network.HTTP.Client -import Network.TLS -- hiding (SHA256) -import Text.Blaze.Html (preEscapedToHtml) -import Text.Blaze.Html.Renderer.Text -import UnliftIO.Exception (try) import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) -import Yesod.Core.Handler -import Yesod.Persist.Core import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI import qualified Data.List.NonEmpty as NE -import qualified Data.List as L import qualified Data.List.Ordered as LO import qualified Data.Text as T -import qualified Data.Text.Lazy as TL import qualified Database.Esqueleto as E -import Yesod.HttpSignature - +import Crypto.ActorKey import Database.Persist.JSON import Network.FedURI -import Network.HTTP.Digest import Yesod.ActivityPub import Yesod.MonadSite -import Yesod.FedURI import Yesod.Hashids import qualified Web.ActivityPub as AP -import Control.Monad.Trans.Except.Local -import Data.Either.Local import Data.List.NonEmpty.Local import Data.Maybe.Local -import Data.Patch.Local hiding (Patch) import Data.Tuple.Local import Database.Persist.Local -import qualified Data.Patch.Local as P - import Vervis.ActivityPub +import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model -import Vervis.Model.Ident import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings -import Vervis.Time -deliverHttp +askLatestInstanceKey + :: (MonadSite m, SiteEnv m ~ App) => m (Maybe (Route App, ActorKey)) +askLatestInstanceKey = do + maybeTVar <- asksSite appActorKeys + for maybeTVar $ \ tvar -> do + (akey1, akey2, new1) <- liftIO $ readTVarIO tvar + return $ + if new1 + then (ActorKey1R, akey1) + else (ActorKey2R, akey2) + +prepareSendIK :: (MonadSite m, SiteEnv m ~ App) - => AP.Doc AP.Activity URIMode - -> Maybe LocalURI - -> Host - -> LocalURI - -> m (Either AP.APPostError (Response ())) -deliverHttp doc mfwd h luInbox = - deliverActivity (ObjURI h luInbox) (ObjURI h <$> mfwd) doc + => (Route App, ActorKey) + -> LocalActorBy KeyHashid + -> OutboxItemId + -> AP.Action URIMode + -> m (AP.Envelope URIMode) +prepareSendIK (keyR, akey) actorByHash itemID action = do + itemHash <- encodeKeyHashid itemID + let sign = actorKeySign akey + actorR = renderLocalActor actorByHash + idR = activityRoute actorByHash itemHash + prepareToSend keyR sign True actorR idR action -deliverHttpBL +prepareSendAK :: (MonadSite m, SiteEnv m ~ App) - => BL.ByteString - -> Maybe LocalURI - -> Host - -> LocalURI - -> m (Either AP.APPostError (Response ())) -deliverHttpBL body mfwd h luInbox = - deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body + => ActorId + -> LocalActorBy KeyHashid + -> OutboxItemId + -> AP.Action URIMode + -> ReaderT SqlBackend m (AP.Envelope URIMode) +prepareSendAK actorID actorByHash itemID action = do + Entity keyID key <- do + mk <- getBy $ UniqueSigKey actorID + case mk of + Nothing -> error "Actor has no keys!" + Just k -> return k + itemHash <- encodeKeyHashid itemID + keyHash <- encodeKeyHashid keyID + let keyR = stampRoute actorByHash keyHash + sign = actorKeySign $ sigKeyMaterial key + actorR = renderLocalActor actorByHash + idR = activityRoute actorByHash itemHash + prepareToSend keyR sign False actorR idR action -deliverRemoteDB_ - :: (MonadIO m, PersistRecordBackend fwder SqlBackend) - => (ForwardingId -> Key sender -> fwder) +prepareSendP + :: (MonadSite m, SiteEnv m ~ App) + => ActorId + -> LocalActorBy KeyHashid + -> OutboxItemId + -> AP.Action URIMode + -> ReaderT SqlBackend m (AP.Envelope URIMode) +prepareSendP actorID actorByHash itemID action = do + maybeKey <- lift askLatestInstanceKey + case maybeKey of + Nothing -> prepareSendAK actorID actorByHash itemID action + Just key -> lift $ prepareSendIK key actorByHash itemID action + +{- +prepareSendH + :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) + => ActorId + -> LocalActorBy KeyHashid + -> OutboxItemId + -> AP.Action URIMode + -> m (AP.Envelope URIMode) +prepareSendH actorID actorByHash itemID action = do + maybeKey <- askLatestInstanceKey + case maybeKey of + Nothing -> runSiteDB $ prepareSendAK actorID actorByHash itemID action + Just key -> prepareSendIK key actorByHash itemID action +-} + +prepareResendIK + :: (MonadSite m, SiteEnv m ~ App) + => (Route App, ActorKey) + -> LocalActorBy KeyHashid -> BL.ByteString + -> m (AP.Envelope URIMode) +prepareResendIK (keyR, akey) holderByHash body = do + let sign = actorKeySign akey + holderR = renderLocalActor holderByHash + prepareToRetry keyR sign (Just holderR) body + +prepareResendAK + :: (MonadSite m, SiteEnv m ~ App) + => ActorId + -> LocalActorBy KeyHashid + -> BL.ByteString + -> ReaderT SqlBackend m (AP.Envelope URIMode) +prepareResendAK actorID actorByHash body = do + Entity keyID key <- do + mk <- getBy $ UniqueSigKey actorID + case mk of + Nothing -> error "Actor has no keys!" + Just k -> return k + keyHash <- encodeKeyHashid keyID + let keyR = stampRoute actorByHash keyHash + sign = actorKeySign $ sigKeyMaterial key + prepareToRetry keyR sign Nothing body + +{- +prepareResendP + :: (MonadSite m, SiteEnv m ~ App) + => ActorId + -> LocalActorBy KeyHashid + -> BL.ByteString + -> ReaderT SqlBackend m (AP.Envelope URIMode) +prepareResendP actorID holderByHash body = do + maybeKey <- lift askLatestInstanceKey + case maybeKey of + Nothing -> prepareResendAK actorID holderByHash body + Just key -> lift $ prepareResendIK key holderByHash body +-} + +prepareResendH + :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) + => ActorId + -> LocalActorBy KeyHashid + -> BL.ByteString + -> m (AP.Envelope URIMode) +prepareResendH actorID holderByHash body = do + maybeKey <- askLatestInstanceKey + case maybeKey of + Nothing -> runSiteDB $ prepareResendAK actorID holderByHash body + Just key -> prepareResendIK key holderByHash body + +prepareForwardIK + :: (MonadSite m, SiteEnv m ~ App) + => (Route App, ActorKey) + -> LocalActorBy KeyHashid + -> BL.ByteString + -> ByteString + -> m (AP.Errand URIMode) +prepareForwardIK (keyR, akey) fwderByHash body proof = do + let sign = actorKeySign akey + fwderR = renderLocalActor fwderByHash + prepareToForward keyR sign True fwderR body proof + +prepareForwardAK + :: (MonadSite m, SiteEnv m ~ App) + => ActorId + -> LocalActorBy KeyHashid + -> BL.ByteString + -> ByteString + -> ReaderT SqlBackend m (AP.Errand URIMode) +prepareForwardAK actorID fwderByHash body proof = do + Entity keyID key <- do + mk <- getBy $ UniqueSigKey actorID + case mk of + Nothing -> error "Actor has no keys!" + Just k -> return k + keyHash <- encodeKeyHashid keyID + let keyR = stampRoute fwderByHash keyHash + sign = actorKeySign $ sigKeyMaterial key + fwderR = renderLocalActor fwderByHash + prepareToForward keyR sign False fwderR body proof + +prepareForwardP + :: (MonadSite m, SiteEnv m ~ App) + => ActorId + -> LocalActorBy KeyHashid + -> BL.ByteString + -> ByteString + -> ReaderT SqlBackend m (AP.Errand URIMode) +prepareForwardP actorID fwderByHash body proof = do + maybeKey <- askLatestInstanceKey + case maybeKey of + Nothing -> prepareForwardAK actorID fwderByHash body proof + Just key -> lift $ prepareForwardIK key fwderByHash body proof + +prepareForwardH + :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) + => ActorId + -> LocalActorBy KeyHashid + -> BL.ByteString + -> ByteString + -> m (AP.Errand URIMode) +prepareForwardH actorID fwderByHash body proof = do + maybeKey <- askLatestInstanceKey + case maybeKey of + Nothing -> runSiteDB $ prepareForwardAK actorID fwderByHash body proof + Just key -> prepareForwardIK key fwderByHash body proof + +forwardRemoteDB + :: MonadIO m + => BL.ByteString -> RemoteActivityId - -> Key sender + -> ActorId -> ByteString -> [((InstanceId, Host), NonEmpty RemoteRecipient)] -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] -deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do + [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] +forwardRemoteDB body ractid fwderID sig recips = do let body' = BL.toStrict body makeFwd (RemoteRecipient raid _ _ msince) = - Forwarding raid ractid body' sig (isNothing msince) - fetchedDeliv <- for recips $ bitraverse pure $ \ rs -> do - fwds <- insertMany' makeFwd rs - insertMany' (flip makeFwder senderKey . snd) fwds - return $ takeNoError5 fetchedDeliv + Forwarding raid ractid body' sig fwderID (isNothing msince) + fetchedDeliv <- for recips $ bitraverse pure (insertMany' makeFwd) + return $ takeNoError4 fetchedDeliv where takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs) - takeNoError5 = takeNoError noError + takeNoError4 = takeNoError noError where - noError ((RemoteRecipient ak luA luI Nothing , fwid), fwrid) = Just (ak, luA, luI, fwid, fwrid) - noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing + noError (RemoteRecipient ak luA luI Nothing , fwid) = Just (ak, luA, luI, fwid) + noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing -deliverRemoteDB_D - :: MonadIO m - => BL.ByteString - -> RemoteActivityId - -> DeckId - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderDeckId))] -deliverRemoteDB_D = deliverRemoteDB_ ForwarderDeck - -deliverRemoteDB_L - :: MonadIO m - => BL.ByteString - -> RemoteActivityId - -> LoomId - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderLoomId))] -deliverRemoteDB_L = deliverRemoteDB_ ForwarderLoom - -deliverRemoteDB_P - :: MonadIO m - => BL.ByteString - -> RemoteActivityId - -> PersonId - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderPersonId))] -deliverRemoteDB_P = deliverRemoteDB_ ForwarderPerson - -deliverRemoteDB_R - :: MonadIO m - => BL.ByteString - -> RemoteActivityId - -> RepoId - -> ByteString - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> ReaderT SqlBackend m - [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))] -deliverRemoteDB_R = deliverRemoteDB_ ForwarderRepo - -deliverRemoteHTTP' - :: (MonadSite m, SiteEnv m ~ App, PersistRecordBackend fwder SqlBackend) +forwardRemoteHttp + :: (MonadSite m, SiteEnv m ~ App) => UTCTime - -> LocalActor - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] + -> AP.Errand URIMode + -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] -> m () -deliverRemoteHTTP' now sender body sig fetched = do - let deliver h inbox = - forwardActivity (ObjURI h inbox) sig (renderLocalActor sender) body +forwardRemoteHttp now errand fetched = do + let deliver h inbox = forwardActivity errand $ ObjURI h inbox traverse_ (fork . deliverFetched deliver now) fetched where fork = forkWorker "Inbox forwarding to remote members of local collections: delivery failed" deliverFetched deliver now ((_, h), recips@(r :| rs)) = do - let (raid, _luActor, luInbox, fwid, forwarderKey) = r + let (raid, _luActor, luInbox, fwid) = r e <- deliver h luInbox let e' = case e of Left err -> @@ -232,18 +321,16 @@ deliverRemoteHTTP' now sender body sig fetched = do case e' of Nothing -> runSiteDB $ do let recips' = NE.toList recips - updateWhere [RemoteActorId <-. map fst5 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - updateWhere [ForwardingId <-. map fourth5 recips'] [ForwardingRunning =. False] + updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False] Just success -> do runSiteDB $ if success - then do - delete forwarderKey - delete fwid + then delete fwid else do updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] update fwid [ForwardingRunning =. False] - for_ rs $ \ (raid, _luActor, luInbox, fwid, forwarderKey) -> + for_ rs $ \ (raid, _luActor, luInbox, fwid) -> fork $ do e <- deliver h luInbox runSiteDB $ @@ -251,70 +338,14 @@ deliverRemoteHTTP' now sender body sig fetched = do Left _err -> do updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] update fwid [ForwardingRunning =. False] - Right _resp -> do - delete forwarderKey - delete fwid - -deliverRemoteHTTP_D - :: (MonadSite m, SiteEnv m ~ App) - => UTCTime - -> KeyHashid Deck - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderDeckId))] - -> m () -deliverRemoteHTTP_D now dkhid = - deliverRemoteHTTP' now $ LocalActorDeck dkhid - -deliverRemoteHTTP_L - :: (MonadSite m, SiteEnv m ~ App) - => UTCTime - -> KeyHashid Loom - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderLoomId))] - -> m () -deliverRemoteHTTP_L now lkhid = - deliverRemoteHTTP' now $ LocalActorLoom lkhid - -deliverRemoteHTTP_P - :: (MonadSite m, SiteEnv m ~ App) - => UTCTime - -> KeyHashid Person - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderPersonId))] - -> m () -deliverRemoteHTTP_P now pkhid = deliverRemoteHTTP' now $ LocalActorPerson pkhid - -deliverRemoteHTTP_R - :: (MonadSite m, SiteEnv m ~ App) - => UTCTime - -> KeyHashid Repo - -> BL.ByteString - -> ByteString - -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderRepoId))] - -> m () -deliverRemoteHTTP_R now rkhid = deliverRemoteHTTP' now $ LocalActorRepo rkhid - -deliverRemoteDB' - :: Host - -> OutboxItemId - -> [(Host, NonEmpty LocalURI)] - -> [((InstanceId, Host), NonEmpty RemoteRecipient)] - -> AppDB - ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - ) -deliverRemoteDB' hContext = deliverRemoteDB'' [hContext] + Right _resp -> delete fwid data Recip = RecipRA (Entity RemoteActor) | RecipURA (Entity UnfetchedRemoteActor) | RecipRC (Entity RemoteCollection) -deliverRemoteDB'' +deliverRemoteDB :: MonadIO m => [Host] -> OutboxItemId @@ -325,7 +356,7 @@ deliverRemoteDB'' , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] ) -deliverRemoteDB'' hContexts obid recips known = do +deliverRemoteDB hContexts obid recips known = do recips' <- for recips $ \ (h, lus) -> do let lus' = NE.nub lus (iid, inew) <- idAndNew <$> insertBy' (Instance h) @@ -385,30 +416,19 @@ deliverRemoteDB'' hContexts obid recips known = do noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing deliverRemoteHttp - :: Host - -> OutboxItemId - -> AP.Doc AP.Activity URIMode - -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - ) - -> Worker () -deliverRemoteHttp hContext = deliverRemoteHttp' [hContext] - -deliverRemoteHttp' :: [Host] -> OutboxItemId - -> AP.Doc AP.Activity URIMode + -> AP.Envelope URIMode -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] - ) + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))] + ) -> Worker () -deliverRemoteHttp' hContexts obid doc (fetched, unfetched, unknown) = do +deliverRemoteHttp hContexts obid envelope (fetched, unfetched, unknown) = do logDebug' "Starting" let deliver fwd h inbox = do let fwd' = if h `elem` hContexts then Just fwd else Nothing - (isJust fwd',) <$> deliverHttp doc fwd' h inbox + (isJust fwd',) <$> deliverActivity envelope fwd' (ObjURI h inbox) now <- liftIO getCurrentTime logDebug' $ "Launching fetched " <> showHosts fetched @@ -427,7 +447,7 @@ deliverRemoteHttp' hContexts obid doc (fetched, unfetched, unknown) = do prefix = T.concat [ "Outbox POST handler: deliverRemoteHttp obid#" - , T.pack $ show $ fromSqlKey obid + , "?" --T.pack $ show $ fromSqlKey obid , ": " ] fork = forkWorker "Outbox POST handler: HTTP delivery" @@ -861,61 +881,74 @@ fixRunningDeliveries = do , " forwarding deliveries" ] -data ForwarderBy f - = FwderPerson (f ForwarderPerson) - | FwderGroup (f ForwarderGroup) - | FwderRepo (f ForwarderRepo) - | FwderDeck (f ForwarderDeck) - | FwderLoom (f ForwarderLoom) - deriving (Generic, FunctorB, ConstraintsB) +relevant dropAfter now since = addUTCTime dropAfter since > now -partitionFwders - :: [ForwarderBy f] - -> ( [f ForwarderPerson] - , [f ForwarderGroup] - , [f ForwarderRepo] - , [f ForwarderDeck] - , [f ForwarderLoom] - ) -partitionFwders = foldl' f ([], [], [], [], []) - where - f (ps, gs, rs, ds, ls) = \ fwder -> - case fwder of - FwderPerson p -> (p : ps, gs, rs, ds, ls) - FwderGroup g -> (ps, g : gs, rs, ds, ls) - FwderRepo r -> (ps, gs, r : rs, ds, ls) - FwderDeck d -> (ps, gs, rs, d : ds, ls) - FwderLoom l -> (ps, gs, rs, ds, l : ls) +fork action = do + wait <- asyncWorker action + return $ do + result <- wait + case result of + Left e -> do + logError $ "Periodic delivery error! " <> T.pack (displayException e) + return False + Right success -> return success -retryOutboxDelivery :: Worker () -retryOutboxDelivery = do - logInfo "Periodic delivery starting" +localActor Nothing Nothing Nothing Nothing Nothing = error "Found unused Actor" +localActor (Just p) Nothing Nothing Nothing Nothing = LocalActorPerson p +localActor Nothing (Just g) Nothing Nothing Nothing = LocalActorGroup g +localActor Nothing Nothing (Just r) Nothing Nothing = LocalActorRepo r +localActor Nothing Nothing Nothing (Just d) Nothing = LocalActorDeck d +localActor Nothing Nothing Nothing Nothing (Just l) = LocalActorLoom l +localActor _ _ _ _ _ = error "Found multiple-use Actor" + +retryUnlinkedDelivery :: Worker () +retryUnlinkedDelivery = do now <- liftIO $ getCurrentTime - (unlinkedHttp, linkedHttp, forwardingHttp) <- runSiteDB $ do + unlinkedHttp <- runSiteDB $ do -- Get all unlinked deliveries which aren't running already in outbox -- post handlers - unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc) -> do + unlinked' <- E.select $ E.from $ + \ (udl `E.InnerJoin` obi `E.InnerJoin` a `E.InnerJoin` ura `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc + `E.LeftOuterJoin` p + `E.LeftOuterJoin` g + `E.LeftOuterJoin` r + `E.LeftOuterJoin` d + `E.LeftOuterJoin` l + ) -> do + E.on $ E.just (a E.^. ActorId) E.==. l E.?. LoomActor + E.on $ E.just (a E.^. ActorId) E.==. d E.?. DeckActor + E.on $ E.just (a E.^. ActorId) E.==. r E.?. RepoActor + E.on $ E.just (a E.^. ActorId) E.==. g E.?. GroupActor + E.on $ E.just (a E.^. ActorId) E.==. p E.?. PersonActor E.on $ E.just (ro E.^. RemoteObjectId) E.==. rc E.?. RemoteCollectionIdent E.on $ E.just (ro E.^. RemoteObjectId) E.==. ra E.?. RemoteActorIdent E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId E.on $ ura E.^. UnfetchedRemoteActorIdent E.==. ro E.^. RemoteObjectId E.on $ udl E.^. UnlinkedDeliveryRecipient E.==. ura E.^. UnfetchedRemoteActorId - E.on $ udl E.^. UnlinkedDeliveryActivity E.==. ob E.^. OutboxItemId + E.on $ obi E.^. OutboxItemOutbox E.==. a E.^. ActorOutbox + E.on $ udl E.^. UnlinkedDeliveryActivity E.==. obi E.^. OutboxItemId E.where_ $ udl E.^. UnlinkedDeliveryRunning E.==. E.val False E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ura E.^. UnfetchedRemoteActorId] return - ( i E.^. InstanceId - , i E.^. InstanceHost + ( i , ura E.^. UnfetchedRemoteActorId , ro E.^. RemoteObjectIdent , ura E.^. UnfetchedRemoteActorSince , udl E.^. UnlinkedDeliveryId , udl E.^. UnlinkedDeliveryActivity , udl E.^. UnlinkedDeliveryForwarding - , ob E.^. OutboxItemActivity + , obi E.^. OutboxItemActivity , ra E.?. RemoteActorId , rc E.?. RemoteCollectionId + + , a E.^. ActorId + + , p E.?. PersonId + , g E.?. GroupId + , r E.?. RepoId + , d E.?. DeckId + , l E.?. LoomId ) -- Strip the E.Value wrappers and organize the records for the @@ -938,10 +971,122 @@ retryOutboxDelivery = do partitionEithers $ map (decideBySinceUDL dropAfter now) lonely deleteWhere [UnlinkedDeliveryId <-. lonelyOld] + return $ groupUnlinked lonelyNew + + logDebug $ + "Periodic delivery forking unlinked " <> + T.pack (show $ map (renderAuthority . snd . fst) unlinkedHttp) + waitsUDL <- traverse (fork . deliverUnlinked now) unlinkedHttp + + logDebug $ + T.concat + [ "Periodic delivery waiting for " + , T.pack $ show $ length waitsUDL, " unlinked" + ] + resultsUDL <- sequence waitsUDL + unless (and resultsUDL) $ logError "Periodic delivery UDL error" + + where + + adaptUnlinked + ( Entity iid (Instance h), E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid + , E.Value actorID, E.Value mp, E.Value mg, E.Value mr, E.Value md, E.Value ml + ) = + ( Left <$> mraid <|> Right <$> mrcid + , ( ( (iid, h) + , ( (uraid, luRecip) + , ( udlid + , fwd + , obid + , BL.fromStrict $ persistJSONBytes act + , actorID + , localActor mp mg mr md ml + ) + ) + ) + , since + ) + ) + + unlinkedID ((_, (_, (udlid, _, _, _, _, _))), _) = udlid + + toLinked (Left raid, ((_, (_, (_, fwd, obid, _, _, _))), _)) = Just $ Delivery raid obid fwd False + toLinked (Right _ , _ ) = Nothing + + decideBySinceUDL dropAfter now (udl@(_, (_, (udlid, _, _, _, _, _))), msince) = + case msince of + Nothing -> Right udl + Just since -> + if relevant dropAfter now since + then Right udl + else Left udlid + + groupUnlinked + = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) + . groupWithExtractBy ((==) `on` fst) fst snd + + deliverUnlinked now ((iid, h), recips) = do + logDebug $ "Periodic deliver starting unlinked for host " <> renderAuthority h + waitsR <- for recips $ \ ((uraid, luRecip), delivs) -> fork $ do + logDebug $ + "Periodic deliver starting unlinked for actor " <> + renderObjURI (ObjURI h luRecip) + e <- fetchRemoteActor iid h luRecip + case e of + Right (Right mera) -> + case mera of + Nothing -> runSiteDB $ deleteWhere [UnlinkedDeliveryId <-. map fst6 (NE.toList delivs)] + Just (Entity raid ra) -> do + waitsD <- for delivs $ \ (udlid, fwd, obid, doc, actorID, actorByKey) -> fork $ do + actorByHash <- hashLocalActor actorByKey + envelope <- prepareResendH actorID actorByHash doc + let fwd' = if fwd then Just luRecip else Nothing + e' <- deliverActivity envelope fwd' (ObjURI h $ remoteActorInbox ra) + case e' of + Left _err -> do + runSiteDB $ do + delete udlid + insert_ $ Delivery raid obid fwd False + return False + Right _resp -> do + runSiteDB $ delete udlid + return True + results <- sequence waitsD + runSiteDB $ + if and results + then update raid [RemoteActorErrorSince =. Nothing] + else if or results + then update raid [RemoteActorErrorSince =. Just now] + else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + _ -> runSiteDB $ updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] + return True + results <- sequence waitsR + unless (and results) $ + logError $ "Periodic UDL delivery error for host " <> renderAuthority h + return True + +retryLinkedDelivery :: Worker () +retryLinkedDelivery = do + now <- liftIO $ getCurrentTime + linkedHttp <- runSiteDB $ do + -- Now let's grab the linked deliveries, and similarly delete old ones -- and return the rest for HTTP delivery. - linked <- E.select $ E.from $ \ (dl `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` ob) -> do - E.on $ dl E.^. DeliveryActivity E.==. ob E.^. OutboxItemId + linked <- E.select $ E.from $ + \ (dl `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` obi `E.InnerJoin` a + `E.LeftOuterJoin` p + `E.LeftOuterJoin` g + `E.LeftOuterJoin` r + `E.LeftOuterJoin` d + `E.LeftOuterJoin` l + ) -> do + E.on $ E.just (a E.^. ActorId) E.==. l E.?. LoomActor + E.on $ E.just (a E.^. ActorId) E.==. d E.?. DeckActor + E.on $ E.just (a E.^. ActorId) E.==. r E.?. RepoActor + E.on $ E.just (a E.^. ActorId) E.==. g E.?. GroupActor + E.on $ E.just (a E.^. ActorId) E.==. p E.?. PersonActor + E.on $ obi E.^. OutboxItemOutbox E.==. a E.^. ActorOutbox + E.on $ dl E.^. DeliveryActivity E.==. obi E.^. OutboxItemId E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId E.on $ dl E.^. DeliveryRecipient E.==. ra E.^. RemoteActorId @@ -956,70 +1101,28 @@ retryOutboxDelivery = do , ra E.^. RemoteActorErrorSince , dl E.^. DeliveryId , dl E.^. DeliveryForwarding - , ob E.^. OutboxItemActivity + , obi E.^. OutboxItemActivity + + , a E.^. ActorId + + , p E.?. PersonId + , g E.?. GroupId + , r E.?. RepoId + , d E.?. DeckId + , l E.?. LoomId ) + dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked deleteWhere [DeliveryId <-. linkedOld] - -- Same for forwarding deliveries, which are always linked - forwarding <- E.select $ E.from $ - \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i - `E.LeftOuterJoin` fwp - `E.LeftOuterJoin` fwg - `E.LeftOuterJoin` fwr - `E.LeftOuterJoin` fwd - `E.LeftOuterJoin` fwl - ) -> do - E.on $ E.just (fw E.^. ForwardingId) E.==. fwl E.?. ForwarderLoomTask - E.on $ E.just (fw E.^. ForwardingId) E.==. fwd E.?. ForwarderDeckTask - E.on $ E.just (fw E.^. ForwardingId) E.==. fwr E.?. ForwarderRepoTask - E.on $ E.just (fw E.^. ForwardingId) E.==. fwg E.?. ForwarderGroupTask - E.on $ E.just (fw E.^. ForwardingId) E.==. fwp E.?. ForwarderPersonTask - E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId - E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId - E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId - E.where_ $ fw E.^. ForwardingRunning E.==. E.val False - E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId] - return (i, ra, fw, fwp, fwg, fwr, fwd, fwl) - let (forwardingOld, forwardingNew) = - partitionEithers $ - map (decideBySinceFW dropAfter now . adaptForwarding) - forwarding - (fwidsOld, fwdersOld) = unzip forwardingOld - (fwpidsOld, fwgidsOld, fwridsOld, fwdidsOld, fwlidsOld) = - partitionFwders fwdersOld - deleteWhere [ForwarderPersonId <-. fwpidsOld] - deleteWhere [ForwarderGroupId <-. fwgidsOld] - deleteWhere [ForwarderRepoId <-. fwridsOld] - deleteWhere [ForwarderDeckId <-. fwdidsOld] - deleteWhere [ForwarderLoomId <-. fwlidsOld] - deleteWhere [ForwardingId <-. fwidsOld] - - return - ( groupUnlinked lonelyNew - , groupLinked linkedNew - , groupForwarding forwardingNew - ) - - let deliver = deliverHttpBL - logInfo "Periodic delivery prepared DB, starting async HTTP POSTs" + return $ groupLinked linkedNew logDebug $ "Periodic delivery forking linked " <> T.pack (show $ map (renderAuthority . snd . fst) linkedHttp) - waitsDL <- traverse (fork . deliverLinked deliver now) linkedHttp - - logDebug $ - "Periodic delivery forking forwarding " <> - T.pack (show $ map (renderAuthority . snd . fst) forwardingHttp) - waitsFW <- traverse (fork . deliverForwarding now) forwardingHttp - - logDebug $ - "Periodic delivery forking unlinked " <> - T.pack (show $ map (renderAuthority . snd . fst) unlinkedHttp) - waitsUDL <- traverse (fork . deliverUnlinked deliver now) unlinkedHttp + waitsDL <- traverse (fork . deliverLinked now) linkedHttp logDebug $ T.concat @@ -1029,58 +1132,26 @@ retryOutboxDelivery = do resultsDL <- sequence waitsDL unless (and resultsDL) $ logError "Periodic delivery DL error" - logDebug $ - T.concat - [ "Periodic delivery waiting for ", T.pack $ show $ length waitsFW - , " forwarding" - ] - resultsFW <- sequence waitsFW - unless (and resultsFW) $ logError "Periodic delivery FW error" - - logDebug $ - T.concat - [ "Periodic delivery waiting for " - , T.pack $ show $ length waitsUDL, " unlinked" - ] - resultsUDL <- sequence waitsUDL - unless (and resultsUDL) $ logError "Periodic delivery UDL error" - - logInfo "Periodic delivery done" where - adaptUnlinked - (E.Value iid, E.Value h, E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid) = - ( Left <$> mraid <|> Right <$> mrcid - , ( ( (iid, h) - , ((uraid, luRecip), (udlid, fwd, obid, BL.fromStrict $ persistJSONBytes act)) - ) - , since - ) - ) - - unlinkedID ((_, (_, (udlid, _, _, _))), _) = udlid - - toLinked (Left raid, ((_, (_, (_, fwd, obid, _))), _)) = Just $ Delivery raid obid fwd False - toLinked (Right _ , _ ) = Nothing - - relevant dropAfter now since = addUTCTime dropAfter since > now - - decideBySinceUDL dropAfter now (udl@(_, (_, (udlid, _, _, _))), msince) = - case msince of - Nothing -> Right udl - Just since -> - if relevant dropAfter now since - then Right udl - else Left udlid adaptLinked - (E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act) = + ( E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act + , E.Value actorID, E.Value mp, E.Value mg, E.Value mr, E.Value md, E.Value ml + ) = ( ( (iid, h) - , ((raid, (ident, inbox)), (dlid, fwd, BL.fromStrict $ persistJSONBytes act)) + , ( (raid, (ident, inbox)) + , ( dlid + , fwd + , BL.fromStrict $ persistJSONBytes act + , actorID + , localActor mp mg mr md ml + ) + ) ) , since ) - decideBySinceDL dropAfter now (dl@(_, (_, (dlid, _, _))), msince) = + decideBySinceDL dropAfter now (dl@(_, (_, (dlid, _, _, _, _))), msince) = case msince of Nothing -> Right dl Just since -> @@ -1088,76 +1159,21 @@ retryOutboxDelivery = do then Right dl else Left dlid - adaptForwarding - ( Entity iid (Instance h) - , Entity raid (RemoteActor _ _ inbox _ since) - , Entity fwid (Forwarding _ _ body sig _) - , mfwp, mfwg, mfwr, mfwd, mfwl - ) = - ( ( (iid, h) - , ( (raid, inbox) - , ( fwid - , BL.fromStrict body - , case (mfwp, mfwg, mfwr, mfwd, mfwl) of - (Nothing, Nothing, Nothing, Nothing, Nothing) -> - error "Found fwid without a Forwarder* record" - (Just fwp, Nothing, Nothing, Nothing, Nothing) -> - FwderPerson fwp - (Nothing, Just fwg, Nothing, Nothing, Nothing) -> - FwderGroup fwg - (Nothing, Nothing, Just fwr, Nothing, Nothing) -> - FwderRepo fwr - (Nothing, Nothing, Nothing, Just fwd, Nothing) -> - FwderDeck fwd - (Nothing, Nothing, Nothing, Nothing, Just fwl) -> - FwderLoom fwl - _ -> error "Found fwid with multiple forwarders" - , sig - ) - ) - ) - , since - ) - - decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, fwder, _))), msince) = - case msince of - Nothing -> Right fw - Just since -> - if relevant dropAfter now since - then Right fw - else Left (fwid, bmap entityKey fwder) - - groupUnlinked - = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) - . groupWithExtractBy ((==) `on` fst) fst snd - groupLinked = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) . groupWithExtractBy ((==) `on` fst) fst snd - groupForwarding - = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) - . groupWithExtractBy ((==) `on` fst) fst snd - - fork action = do - wait <- asyncWorker action - return $ do - result <- wait - case result of - Left e -> do - logError $ "Periodic delivery error! " <> T.pack (displayException e) - return False - Right success -> return success - - deliverLinked deliver now ((_, h), recips) = do + deliverLinked now ((_, h), recips) = do logDebug $ "Periodic deliver starting linked for host " <> renderAuthority h waitsR <- for recips $ \ ((raid, (ident, inbox)), delivs) -> fork $ do logDebug $ "Periodic deliver starting linked for actor " <> renderObjURI (ObjURI h ident) - waitsD <- for delivs $ \ (dlid, fwd, doc) -> fork $ do + waitsD <- for delivs $ \ (dlid, fwd, doc, actorID, actorByKey) -> fork $ do + actorByHash <- hashLocalActor actorByKey + envelope <- prepareResendH actorID actorByHash doc let fwd' = if fwd then Just ident else Nothing - e <- deliver doc fwd' h inbox + e <- deliverActivity envelope fwd' (ObjURI h inbox) case e of Left err -> do logError $ T.concat @@ -1182,43 +1198,92 @@ retryOutboxDelivery = do logError $ "Periodic DL delivery error for host " <> renderAuthority h return True - deliverUnlinked deliver now ((iid, h), recips) = do - logDebug $ "Periodic deliver starting unlinked for host " <> renderAuthority h - waitsR <- for recips $ \ ((uraid, luRecip), delivs) -> fork $ do - logDebug $ - "Periodic deliver starting unlinked for actor " <> - renderObjURI (ObjURI h luRecip) - e <- fetchRemoteActor iid h luRecip - case e of - Right (Right mera) -> - case mera of - Nothing -> runSiteDB $ deleteWhere [UnlinkedDeliveryId <-. map fst4 (NE.toList delivs)] - Just (Entity raid ra) -> do - waitsD <- for delivs $ \ (udlid, fwd, obid, doc) -> fork $ do - let fwd' = if fwd then Just luRecip else Nothing - e' <- deliver doc fwd' h $ remoteActorInbox ra - case e' of - Left _err -> do - runSiteDB $ do - delete udlid - insert_ $ Delivery raid obid fwd False - return False - Right _resp -> do - runSiteDB $ delete udlid - return True - results <- sequence waitsD - runSiteDB $ - if and results - then update raid [RemoteActorErrorSince =. Nothing] - else if or results - then update raid [RemoteActorErrorSince =. Just now] - else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - _ -> runSiteDB $ updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] - return True - results <- sequence waitsR - unless (and results) $ - logError $ "Periodic UDL delivery error for host " <> renderAuthority h - return True +retryForwarding :: Worker () +retryForwarding = do + now <- liftIO $ getCurrentTime + forwardingHttp <- runSiteDB $ do + + -- Same for forwarding deliveries, which are always linked + forwarding <- E.select $ E.from $ + \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i + `E.LeftOuterJoin` p + `E.LeftOuterJoin` g + `E.LeftOuterJoin` r + `E.LeftOuterJoin` d + `E.LeftOuterJoin` l + ) -> do + E.on $ E.just (fw E.^. ForwardingForwarder) E.==. l E.?. LoomActor + E.on $ E.just (fw E.^. ForwardingForwarder) E.==. d E.?. DeckActor + E.on $ E.just (fw E.^. ForwardingForwarder) E.==. r E.?. RepoActor + E.on $ E.just (fw E.^. ForwardingForwarder) E.==. g E.?. GroupActor + E.on $ E.just (fw E.^. ForwardingForwarder) E.==. p E.?. PersonActor + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId + E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId + E.where_ $ fw E.^. ForwardingRunning E.==. E.val False + E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId] + return + (i, ra, fw + , p E.?. PersonId + , g E.?. GroupId + , r E.?. RepoId + , d E.?. DeckId + , l E.?. LoomId + ) + dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings + let (forwardingOld, forwardingNew) = + partitionEithers $ + map (decideBySinceFW dropAfter now . adaptForwarding) + forwarding + deleteWhere [ForwardingId <-. forwardingOld] + + return $ groupForwarding forwardingNew + + logDebug $ + "Periodic delivery forking forwarding " <> + T.pack (show $ map (renderAuthority . snd . fst) forwardingHttp) + waitsFW <- traverse (fork . deliverForwarding now) forwardingHttp + + logDebug $ + T.concat + [ "Periodic delivery waiting for ", T.pack $ show $ length waitsFW + , " forwarding" + ] + resultsFW <- sequence waitsFW + unless (and resultsFW) $ logError "Periodic delivery FW error" + + where + + adaptForwarding + ( Entity iid (Instance h) + , Entity raid (RemoteActor _ _ inbox _ since) + , Entity fwid (Forwarding _ _ body sig fwderID _) + , E.Value mp, E.Value mg, E.Value mr, E.Value md, E.Value ml + ) = + ( ( (iid, h) + , ( (raid, inbox) + , ( fwid + , BL.fromStrict body + , localActor mp mg mr md ml + , sig + , fwderID + ) + ) + ) + , since + ) + + decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, _, _, _))), msince) = + case msince of + Nothing -> Right fw + Just since -> + if relevant dropAfter now since + then Right fw + else Left fwid + + groupForwarding + = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) + . groupWithExtractBy ((==) `on` fst) fst snd deliverForwarding now ((_, h), recips) = do logDebug $ "Periodic deliver starting forwarding for host " <> renderAuthority h @@ -1226,21 +1291,15 @@ retryOutboxDelivery = do logDebug $ "Periodic deliver starting forwarding for inbox " <> renderObjURI (ObjURI h inbox) - waitsD <- for delivs $ \ (fwid, body, fwderE, sig) -> fork $ do - let (fwderK, senderK) = splitForwarder fwderE - sender <- renderLocalActor <$> hashLocalActor senderK - e <- forwardActivity (ObjURI h inbox) sig sender body + waitsD <- for delivs $ \ (fwid, body, fwderByKey, sig, fwderActorID) -> fork $ do + fwderByHash <- hashLocalActor fwderByKey + errand <- prepareForwardH fwderActorID fwderByHash body sig + let sender = renderLocalActor fwderByHash + e <- forwardActivity errand $ ObjURI h inbox case e of Left _err -> return False Right _resp -> do - runSiteDB $ do - case fwderK of - FwderPerson k -> delete k - FwderGroup k -> delete k - FwderRepo k -> delete k - FwderDeck k -> delete k - FwderLoom k -> delete k - delete fwid + runSiteDB $ delete fwid return True results <- sequence waitsD runSiteDB $ @@ -1254,14 +1313,55 @@ retryOutboxDelivery = do unless (and results) $ logError $ "Periodic FW delivery error for host " <> renderAuthority h return True - where - splitForwarder (FwderPerson (Entity f (ForwarderPerson _ p))) = - (FwderPerson f, LocalActorPerson p) - splitForwarder (FwderGroup (Entity f (ForwarderGroup _ g))) = - (FwderGroup f, LocalActorGroup g) - splitForwarder (FwderRepo (Entity f (ForwarderRepo _ r))) = - (FwderRepo f, LocalActorRepo r) - splitForwarder (FwderDeck (Entity f (ForwarderDeck _ d))) = - (FwderDeck f, LocalActorDeck d) - splitForwarder (FwderLoom (Entity f (ForwarderLoom _ l))) = - (FwderLoom f, LocalActorLoom l) + +retryOutboxDelivery :: Worker () +retryOutboxDelivery = do + logInfo "Periodic delivery starting" + + retryUnlinkedDelivery + retryLinkedDelivery + retryForwarding + + logInfo "Periodic delivery done" + +deliverActivityDB + :: (MonadSite m, SiteEnv m ~ App) + => LocalActorBy KeyHashid + -> ActorId + -> RecipientRoutes + -> [(Host, NonEmpty LocalURI)] + -> [Host] + -> OutboxItemId + -> AP.Action URIMode + -> ExceptT Text (ReaderT SqlBackend m) (Worker ()) +deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID action = do + moreRemoteRecips <- lift $ deliverLocal' True senderByHash senderActorID itemID localRecips + checkFederation moreRemoteRecips + remoteRecipsHttp <- lift $ deliverRemoteDB fwdHosts itemID remoteRecips moreRemoteRecips + envelope <- lift $ prepareSendP senderActorID senderByHash itemID action + return $ deliverRemoteHttp fwdHosts itemID envelope remoteRecipsHttp + where + checkFederation remoteRecips = do + federation <- asksSite $ appFederation . appSettings + unless (federation || null remoteRecips) $ + throwE "Federation disabled, but remote recipients found" + +forwardActivityDB + :: (MonadSite m, SiteEnv m ~ App) + => BL.ByteString + -> RecipientRoutes + -> ByteString + -> ActorId + -> LocalActorBy KeyHashid + -> RecipientRoutes + -> RemoteActivityId + -> ReaderT SqlBackend m (Worker ()) +forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID = do + let localRecipsFinal = localRecipSieve' sieve False False localRecips + remoteRecips <- + insertRemoteActivityToLocalInboxes False activityID localRecipsFinal + remoteRecipsHttp <- + forwardRemoteDB body activityID fwderActorID sig remoteRecips + errand <- prepareForwardP fwderActorID fwderByHash body sig + now <- liftIO getCurrentTime + return $ forwardRemoteHttp now errand remoteRecipsHttp diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 2c78a45..dc74a6c 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -78,6 +78,8 @@ module Web.ActivityPub , Undo (..) , Audience (..) , SpecificActivity (..) + , Action (..) + , makeActivity , Activity (..) -- * Utilities @@ -92,8 +94,13 @@ module Web.ActivityPub , hActivityPubForwarder , hForwardingSignature , hForwardedSignature - , httpPostAP - , httpPostAPBytes + , Envelope () + , Errand () + , sending + , retrying + , deliver + , forwarding + , forward , Fetched (..) , fetchAP , fetchAP_T @@ -115,6 +122,7 @@ import Control.Applicative ((<|>), optional) import Control.Exception (Exception, displayException, try) import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Writer (Writer) import Crypto.Hash hiding (Context) @@ -132,7 +140,7 @@ import Data.Proxy import Data.Semigroup (Endo, First (..)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8') -import Data.Time.Clock (UTCTime) +import Data.Time.Clock import Data.Traversable import Network.HTTP.Client hiding (Proxy, proxy) import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) @@ -152,6 +160,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Data.Vector as V import qualified Network.HTTP.Signature as S import qualified Text.Email.Parser as E @@ -1679,6 +1688,25 @@ data SpecificActivity u | ResolveActivity (Resolve u) | UndoActivity (Undo u) +data Action u = Action + { actionCapability :: Maybe (ObjURI u) + , actionSummary :: Maybe HTML + , actionAudience :: Audience u + , actionFulfills :: [ObjURI u] + , actionSpecific :: SpecificActivity u + } + +makeActivity :: LocalURI -> LocalURI -> Action u -> Activity u +makeActivity luId luActor Action{..} = Activity + { activityId = Just luId + , activityActor = luActor + , activityCapability = actionCapability + , activitySummary = actionSummary + , activityAudience = actionAudience + , activityFulfills = actionFulfills + , activitySpecific = actionSpecific + } + data Activity u = Activity { activityId :: Maybe LocalURI , activityActor :: LocalURI @@ -1855,62 +1883,168 @@ hForwardedSignature = "Forwarded-Signature" -- * Compute HTTP signature and add _Signature_ request header -- * Perform the POST request -- * Verify the response status is 2xx +{- httpPostAP :: (MonadIO m, UriMode u, ToJSON a) => Manager - -> ObjURI u -> NonEmpty HeaderName -> S.KeyId -> (ByteString -> S.Signature) -> Text - -> Maybe (Either (ObjURI u) ByteString) -> a + -> ObjURI u + -> Maybe (Either (ObjURI u) ByteString) -> m (Either APPostError (Response ())) -httpPostAP manager uri headers keyid sign uSender mfwd value = - httpPostAPBytes manager uri headers keyid sign uSender mfwd $ encode value +httpPostAP manager headers keyid sign uSender value = + httpPostAPBytes manager headers keyid sign uSender $ encode value +-} + +data ForwardMode u + = SendNoForward + | SendAllowForward LocalURI + | ForwardBy (ObjURI u) ByteString + +data Envelope u = Envelope + { envelopeKey :: RefURI u + , envelopeSign :: ByteString -> S.Signature + , envelopeHolder :: Maybe LocalURI + , envelopeBody :: BL.ByteString + } + +data Errand u = Errand + { errandKey :: RefURI u + , errandSign :: ByteString -> S.Signature + , errandHolder :: Bool + , errandFwder :: LocalURI + , errandBody :: BL.ByteString + , errandProof :: ByteString + } -- | Like 'httpPostAP', except it takes the object as a raw lazy -- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON. httpPostAPBytes :: (MonadIO m, UriMode u) => Manager - -> ObjURI u -> NonEmpty HeaderName - -> S.KeyId + -> RefURI u -> (ByteString -> S.Signature) - -> Text - -> Maybe (Either (ObjURI u) ByteString) + -> Maybe LocalURI -> BL.ByteString + -> ForwardMode u + -> ObjURI u -> m (Either APPostError (Response ())) -httpPostAPBytes manager uri headers keyid sign uSender mfwd body = +httpPostAPBytes manager headers ruKey@(RefURI hKey _) sign mluHolder body fwd uInbox@(ObjURI hInbox _) = liftIO $ runExceptT $ do - req <- requestFromURI $ uriFromObjURI uri + req <- requestFromURI $ uriFromObjURI uInbox let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body req' = setRequestCheckStatus $ consHeader hContentType typeActivityStreams2LD $ - consHeader hActivityPubActor (encodeUtf8 uSender) $ + maybe id (consHeader hActivityPubActor . TE.encodeUtf8 . renderObjURI . ObjURI hKey) mluHolder $ consHeader hDigest digest $ req { method = "POST" , requestBody = RequestBodyLBS body } - req'' <- tryExceptT APPostErrorSig $ signRequest headers Nothing keyid sign Nothing req' + keyid = S.KeyId $ TE.encodeUtf8 $ renderRefURI ruKey + now <- lift getCurrentTime + req'' <- except $ first APPostErrorSig $ signRequest headers Nothing keyid sign now req' req''' <- - case mfwd of - Nothing -> return req'' - Just (Left uRecip) -> - tryExceptT APPostErrorSig $ - signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign Nothing $ consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uRecip) req'' - Just (Right sig) -> + case fwd of + SendNoForward -> return req'' + SendAllowForward luRecip -> + except $ first APPostErrorSig $ + signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $ + consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req'' + ForwardBy uSender sig -> return $ consHeader hForwardedSignature sig $ - consHeader hActivityPubForwarder (encodeUtf8 uSender) + consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender) req'' tryExceptT APPostErrorHTTP $ httpNoBody req''' manager where consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r } tryExceptT adapt action = ExceptT $ first adapt <$> try action +sending + :: UriMode u + => LocalRefURI + -> (ByteString -> S.Signature) + -> Bool + -> ObjURI u + -> LocalURI + -> Action u + -> Envelope u +sending lruKey sign holder uActor@(ObjURI hActor luActor) luId action = + Envelope + { envelopeKey = RefURI hActor lruKey + , envelopeSign = sign + , envelopeHolder = guard holder >> Just luActor + , envelopeBody = encode $ Doc hActor $ makeActivity luId luActor action + } + +retrying + :: RefURI u + -> (ByteString -> S.Signature) + -> Maybe LocalURI + -> BL.ByteString + -> Envelope u +retrying = Envelope + +forwarding + :: LocalRefURI + -> (ByteString -> S.Signature) + -> Bool + -> ObjURI u + -> BL.ByteString + -> ByteString + -> Errand u +forwarding lruKey sign holder (ObjURI hFwder luFwder) body sig = + Errand + { errandKey = RefURI hFwder lruKey + , errandSign = sign + , errandHolder = holder + , errandFwder = luFwder + , errandBody = body + , errandProof = sig + } + +deliver + :: (MonadIO m, UriMode u) + => Manager + -> NonEmpty HeaderName + -> Envelope u + -> Maybe LocalURI + -> ObjURI u + -> m (Either APPostError (Response ())) +deliver manager headers (Envelope ruKey sign mluHolder body) mluFwd uInbox = + httpPostAPBytes + manager + headers + ruKey + sign + mluHolder + body + (maybe SendNoForward SendAllowForward mluFwd) + uInbox + +forward + :: (MonadIO m, UriMode u) + => Manager + -> NonEmpty HeaderName + -> Errand u + -> ObjURI u + -> m (Either APPostError (Response ())) +forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body sig) uInbox = + httpPostAPBytes + manager + headers + ruKey + sign + (guard holder >> Just luFwder) + body + (ForwardBy (ObjURI hKey luFwder) sig) + uInbox + -- | Result of GETing the keyId URI and processing the JSON document. data Fetched = Fetched { fetchedPublicKey :: PublicVerifKey diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index 02b3342..c346760 100644 --- a/src/Yesod/ActivityPub.hs +++ b/src/Yesod/ActivityPub.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -15,22 +15,33 @@ module Yesod.ActivityPub ( YesodActivityPub (..) + + , prepareToSend + , prepareToRetry , deliverActivity - , deliverActivityBL - , deliverActivityBL' + , deliverActivityExcept + , deliverActivityThrow + + , prepareToForward , forwardActivity + , forwardActivityExcept + , forwardActivityThrow + , redirectToPrettyJSON + , provideHtmlAndAP , provideHtmlAndAP' , provideHtmlAndAP'' , provideHtmlFeedAndAP + , hostIsLocal , verifyHostLocal ) where -import Control.Exception +import Control.Exception.Base import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Logger.CallStack import Control.Monad.Trans.Except import Control.Monad.Trans.Writer @@ -56,6 +67,8 @@ import qualified Data.Text as T import Network.HTTP.Signature +import qualified Network.HTTP.Signature as S + import Database.Persist.JSON import Network.FedURI import Web.ActivityPub @@ -63,18 +76,307 @@ import Yesod.FedURI import Yesod.MonadSite import Yesod.RenderSource +import qualified Web.ActivityPub as AP + class (Yesod site, SiteFedURI site) => YesodActivityPub site where siteInstanceHost :: site -> Authority (SiteFedURIMode site) sitePostSignedHeaders :: site -> NonEmpty HeaderName + {- siteGetHttpSign :: (MonadSite m, SiteEnv m ~ site) => m (KeyId, ByteString -> Signature) - {- siteSigVerRequiredHeaders :: site -> [HeaderName] siteSigVerWantedHeaders :: site -> [HeaderName] siteSigVerSeconds :: site -> Int -} -deliverActivity' +prepareToSend + :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u) + => Route site + -> (ByteString -> S.Signature) + -> Bool + -> Route site + -> Route site + -> AP.Action u + -> m (Envelope u) +prepareToSend keyR sign holder actorR idR action = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR + uActor = encodeRouteHome actorR + luId = encodeRouteLocal idR + return $ AP.sending lruKey sign holder uActor luId action + +prepareToRetry + :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u) + => Route site + -> (ByteString -> S.Signature) + -> Maybe (Route site) + -> BL.ByteString + -> m (Envelope u) +prepareToRetry keyR sign mHolderR body = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let ruKey = + let ObjURI h lu = encodeRouteHome keyR + in RefURI h $ LocalRefURI $ Left lu + mluHolder = encodeRouteLocal <$> mHolderR + return $ AP.retrying ruKey sign mluHolder body + +deliverActivity + :: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u + , YesodActivityPub site + , HasHttpManager site + ) + => Envelope u + -> Maybe LocalURI + -> ObjURI u + -> m (Either APPostError (Response ())) +deliverActivity envelope mluFwd uInbox = do + manager <- asksSite getHttpManager + headers <- asksSite sitePostSignedHeaders + AP.deliver manager headers envelope mluFwd uInbox + +deliverActivityExcept + :: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u + , YesodActivityPub site + , HasHttpManager site + ) + => Envelope u + -> Maybe LocalURI + -> ObjURI u + -> ExceptT APPostError m (Response ()) +deliverActivityExcept envelope mluFwd uInbox = + ExceptT $ deliverActivity envelope mluFwd uInbox + +deliverActivityThrow + :: ( MonadSite m, SiteEnv m ~ site, SiteFedURIMode site ~ u + , YesodActivityPub site + , HasHttpManager site + ) + => Envelope u + -> Maybe LocalURI + -> ObjURI u + -> m (Response ()) +deliverActivityThrow envelope mluFwd uInbox = do + result <- deliverActivity envelope mluFwd uInbox + case result of + Left e -> liftIO $ throwIO e + Right response -> return response + +prepareToForward + :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, SiteFedURIMode site ~ u) + => Route site + -> (ByteString -> S.Signature) + -> Bool + -> Route site + -> BL.ByteString + -> ByteString + -> m (Errand u) +prepareToForward keyR sign holder fwderR body sig = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR + uFwder = encodeRouteHome fwderR + return $ AP.forwarding lruKey sign holder uFwder body sig + +forwardActivity + :: ( MonadSite m, SiteEnv m ~ site + , SiteFedURI site, SiteFedURIMode site ~ u + , HasHttpManager site + , YesodActivityPub site + ) + => Errand u + -> ObjURI u + -> m (Either APPostError (Response ())) +forwardActivity errand uInbox = do + manager <- asksSite getHttpManager + headers <- asksSite sitePostSignedHeaders + AP.forward manager headers errand uInbox + +forwardActivityExcept + :: ( MonadSite m, SiteEnv m ~ site + , SiteFedURI site, SiteFedURIMode site ~ u + , HasHttpManager site + , YesodActivityPub site + ) + => Errand u + -> ObjURI u + -> ExceptT APPostError m (Response ()) +forwardActivityExcept errand uInbox = ExceptT $ forwardActivity errand uInbox + +forwardActivityThrow + :: ( MonadSite m, SiteEnv m ~ site + , SiteFedURI site, SiteFedURIMode site ~ u + , HasHttpManager site + , YesodActivityPub site + ) + => Errand u + -> ObjURI u + -> m (Response ()) +forwardActivityThrow errand uInbox = do + result <- forwardActivity errand uInbox + case result of + Left e -> liftIO $ throwIO e + Right response -> return response + +{- +-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign +-- it +data Envelope u = Envelope + { envelopeKey :: LocalRefURI + , envelopeSign :: ByteString -> S.Signature + , envelopeHolder :: Bool + , envelopeActor :: ObjURI u + , envelopeId :: LocalURI + , envelopeAction :: Action u + } +-} + +{- +-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign +-- it +data Envelope site = Envelope + { -- | Signing key's identifier URI + envelopeKey :: Route site + -- | Signing function, producing a signature for a given input + , envelopeSign :: ByteString -> Signature + -- | Whether the signing key is used for the whole instance, or a + -- personal key used only by one actor + , envelopeSharedKey :: Bool + -- | The actor signing and sending the activity + , envelopeActor :: Route site + -- | Activity's ID URI + , envelopeId :: Route site + -- | Activity document, just needing its actor and id to be filled in + , envelopeAction :: AP.Action (SiteFedURIMode site) + } +-} + +{- +prepareActivity + :: Route site + -> (ByteString -> S.Signature) + -> Bool + -> Route site + -> Route site + -> AP.Action u + -> m (Envelope u) +prepareActivity keyR sign holder actorR idR action = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR + uActor = encodeRouteHome actorR + luId = encodeRouteLocal idR + return $ Envelope lruKey sign holder uActor luId action + + return $ AP.send manager headers lruKey sign holder uActor luId action + +sendActivity + :: Envelope u + -> Maybe LocalURI + -> ObjURI u + -> m (Either AP.APPostError (Response ())) +sendActivity (Envelope lruKey sign holder uActor luId action) +-} + +{- +prepareSendActivity + :: ( MonadSite m + , SiteEnv m ~ site + , SiteFedURIMode site ~ u + , HasHttpManager site + , YesodActivityPub site + ) + => Route site + -> (ByteString -> S.Signature) + -> Bool + -> Route site + -> Route site + -> AP.Action u + -> m (Maybe LocalURI -> ObjURI u -> m (Either AP.APPostError (Response ()))) +prepareSendActivity keyR sign holder actorR idR action = do + manager <- asksSite getHttpManager + headers <- asksSite sitePostSignedHeaders + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR + uActor = encodeRouteHome actorR + luId = encodeRouteLocal idR + return $ AP.send manager headers lruKey sign holder uActor luId action + +resendActivity + :: ( MonadSite m + , SiteEnv m ~ site + , SiteFedURIMode site ~ u + , HasHttpManager site + , YesodActivityPub site + ) + => Route site + -> (ByteString -> S.Signature) + -> Maybe (Route site) + -> BL.ByteString + -> Maybe LocalURI + -> ObjURI u + -> m (Either AP.APPostError (Response ())) +resendActivity keyR sign mHolderR body mluFwd uInbox = do + manager <- asksSite getHttpManager + headers <- asksSite sitePostSignedHeaders + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let ruKey = + let ObjURI h lu = encodeRouteHome keyR + in RefURI h $ LocalRefURI $ Left lu + mluHolder = encodeRouteLocal <$> mHolderR + AP.resend manager headers ruKey sign mluHolder body mluFwd uInbox + +forwardActivity + :: ( MonadSite m + , SiteEnv m ~ site + , SiteFedURIMode site ~ u + , HasHttpManager site + , YesodActivityPub site + ) + -> Route site + -> (ByteString -> S.Signature) + -> Bool + -> Route site + -> BL.ByteString + -> ByteString + -> ObjURI u + -> m (Either APPostError (Response ())) +forwardActivity keyR sign holder fwderR body sig uInbox = do + manager <- asksSite getHttpManager + headers <- asksSite sitePostSignedHeaders + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR + uFwder = encodeRouteHome fwderR + AP.forward lruKey sign holder uFwder body sig uInbox +-} + +{- +data Stamp site = Stamp + { stampActor :: Route site + , stampKey :: Route site + , stampSign :: ByteString -> Signature + } + +-- | An 'AP.Activity' ready for sending, attached to an actor key ready to sign +-- it +data Envelope site = Envelope + { -- | Activity document, just needing its actor and id to be filled in + envelopeDoc :: AP.Action (SiteFedURIMode site) + -- | Activity's ID URI + , envelopeId :: Route site + -- | The actor signing and sending the activity + , envelopeActor :: Route site + -- | Signing key's identifier URI + , envelopeKey :: Route site + -- | Signing function, producing a signature for a given input + , envelopeSign :: ByteString -> Signature + } + +deliverActivityBL :: ( MonadSite m , SiteEnv m ~ site , SiteFedURIMode site ~ u @@ -83,13 +385,15 @@ deliverActivity' ) => ObjURI u -> Maybe (ObjURI u) - -> Text + -> Stamp -> BL.ByteString -> m (Either APPostError (Response ())) -deliverActivity' inbox mfwd sender body = do +deliverActivityBL inbox mfwd (Stamp actorR keyR sign) body = do manager <- asksSite getHttpManager headers <- asksSite sitePostSignedHeaders - (keyid, sign) <- siteGetHttpSign + (sender, keyid) <- do + renderUrl <- askUrlRender + return (renderUrl actorR, KeyId $ renderUrl keyR) result <- httpPostAPBytes manager inbox headers keyid sign sender (Left <$> mfwd) body @@ -115,48 +419,24 @@ deliverActivity ) => ObjURI u -> Maybe (ObjURI u) - -> Doc Activity u + -> Envelope site -> m (Either APPostError (Response ())) -deliverActivity inbox mfwd doc@(Doc hAct activity) = - let sender = renderObjURI $ ObjURI hAct (activityActor activity) - body = encode doc - in deliverActivity' inbox mfwd sender body +deliverActivity inbox mfwd (Envelope action idR actorR keyR sign) = do + encodeRouteLocal <- getEncodeRouteLocal + hLocal <- asksSite siteInstanceHost + let body = + encode $ Doc hLocal $ + makeActivity + (encodeRouteLocal idR) (encodeRouteLocal actorR) action + deliverActivityBL inbox mfwd (Stamp actorR keyR sign) body -deliverActivityBL - :: ( MonadSite m - , SiteEnv m ~ site - , SiteFedURIMode site ~ u - , HasHttpManager site - , YesodActivityPub site - ) - => ObjURI u - -> Maybe (ObjURI u) - -> Route site - -> BL.ByteString - -> m (Either APPostError (Response ())) -deliverActivityBL inbox mfwd senderR body = do - renderUrl <- askUrlRender - let sender = renderUrl senderR - deliverActivity' inbox mfwd sender body - -deliverActivityBL' - :: ( MonadSite m - , SiteEnv m ~ site - , SiteFedURIMode site ~ u - , HasHttpManager site - , YesodActivityPub site - ) - => ObjURI u - -> Maybe (ObjURI u) - -> BL.ByteString - -> m (Either APPostError (Response ())) -deliverActivityBL' inbox mfwd body = do - sender <- - case M.lookup ("actor" :: Text) =<< decode body of - Just (String t) -> return t - _ -> - liftIO $ throwIO $ userError "Couldn't extract actor from body" - deliverActivity' inbox mfwd sender body +data Errand site = Errand + { errandDoc :: BL.ByteString + , errandProof :: ByteString + , errandActor :: Route site + , errandKey :: Route site + , errandSign :: ByteString -> Signature + } forwardActivity :: ( MonadSite m @@ -166,18 +446,16 @@ forwardActivity , YesodActivityPub site ) => ObjURI u - -> ByteString - -> Route site - -> BL.ByteString + -> Errand site -> m (Either APPostError (Response ())) -forwardActivity inbox sig rSender body = do +forwardActivity inbox (Errand doc sig actorR keyR sign) = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome manager <- asksSite getHttpManager headers <- asksSite sitePostSignedHeaders - (keyid, sign) <- siteGetHttpSign - renderUrl <- askUrlRender - let sender = renderUrl rSender - result <- - httpPostAPBytes manager inbox headers keyid sign sender (Just $ Right sig) body + let uActor = encodeRouteHome actorR + lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR + result <- AP.forward manager headers uActor lruKey sign doc inbox sig case result of Left err -> logError $ T.concat @@ -190,6 +468,7 @@ forwardActivity inbox sig rSender body = do , "> success: ", T.pack $ show $ responseStatus resp ] return result +-} redirectToPrettyJSON :: (MonadHandler m, HandlerSite m ~ site) => Route site -> m a diff --git a/th/models b/th/models index 8bd7646..046b5ce 100644 --- a/th/models +++ b/th/models @@ -118,6 +118,12 @@ Actor UniqueActorOutbox outbox UniqueActorFollowers followers +SigKey + actor ActorId + material ActorKey + + UniqueSigKey actor + Person username Username login Text @@ -161,40 +167,11 @@ Forwarding activity RemoteActivityId activityRaw ByteString signature ByteString + forwarder ActorId running Bool UniqueForwarding recipient activity -ForwarderPerson - task ForwardingId - sender PersonId - - UniqueForwarderPerson task - -ForwarderGroup - task ForwardingId - sender GroupId - - UniqueForwarderGroup task - -ForwarderRepo - task ForwardingId - sender RepoId - - UniqueForwarderRepo task - -ForwarderLoom - task ForwardingId - sender LoomId - - UniqueForwarderLoom task - -ForwarderDeck - task ForwardingId - sender DeckId - - UniqueForwarderDeck task - -- ========================================================================= -- -- ========================================================================= -- diff --git a/th/routes b/th/routes index 8c850c0..89d89da 100644 --- a/th/routes +++ b/th/routes @@ -150,6 +150,8 @@ /reply/#MessageKeyHashid ReplyR POST +/people/#PersonKeyHashid/stamps/#SigKeyKeyHashid PersonStampR GET + ---- Group ------------------------------------------------------------------ /groups/#GroupKeyHashid GroupR GET @@ -158,6 +160,8 @@ /groups/#GroupKeyHashid/outbox/#OutboxItemKeyHashid GroupOutboxItemR GET /groups/#GroupKeyHashid/followers GroupFollowersR GET +/groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid GroupStampR GET + ---- Repo -------------------------------------------------------------------- /repos/#RepoKeyHashid RepoR GET @@ -186,6 +190,8 @@ /repos/#RepoKeyHashid/enable-loom/#LoomKeyHashid RepoLinkR POST +/repos/#RepoKeyHashid/stamps/#SigKeyKeyHashid RepoStampR GET + ---- Deck -------------------------------------------------------------------- /decks/#DeckKeyHashid DeckR GET @@ -203,6 +209,8 @@ /decks/#DeckKeyHashid/follow DeckFollowR POST /decks/#DeckKeyHashid/unfollow DeckUnfollowR POST +/decks/#DeckKeyHashid/stamps/#SigKeyKeyHashid DeckStampR GET + ---- Ticket ------------------------------------------------------------------ /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid TicketR GET @@ -248,6 +256,8 @@ /looms/#LoomKeyHashid/follow LoomFollowR POST /looms/#LoomKeyHashid/unfollow LoomUnfollowR POST +/looms/#LoomKeyHashid/stamps/#SigKeyKeyHashid LoomStampR GET + ---- Cloth ------------------------------------------------------------------- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid ClothR GET diff --git a/vervis.cabal b/vervis.cabal index 03c0298..6f5b0ae 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -46,6 +46,7 @@ library Control.Concurrent.Local Control.Concurrent.ResultShare Control.Monad.Trans.Except.Local + Crypto.ActorKey Crypto.PubKey.Encoding Crypto.PublicVerifKey Darcs.Local.Repository @@ -127,7 +128,6 @@ library Vervis.Access Vervis.ActivityPub - Vervis.ActorKey Vervis.API Vervis.Avatar Vervis.BinaryBody @@ -144,7 +144,6 @@ library Vervis.Data.Collab Vervis.Data.Ticket - Vervis.Delivery Vervis.Discussion --Vervis.Federation Vervis.Federation.Auth @@ -231,6 +230,7 @@ library Vervis.Web.Actor Vervis.Web.Darcs + Vervis.Web.Delivery Vervis.Web.Discussion Vervis.Web.Git Vervis.Web.Repo