When receiving HTTP signed request, check the keyId host for weird cases

- Exclude hosts without periods, so things like localhost and IPv6 are rejected
- Exclude hosts without letters, so things like IPv4 are rejected
- Exclude the instance's own host, just in case somehow some fake activity
  slips in and gets approved, maybe even accidentally when delivered by another
  server

src/Vervis/Foundation.hs

@@ -25,6 +25,7 @@ import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Crypto.Error (CryptoFailable (..))
 import Crypto.PubKey.Ed25519 (PublicKey, publicKey, signature, verify)
+import Data.Char
 import Data.Either (isRight)
 import Data.HashMap.Strict (HashMap)
 import Data.Maybe (fromJust)
@@ -52,7 +53,7 @@ import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.HashMap.Strict as M (lookup, insert)
 import qualified Yesod.Core.Unsafe as Unsafe
 --import qualified Data.CaseInsensitive as CI
-import Data.Text as T (pack, intercalate, concat)
+import qualified Data.Text as T
 --import qualified Data.Text.Encoding as TE
 
 import Network.HTTP.Signature hiding (Algorithm (..))
@@ -621,6 +622,7 @@ instance YesodHttpSig App where
         toSeconds = toTimeUnit
     httpVerifySig (Verification malgo (KeyId keyid) input (Signature signature)) = fmap HttpSigVerResult $ runExceptT $ do
         (host, luKey) <- f2l <$> parseKeyId keyid
+        checkHost host
         mluActorHeader <- getActorHeader host
         manager <- getsYesod appHttpManager
         (inboxOrVkid, vkd) <- do
@@ -702,6 +704,16 @@ instance YesodHttpSig App where
             case parseFedURI =<< (first displayException . decodeUtf8') k of
                 Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e
                 Right u -> return u
+        checkHost h = do
+            unless (T.any (== '.') h) $
+                throwE "Host doesn't contain periods"
+            unless (T.any isAsciiLetter h) $
+                throwE "Host doesn't contain ASCII letters"
+            home <- getsYesod $ appInstanceHost . appSettings
+            when (h == home) $
+                throwE "Received HTTP signed request from the instance's host"
+            where
+            isAsciiLetter c = isAsciiLower c || isAsciiUpper c
         getActorHeader host = do
             bs <- lookupHeaders hActivityPubActor
             case bs of