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,54 +576,69 @@ 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
-        let uActor = u { uriFragment = "" }
+        signature <- ExceptT . pure $ do
-        (fromDB, key) <- do
+            case signature sig of
-            ment <- lift $ runDB $ getBy $ UniqueVerifKey u
-            case ment of
-                Just (Entity _ vk) -> return (True, verifKeyPublic vk)
-                Nothing -> do
-                    manager <- getsYesod appHttpManager
-                    actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
-                    ExceptT . pure $ do
-                        if uActor == actorId actor
-                            then Right ()
-                            else Left "Actor ID doesn't match the keyid URI we fetched"
-                        let pkey = actorPublicKey actor
-                        if publicKeyShared pkey
-                            then Left "Actor's publicKey is shared, we're rejecting it!"
-                            else Right ()
-                        if publicKeyId pkey == u
-                            then Right ()
-                            else Left "Actor's publicKey's ID doesn't match the keyid URI"
-                        if publicKeyOwner pkey == actorId actor
-                            then Right ()
-                            else Left "Actor's publicKey's owner doesn't match the actor's ID"
-                        case publicKeyAlgo pkey of
-                            Nothing ->
-                                Left $
-                                case malgo of
-                                    Nothing -> "Algo not given in Sig nor actor"
-                                    Just _  -> "Algo mismatch, Ed25519 in Sig but none in actor"
-                            Just algo ->
-                                case algo of
-                                    AlgorithmEd25519 -> Right ()
-                                    AlgorithmOther _ ->
-                                        Left $
-                                        case malgo of
-                                            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)
-                            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
+        let uActor = u { uriFragment = "" }
-                then Right ()
+        (mvkid, key) <- do
-                else Left "Ed25519 sig verification says not valid"
+            ment <- lift $ runDB $ getBy $ UniqueVerifKey u
-        unless fromDB $ lift $ runDB $ insert_ $ VerifKey u key
+            case ment of
+                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
+                if uActor == actorId actor
+                    then Right ()
+                    else Left "Actor ID doesn't match the keyid URI we fetched"
+                let pkey = actorPublicKey actor
+                if publicKeyShared pkey
+                    then Left "Actor's publicKey is shared, we're rejecting it!"
+                    else Right ()
+                if publicKeyId pkey == u
+                    then Right ()
+                    else Left "Actor's publicKey's ID doesn't match the keyid URI"
+                if publicKeyOwner pkey == actorId actor
+                    then Right ()
+                    else Left "Actor's publicKey's owner doesn't match the actor's ID"
+                case publicKeyAlgo pkey of
+                    Nothing ->
+                        Left $
+                        case malgo of
+                            Nothing -> "Algo not given in Sig nor actor"
+                            Just _  -> "Algo mismatch, Ed25519 in Sig but none in actor"
+                    Just algo ->
+                        case algo of
+                            AlgorithmEd25519 -> Right ()
+                            AlgorithmOther _ ->
+                                Left $
+                                case malgo of
+                                    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 k
+                    CryptoFailed e -> Left "Parsing Ed25519 public key failed"
 
 instance YesodBreadcrumbs App where
     breadcrumb route = return $ case route of