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

@@ -51,6 +51,7 @@ VerifKey
 RemoteSharer
     ident    FedURI
     instance InstanceId
+    inbox    FedURI
 
     UniqueRemoteSharer ident
 

migrations/2019_02_03_verifkey.model

@@ -10,6 +10,7 @@ VerifKey
 RemoteSharer
     ident    Text
     instance InstanceId
+    inbox    Text
 
     UniqueRemoteSharer ident
 

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
+                    Fetched k mexp ua uinb h s <- fetchKey' muActorHeader u
-                    return (Nothing, k, mexp, ua, h, s)
+                    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
+            case inboxOrVkid of
-                Nothing ->
+                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
+                                    iid <- either entityKey id <$> insertBy (Instance host)
-                                        ment2 <- getBy $ UniqueInstance host
+                                    rsid <- insert $ RemoteSharer uActor iid inbox
-                                        case ment2 of
-                                            Nothing -> insert $ Instance host
-                                            Just (Entity i _) -> return i
-                                    rsid <- insert $ RemoteSharer uActor iid
                                     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 ()

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
+            minbox <- fetchInboxURI manager to
-            case eres of
+            for_ minbox $ \ inbox -> do
-                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
+                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

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
                 }