Allow other servers to do blind key rotation by re-fetching if sig is invalid
This commit is contained in:
parent
b0b2aa83c5
commit
8db38c087f
1 changed files with 61 additions and 46 deletions
|
@ -18,7 +18,7 @@ module Vervis.Foundation where
|
||||||
import Prelude (init, last)
|
import Prelude (init, last)
|
||||||
|
|
||||||
import Control.Monad.Logger.CallStack (logWarn)
|
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 Control.Monad.Trans.Maybe
|
||||||
import Crypto.Error (CryptoFailable (..))
|
import Crypto.Error (CryptoFailable (..))
|
||||||
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
|
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
|
||||||
|
@ -576,12 +576,36 @@ instance YesodHttpSig App where
|
||||||
u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
|
u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
|
||||||
Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
|
Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
|
||||||
Just uri -> Right 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 = "" }
|
let uActor = u { uriFragment = "" }
|
||||||
(fromDB, key) <- do
|
(mvkid, key) <- do
|
||||||
ment <- lift $ runDB $ getBy $ UniqueVerifKey u
|
ment <- lift $ runDB $ getBy $ UniqueVerifKey u
|
||||||
case ment of
|
case ment of
|
||||||
Just (Entity _ vk) -> return (True, verifKeyPublic vk)
|
Just (Entity vkid vk) -> return (Just vkid, verifKeyPublic vk)
|
||||||
Nothing -> do
|
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
|
manager <- getsYesod appHttpManager
|
||||||
actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
|
actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
|
||||||
ExceptT . pure $ do
|
ExceptT . pure $ do
|
||||||
|
@ -613,17 +637,8 @@ instance YesodHttpSig App where
|
||||||
Nothing -> "No algo in Sig, unsupported algo in actor"
|
Nothing -> "No algo in Sig, unsupported algo in actor"
|
||||||
Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
|
Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
|
||||||
case publicKey $ pemContent $ publicKeyPem pkey of
|
case publicKey $ pemContent $ publicKeyPem pkey of
|
||||||
CryptoPassed k -> Right (False, k)
|
CryptoPassed k -> Right k
|
||||||
CryptoFailed e -> Left "Parsing Ed25519 public key failed"
|
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
|
instance YesodBreadcrumbs App where
|
||||||
breadcrumb route = return $ case route of
|
breadcrumb route = return $ case route of
|
||||||
|
|
Loading…
Reference in a new issue