When verifying HTTP sig with known shared key, verify actor lists the key

Previously, when verifying an HTTP signature and we fetched the key and
discovered it's shared, we'd fetch the actor and make sure it lists the key URI
in the `publicKey` field. But if we already knew the key, had it cached in our
DB, we wouldn't check the actor at all, despite not knowing whether it lists
the key.

With this patch, we now always GET the actor when the key is shared,
determining the actor URI from the `ActivityPub-Actor` request header, and we
verify that the actor lists the key URI. We do that regardless of whether or
not we have the key in the DB, although these two cases and handled in
different parts of the code right now (for a new key, it's in Web.ActivityPub
fetchKey; for a known key, it's in Vervis.Foundation httpVerifySig).

src/Vervis/Foundation.hs

@@ -705,10 +705,14 @@ instance YesodHttpSig App where
                                         then return ()
                                         else throwE "Key's owner doesn't match actor header"
                                 return (sharer, False)
-                            Nothing ->
+                            Nothing -> do
-                                case muActorHeader of
+                                ua <- case muActorHeader of
                                     Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
-                                    Just u -> return (u, True)
+                                    Just u -> return u
+                                _ <- do
+                                    manager <- getsYesod appHttpManager
+                                    ExceptT $ keyListedByActor manager uKey ua
+                                return (ua, True)
                     return VerifKeyDetail
                         { vkdKeyId     = uKey
                         , vkdInboxOrId = Right vkid

src/Web/ActivityPub.hs

@@ -36,6 +36,7 @@ module Web.ActivityPub
     , httpGetAP
     , httpPostAP
     , Fetched (..)
+    , keyListedByActor
     , fetchKey
     )
 where
@@ -404,6 +405,25 @@ data Fetched = Fetched
       --   we received.
     }
 
+-- | Fetches the given actor and checks whether it lists the given key (as a
+-- URI, not as an embedded object). If it does, returns 'Right' the fetched
+-- actor. Otherwise, or if an error occurs during fetching, returns 'Left' an
+-- error message.
+keyListedByActor :: MonadIO m => Manager -> FedURI -> FedURI -> m (Either String Actor)
+keyListedByActor manager uKey uActor = runExceptT $ do
+    let fetch :: (MonadIO m, FromJSON a) => FedURI -> ExceptT String m a
+        fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
+    actor <- fetch uActor
+    if keyUriListed uKey actor
+        then return actor
+        else throwE "Actor publicKey has no URI matching pkey @id"
+    where
+    keyUriListed uk a =
+        let PublicKeySet k1 mk2 = actorPublicKeys a
+            match (Left uri) = uri == uk
+            match (Right _)  = False
+        in  match k1 || maybe False match mk2
+
 fetchKey
     :: MonadIO m
     => Manager
@@ -416,7 +436,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
         fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
     obj <- fetch uKey
     let inztance = uKey { furiPath = "", furiFragment = "" }
-    (actor, pkey, shared) <-
+    (actor, pkey) <-
         case obj of
             Left' pkey -> do
                 if publicKeyId pkey == uKey
@@ -437,13 +457,8 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
                                     then return ()
                                     else throwE "Key's owner doesn't match actor header"
                             return owner
-                actor <- fetch uActor
+                actor <- ExceptT $ keyListedByActor manager uKey uActor
-                let PublicKeySet k1 mk2 = actorPublicKeys actor
+                return (actor, pkey)
-                    match (Left uri) = uri == uKey
-                    match (Right _)  = False
-                if match k1 || maybe False match mk2
-                    then return (actor, pkey, publicKeyShared pkey)
-                    else throwE "Actor publicKey has no URI matching pkey @id"
             Right' actor -> do
                 if actorId actor == uKey { furiFragment = "" }
                     then return ()
@@ -463,9 +478,9 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
                     Just pk ->
                         if publicKeyShared pk
                             then throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
-                            else return (actor, pk, False)
+                            else return (actor, pk)
     ExceptT . pure $ do
-        if shared
+        if publicKeyShared pkey
             then if publicKeyOwner pkey == inztance
                     then Right ()
                     else Left "Key is shared but its owner isn't the top-level instance URI"
@@ -493,6 +508,6 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
                 , fetchedActorId    = actorId actor
                 , fetchedActorInbox = actorInbox actor
                 , fetchedHost       = furiHost uKey
-                , fetchedKeyShared  = shared
+                , fetchedKeyShared  = publicKeyShared pkey
                 }
             CryptoFailed _ -> Left "Parsing Ed25519 public key failed"