From c336d56036889432e22871720e4a5bfbc22d87c7 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 3 Feb 2019 23:39:56 +0000 Subject: [PATCH] Allow actor public key to be in a separate document --- config/models | 1 + migrations/2019_02_03_verifkey.model | 1 + src/Data/Aeson/Local.hs | 9 +++- src/Vervis/Foundation.hs | 52 ++++++--------------- src/Web/ActivityPub.hs | 68 ++++++++++++++++++++++++++-- 5 files changed, 88 insertions(+), 43 deletions(-) diff --git a/config/models b/config/models index 26beec3..544b572 100644 --- a/config/models +++ b/config/models @@ -41,6 +41,7 @@ Person VerifKey ident URI + actor URI public PublicKey UniqueVerifKey ident diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index 48dbcfa..f37cdd9 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -1,5 +1,6 @@ VerifKey ident String + actor String public ByteString UniqueVerifKey ident diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 8e2fdc3..e08255b 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -14,7 +14,8 @@ -} module Data.Aeson.Local - ( frg + ( Either' (..) + , frg , parseHttpsURI , renderURI , (.=?) @@ -23,6 +24,7 @@ where import Prelude +import Control.Applicative ((<|>)) import Data.Aeson import Data.Aeson.Types (Parser) import Data.Text (Text) @@ -30,6 +32,11 @@ import Network.URI import qualified Data.Text as T (unpack) +data Either' a b = Left' a | Right' b + +instance (FromJSON a, FromJSON b) => FromJSON (Either' a b) where + parseJSON v = Left' <$> parseJSON v <|> Right' <$> parseJSON v + frg :: Text frg = "https://forgefed.angeley.es/ns#" diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 70f4ee4..2a0d961 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -580,12 +580,14 @@ instance YesodHttpSig App where case signature sig of CryptoPassed s -> Right s CryptoFailed e -> Left "Parsing Ed25519 signature failed" - let uActor = u { uriFragment = "" } - (mvkid, key) <- do + (mvkid, key, uActor) <- do ment <- lift $ runDB $ getBy $ UniqueVerifKey u case ment of - Just (Entity vkid vk) -> return (Just vkid, verifKeyPublic vk) - Nothing -> (,) Nothing <$> fetchKey u uActor + Just (Entity vkid vk) -> + return (Just vkid, verifKeyPublic vk, verifKeyActor vk) + Nothing -> do + (k, ua) <- fetchKey' u + return (Nothing, k, ua) let verify' k = verify k input signature err = throwE "Ed25519 sig verification says not valid" existsInDB = isJust mvkid @@ -594,51 +596,23 @@ instance YesodHttpSig App where then return (not existsInDB, key) else if existsInDB then do - newKey <- fetchKey u uActor + (newKey, newActor) <- fetchKey' u + if newActor == uActor + then return () + else throwE "Key owner changed, we reject that" if verify' newKey then return (True, newKey) else err else err when write $ lift $ runDB $ case mvkid of - Nothing -> insert_ $ VerifKey u key' + Nothing -> insert_ $ VerifKey u uActor key' Just vkid -> update vkid [VerifKeyPublic =. key'] return uActor where - fetchKey u uActor = do + fetchKey' u = 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" + ExceptT $ fetchKey manager (isJust malgo) u instance YesodBreadcrumbs App where breadcrumb route = return $ case route of diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 4389727..7c6869a 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -35,17 +35,21 @@ module Web.ActivityPub , APGetError (..) , httpGetAP , httpPostAP + , fetchKey ) where import Prelude -import Control.Applicative ((<|>)) -import Control.Exception (Exception, try) +import Control.Applicative ((<|>), optional) +import Control.Exception (Exception, displayException, try) import Control.Monad.IO.Class +import Control.Monad.Trans.Except import Control.Monad.Trans.Writer (Writer) +import Crypto.Error (CryptoFailable (..)) import Data.Aeson import Data.Aeson.Types (Parser) +import Data.Bifunctor (bimap) import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.PEM @@ -62,6 +66,7 @@ import Network.URI import Yesod.Core.Content (ContentType) import Yesod.Core.Handler (ProvidedRep, provideRepType) +import qualified Crypto.PubKey.Ed25519 as E (PublicKey, publicKey) import qualified Data.HashMap.Strict as M (lookup) import qualified Data.Text as T (unpack) import qualified Data.Vector as V (fromList) @@ -116,7 +121,14 @@ data PublicKey = PublicKey } instance FromJSON PublicKey where - parseJSON = withObject "PublicKey" $ \ o -> + parseJSON = withObject "PublicKey" $ \ o -> do + mtyp <- optional $ o .: "@type" <|> o .: "type" + case mtyp of + Nothing -> return () + Just t -> + if t == ("Key" :: Text) + then return () + else fail "PublicKey @type isn't Key" PublicKey <$> (parseHttpsURI =<< o .: "id") <*> (parseHttpsURI =<< o .: "owner") @@ -314,3 +326,53 @@ httpPostAP manager uri headers sign value = httpNoBody req'' manager where consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r } + +fetchKey + :: MonadIO m + => Manager + -> Bool + -> URI + -> m (Either String (E.PublicKey, URI)) +fetchKey manager sigAlgo u = runExceptT $ do + let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a + fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u + obj <- fetch u + (actor, pkey) <- + case obj of + Left' pkey -> + if uriAuthority (publicKeyOwner pkey) == uriAuthority u + then do + actor <- fetch $ publicKeyOwner pkey + return (actor, pkey) + else throwE "Actor and key on different domains, we reject" + Right' actor -> + if actorId actor == u { uriFragment = "" } + then return (actor, actorPublicKey actor) + else throwE "Actor ID doesn't match the keyid URI we fetched" + ExceptT . pure $ do + 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 $ + if sigAlgo + then "Algo mismatch, Ed25519 in Sig but none in actor" + else "Algo not given in Sig nor actor" + Just algo -> + case algo of + AlgorithmEd25519 -> Right () + AlgorithmOther _ -> + Left $ + if sigAlgo + then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" + else "No algo in Sig, unsupported algo in actor" + case E.publicKey $ pemContent $ publicKeyPem pkey of + CryptoPassed k -> Right (k, actorId actor) + CryptoFailed e -> Left "Parsing Ed25519 public key failed"