Allow other servers to do blind key rotation by re-fetching if sig is invalid
This commit is contained in:
fr33domlover
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 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 = "" }
|
||||
(fromDB, key) <- do
|
||||
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
|
||||
signature <- ExceptT . pure $ do
|
||||
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
|
||||
let uActor = u { uriFragment = "" }
|
||||
(mvkid, key) <- do
|
||||
ment <- lift $ runDB $ getBy $ UniqueVerifKey u
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue