From bf56ebf15877d496fea16896ffffa16768cc9de8 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 16 Feb 2019 21:47:58 +0000 Subject: [PATCH] Make the verification key update logic clearer --- src/Vervis/Foundation.hs | 206 ++++++++++++++++++++++++++------------- 1 file changed, 139 insertions(+), 67 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 06d56f3..1d563ab 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -21,7 +21,7 @@ import Control.Monad.Logger.CallStack (logWarn) import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Crypto.Error (CryptoFailable (..)) -import Crypto.PubKey.Ed25519 (publicKey, signature, verify) +import Crypto.PubKey.Ed25519 (PublicKey, publicKey, signature, verify) import Data.Either (isRight) import Data.Maybe (fromJust) import Data.PEM (pemContent) @@ -59,7 +59,7 @@ import Yesod.Mail.Send import qualified Network.HTTP.Signature as S (Algorithm (..)) import Network.FedURI -import Web.ActivityPub +import Web.ActivityPub hiding (PublicKey) import Text.Email.Local import Text.Jasmine.Local (discardm) @@ -564,6 +564,100 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding +data AddVerifKey = AddVerifKey + { addvkHost :: Text + , addvkKeyId :: FedURI + , addvkExpires :: Maybe UTCTime + , addvkKey :: PublicKey + } + +addSharedKey :: AddVerifKey -> AppDB (Maybe String) +addSharedKey (AddVerifKey host uKey mexpires key) = do + (iid, new) <- idAndNew <$> insertBy (Instance host) + room <- + if new + then pure True + else + (< 2) <$> + count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] + if room + then do + insert_ $ VerifKey uKey iid mexpires key Nothing + return Nothing + else return $ Just "We already store 2 keys" + where + idAndNew (Left (Entity iid _)) = (iid, False) + idAndNew (Right iid) = (iid, True) + +data AddPersonalKey = AddPersonalKey + { addpkKey :: AddVerifKey + , addpkActorId :: FedURI + , addpkActorInbox :: FedURI + } + +addPersonalKey :: AddPersonalKey -> AppDB (Maybe String) +addPersonalKey (AddPersonalKey avk uActor uInbox) = do + let AddVerifKey host uKey mexpires key = avk + (iid, rsid, new) <- do + mrs <- getBy $ UniqueRemoteSharer uActor + case mrs of + Nothing -> do + iid <- either entityKey id <$> insertBy (Instance host) + rsid <- insert $ RemoteSharer uActor iid uInbox + return (iid, rsid, True) + Just (Entity rsid rs) -> + return (remoteSharerInstance rs, rsid, False) + room <- + if new + then pure True + else (< 2) <$> count [VerifKeySharer ==. Just rsid] + if room + then do + insert_ $ VerifKey uKey iid mexpires key (Just rsid) + return Nothing + else return $ Just "We already store 2 keys" + +data UpdateVerifKey = UpdateVerifKey + { updvkId :: VerifKeyId + , updvkExpires :: Maybe UTCTime + , updvkKey :: PublicKey + } + +updateVerifKey :: UpdateVerifKey -> AppDB (Maybe String) +updateVerifKey (UpdateVerifKey vkid mexpires key) = do + update vkid [VerifKeyExpires =. mexpires, VerifKeyPublic =. key] + return Nothing + +data VerifKeyUpdate + = VKUAddSharedKey AddVerifKey + | VKUAddPersonalKey AddPersonalKey + | VKUUpdateKey UpdateVerifKey + +updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String) +updateVerifKeyInDB (VKUAddSharedKey avk) = addSharedKey avk +updateVerifKeyInDB (VKUAddPersonalKey apk) = addPersonalKey apk +updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk + +data VerifKeyDetail = VerifKeyDetail + { vkdKeyId :: FedURI + , vkdInboxOrId :: Either FedURI VerifKeyId + , vkdKey :: PublicKey + , vkdExpires :: Maybe UTCTime + , vkdActorId :: FedURI + , vkdHost :: Text + , vkdShared :: Bool + } + +makeVerifKeyUpdate :: VerifKeyDetail -> VerifKeyUpdate +makeVerifKeyUpdate (VerifKeyDetail uKey iori key mexpires uActor host shared) = + case iori of + Left uInbox -> + let avk = AddVerifKey host uKey mexpires key + in if shared + then VKUAddSharedKey avk + else VKUAddPersonalKey $ AddPersonalKey avk uActor uInbox + Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key + instance YesodHttpSig App where data HttpSigVerResult App = HttpSigVerResult (Either String FedURI) httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor] @@ -579,7 +673,7 @@ instance YesodHttpSig App where case algo of S.AlgorithmEd25519 -> Right () S.AlgorithmOther _ -> Left "Unsupported algo in Sig header" - u <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of + uKey <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of Left e -> Left $ "keyId in Sig header isn't a valid FedURI: " ++ e Right uri -> Right uri signature <- ExceptT . pure $ do @@ -594,9 +688,10 @@ instance YesodHttpSig App where t <- first displayException $ decodeUtf8' b parseFedURI t _ -> throwE "Multiple ActivityPub-Actor headers" - (inboxOrVkid, key, mexpires, uActor, host, shared) <- do + --(inboxOrVkid, key, mexpires, uActor, host, shared) <- do + vkd <- do ments <- lift $ runDB $ do - mvk <- getBy $ UniqueVerifKey u + mvk <- getBy $ UniqueVerifKey uKey for mvk $ \ vk@(Entity _ verifkey) -> do mremote <- traverse getJust $ verifKeySharer verifkey return (vk, mremote) @@ -609,93 +704,70 @@ instance YesodHttpSig App where case muActorHeader of Nothing -> throwE "Got a sig with an instance key, but actor header not specified!" Just u -> return (u, True) - let uKey = verifKeyIdent vk - return - ( Right vkid - , verifKeyPublic vk - , verifKeyExpires vk - , ua - , furiHost uKey - , s - ) - Nothing -> do - Fetched k mexp ua uinb h s <- fetchKey' muActorHeader u - return (Left uinb, k, mexp, ua, h, s) + return VerifKeyDetail + { vkdKeyId = uKey + , vkdInboxOrId = Right vkid + , vkdKey = verifKeyPublic vk + , vkdExpires = verifKeyExpires vk + , vkdActorId = ua + , vkdHost = furiHost uKey + , vkdShared = s + } + Nothing -> fetched2vkd uKey <$> fetchKey' muActorHeader uKey let verify' k = verify k input signature errSig = throwE "Ed25519 sig verification says not valid" errTime = throwE "Key expired" - existsInDB = isRight inboxOrVkid + existsInDB = isRight $ vkdInboxOrId vkd now <- liftIO getCurrentTime let stillValid Nothing = True stillValid (Just expires) = expires > now - (write, key', mexpires') <- - if verify' key && stillValid mexpires - then return (not existsInDB, key, mexpires) + + mvkd <- + if verify' (vkdKey vkd) && stillValid (vkdExpires vkd) + then return $ if existsInDB + then Nothing + else Just vkd else if existsInDB then do - Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader u - if shared == s + Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader uKey + if vkdShared vkd == s then return () else throwE "Key scope changed, we reject that" - if shared - then if h == host + if vkdShared vkd + then if h == vkdHost vkd then return () else fail "BUG! We re-fetched a key and the host changed" - else if newActor == uActor + else if newActor == vkdActorId vkd then return () else throwE "Key owner changed, we reject that" if stillValid newExp then return () else errTime if verify' newKey - then return (True, newKey, newExp) + then return $ Just vkd + { vkdKey = newKey + , vkdExpires = newExp + } else errSig - else if stillValid mexpires + else if stillValid $ vkdExpires vkd then errSig else errTime - when write $ ExceptT $ runDB $ - case inboxOrVkid of - Left inbox -> - if shared - then do - ment <- getBy $ UniqueInstance host - case ment of - Nothing -> do - iid <- insert $ Instance host - insert_ $ VerifKey u iid mexpires' key' Nothing - return $ Right () - Just (Entity iid _) -> do - n <- count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] - if n < 2 - then do - insert_ $ VerifKey u iid mexpires' key' Nothing - return $ Right () - else return $ Left "We already store 2 keys" - else do - ment <- getBy $ UniqueRemoteSharer uActor - case ment of - Nothing -> do - iid <- either entityKey id <$> insertBy (Instance host) - rsid <- insert $ RemoteSharer uActor iid inbox - insert_ $ VerifKey u iid mexpires' key' (Just rsid) - return $ Right () - Just (Entity rsid rs) -> do - n <- count [VerifKeySharer ==. Just rsid] - if n < 2 - then do - let iid = remoteSharerInstance rs - insert_ $ VerifKey u iid mexpires' key' (Just rsid) - return $ Right () - else return $ Left "We already store 2 keys" - Right vkid -> do - update vkid - [VerifKeyExpires =. mexpires', VerifKeyPublic =. key'] - return $ Right () - return uActor + + for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate + return $ vkdActorId vkd where fetchKey' mua uk = do manager <- getsYesod appHttpManager ExceptT $ fetchKey manager (isJust malgo) mua uk + fetched2vkd uk (Fetched k mexp ua uinb h s) = VerifKeyDetail + { vkdKeyId = uk + , vkdInboxOrId = Left uinb + , vkdKey = k + , vkdExpires = mexp + , vkdActorId = ua + , vkdHost = h + , vkdShared = s + } instance YesodBreadcrumbs App where breadcrumb route = return $ case route of