diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 91f2ddb..70f4ee4 100644 --- a/src/Vervis/Foundation.hs +++ b/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 = "" } - (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