Allow other servers to do blind key rotation by re-fetching if sig is invalid

src/Vervis/Foundation.hs

@@ -18,7 +18,7 @@ module Vervis.Foundation where
 import Prelude (init, last)
 
 import Control.Monad.Logger.CallStack (logWarn)
-import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
+import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Crypto.Error (CryptoFailable (..))
 import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
@@ -576,12 +576,36 @@ instance YesodHttpSig App where
         u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
             Nothing  -> Left "keyId in Sig header isn't a valid absolute URI"
             Just uri -> Right uri
+        signature <- ExceptT . pure $ do
+            case signature sig of
+                CryptoPassed s -> Right s
+                CryptoFailed e -> Left "Parsing Ed25519 signature failed"
         let uActor = u { uriFragment = "" }
-        (fromDB, key) <- do
+        (mvkid, key) <- do
             ment <- lift $ runDB $ getBy $ UniqueVerifKey u
             case ment of
-                Just (Entity _ vk) -> return (True, verifKeyPublic vk)
-                Nothing -> do
+                Just (Entity vkid vk) -> return (Just vkid, verifKeyPublic vk)
+                Nothing -> (,) Nothing <$> fetchKey u uActor
+        let verify' k = verify k input signature
+            err = throwE "Ed25519 sig verification says not valid"
+            existsInDB = isJust mvkid
+        (write, key') <-
+            if verify' key
+                then return (not existsInDB, key)
+                else if existsInDB
+                    then do
+                        newKey <- fetchKey u uActor
+                        if verify' newKey
+                            then return (True, newKey)
+                            else err
+                    else err
+        when write $ lift $ runDB $
+            case mvkid of
+                Nothing   -> insert_ $ VerifKey u key'
+                Just vkid -> update vkid [VerifKeyPublic =. key']
+        return uActor
+        where
+        fetchKey u uActor = do
             manager <- getsYesod appHttpManager
             actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
             ExceptT . pure $ do
@@ -613,17 +637,8 @@ instance YesodHttpSig App where
                                     Nothing -> "No algo in Sig, unsupported algo in actor"
                                     Just _  -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
                 case publicKey $ pemContent $ publicKeyPem pkey of
-                            CryptoPassed k -> Right (False, k)
+                    CryptoPassed k -> Right k
                     CryptoFailed e -> Left "Parsing Ed25519 public key failed"
-        ExceptT . pure $ do
-            signature <- case signature sig of
-                CryptoPassed s -> Right s
-                CryptoFailed e -> Left "Parsing Ed25519 signature failed"
-            if verify key input signature
-                then Right ()
-                else Left "Ed25519 sig verification says not valid"
-        unless fromDB $ lift $ runDB $ insert_ $ VerifKey u key
-        return uActor
 
 instance YesodBreadcrumbs App where
     breadcrumb route = return $ case route of