From 9e0314fa09e31e8344d78462c448caf681a72c5e Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 14 Feb 2019 23:27:40 +0000 Subject: [PATCH] Store remote actors' inbox URIs in DB, avoiding some actor fetch When a local user wants to publish an activity, we were always GETing the recipient actor, so that we could determine their inbox and POST the activity to it. But now, instead, whenever we GET an actor (whether it's for the key sig verification or for determining inbox URI), we keep their inbox URI in the database, and we don't need to GET it again next time. --- config/models | 1 + migrations/2019_02_03_verifkey.model | 1 + src/Vervis/Foundation.hs | 27 ++++++------ src/Vervis/Handler/Inbox.hs | 63 ++++++++++++++++++---------- src/Web/ActivityPub.hs | 3 ++ 5 files changed, 59 insertions(+), 36 deletions(-) diff --git a/config/models b/config/models index c601890..2b4c450 100644 --- a/config/models +++ b/config/models @@ -51,6 +51,7 @@ VerifKey RemoteSharer ident FedURI instance InstanceId + inbox FedURI UniqueRemoteSharer ident diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index 113b886..4070d79 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -10,6 +10,7 @@ VerifKey RemoteSharer ident Text instance InstanceId + inbox Text UniqueRemoteSharer ident diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index c075e97..06d56f3 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -22,6 +22,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) +import Data.Either (isRight) import Data.Maybe (fromJust) import Data.PEM (pemContent) import Data.Text.Encoding (decodeUtf8') @@ -593,7 +594,7 @@ instance YesodHttpSig App where t <- first displayException $ decodeUtf8' b parseFedURI t _ -> throwE "Multiple ActivityPub-Actor headers" - (mvkid, key, mexpires, uActor, host, shared) <- do + (inboxOrVkid, key, mexpires, uActor, host, shared) <- do ments <- lift $ runDB $ do mvk <- getBy $ UniqueVerifKey u for mvk $ \ vk@(Entity _ verifkey) -> do @@ -610,7 +611,7 @@ instance YesodHttpSig App where Just u -> return (u, True) let uKey = verifKeyIdent vk return - ( Just vkid + ( Right vkid , verifKeyPublic vk , verifKeyExpires vk , ua @@ -618,12 +619,12 @@ instance YesodHttpSig App where , s ) Nothing -> do - Fetched k mexp ua h s <- fetchKey' muActorHeader u - return (Nothing, k, mexp, ua, h, s) + Fetched k mexp ua uinb h s <- fetchKey' muActorHeader u + return (Left uinb, k, mexp, ua, h, s) let verify' k = verify k input signature errSig = throwE "Ed25519 sig verification says not valid" errTime = throwE "Key expired" - existsInDB = isJust mvkid + existsInDB = isRight inboxOrVkid now <- liftIO getCurrentTime let stillValid Nothing = True stillValid (Just expires) = expires > now @@ -632,7 +633,7 @@ instance YesodHttpSig App where then return (not existsInDB, key, mexpires) else if existsInDB then do - Fetched newKey newExp newActor h s <- fetchKey' muActorHeader u + Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader u if shared == s then return () else throwE "Key scope changed, we reject that" @@ -653,8 +654,8 @@ instance YesodHttpSig App where then errSig else errTime when write $ ExceptT $ runDB $ - case mvkid of - Nothing -> + case inboxOrVkid of + Left inbox -> if shared then do ment <- getBy $ UniqueInstance host @@ -674,12 +675,8 @@ instance YesodHttpSig App where ment <- getBy $ UniqueRemoteSharer uActor case ment of Nothing -> do - iid <- do - ment2 <- getBy $ UniqueInstance host - case ment2 of - Nothing -> insert $ Instance host - Just (Entity i _) -> return i - rsid <- insert $ RemoteSharer uActor iid + iid <- either entityKey id <$> insertBy (Instance host) + rsid <- insert $ RemoteSharer uActor iid inbox insert_ $ VerifKey u iid mexpires' key' (Just rsid) return $ Right () Just (Entity rsid rs) -> do @@ -690,7 +687,7 @@ instance YesodHttpSig App where insert_ $ VerifKey u iid mexpires' key' (Just rsid) return $ Right () else return $ Left "We already store 2 keys" - Just vkid -> do + Right vkid -> do update vkid [VerifKeyExpires =. mexpires', VerifKeyPublic =. key'] return $ Right () diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index c7b8a03..b507154 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -35,6 +35,7 @@ import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) import Data.Aeson import Data.Bifunctor (first, second) +import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..)) import Data.PEM (PEM (..)) @@ -44,7 +45,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Interval (TimeInterval, toTimeUnit) import Data.Time.Units (Second) -import Database.Persist (Entity (..)) +import Database.Persist (Entity (..), getBy, insertBy, insert_) import Network.HTTP.Client (Manager, HttpException, requestFromURI) import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader) import Network.HTTP.Types.Header (hDate, hHost) @@ -229,27 +230,47 @@ postOutboxR = do } } manager <- getsYesod appHttpManager - eres <- httpGetAP manager to - case eres of - Left (APGetErrorHTTP e) -> setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e) - Left (APGetErrorJSON e) -> setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e) - Left (APGetErrorContentType e) -> setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e - Right response -> do - let actor = getResponseBody response - if actorId actor /= to - then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched" - else do - (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys - let (keyID, akey) = - if new1 - then (renderUrl ActorKey1R, akey1) - else (renderUrl ActorKey2R, akey2) - sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) - eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity - case eres' of - Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e) - Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result." + minbox <- fetchInboxURI manager to + for_ minbox $ \ inbox -> do + (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys + let (keyID, akey) = + if new1 + then (renderUrl ActorKey1R, akey1) + else (renderUrl ActorKey2R, akey2) + sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) + eres' <- httpPostAP manager inbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity + case eres' of + Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e) + Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result." defaultLayout $ activityWidget widget enctype + where + fetchInboxURI :: Manager -> FedURI -> Handler (Maybe FedURI) + fetchInboxURI manager to = do + mrs <- runDB $ getBy $ UniqueRemoteSharer to + case mrs of + Nothing -> do + eres <- httpGetAP manager to + case eres of + Left (APGetErrorHTTP e) -> do + setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e) + return Nothing + Left (APGetErrorJSON e) -> do + setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e) + return Nothing + Left (APGetErrorContentType e) -> do + setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e + return Nothing + Right response -> do + let actor = getResponseBody response + if actorId actor /= to + then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched" >> return Nothing + else do + let inbox = actorInbox actor + runDB $ do + iid <- either entityKey id <$> insertBy (Instance $ furiHost to) + insert_ $ RemoteSharer to iid inbox + return $ Just inbox + Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent getActorKey choose route = do diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 59ba0b5..edde43b 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -390,6 +390,8 @@ data Fetched = Fetched -- ^ Optional expiration time declared for the key we received. , fetchedActorId :: FedURI -- ^ The @id URI of the actor for whom the key's signature applies. + , fetchedActorInbox :: FedURI + -- ^ The inbox URI of the actor for whom the key's signature applies. , fetchedHost :: Text -- ^ The domain name of the instance from which we got the key. , fetchedKeyShared :: Bool @@ -484,6 +486,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do { fetchedPublicKey = k , fetchedKeyExpires = publicKeyExpires pkey , fetchedActorId = actorId actor + , fetchedActorInbox = actorInbox actor , fetchedHost = furiHost uKey , fetchedKeyShared = shared }