diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index e08255b..1428e05 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -15,6 +15,8 @@ module Data.Aeson.Local ( Either' (..) + , toEither + , fromEither , frg , parseHttpsURI , renderURI @@ -37,6 +39,19 @@ 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 +instance (ToJSON a, ToJSON b) => ToJSON (Either' a b) where + toJSON = error "toJSON Either'" + toEncoding (Left' x) = toEncoding x + toEncoding (Right' y) = toEncoding y + +toEither :: Either' a b -> Either a b +toEither (Left' x) = Left x +toEither (Right' y) = Right y + +fromEither :: Either a b -> Either' a b +fromEither (Left x) = Left' x +fromEither (Right y) = Right' y + frg :: Text frg = "https://forgefed.angeley.es/ns#" diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 59edcf7..5168bd8 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -153,7 +153,7 @@ getPersonR shr = do , actorType = ActorTypePerson , actorUsername = shr2text shr , actorInbox = route2uri InboxR - , actorPublicKey = PublicKey + , actorPublicKey = Right PublicKey { publicKeyId = me { uriFragment = "#key" } , publicKeyOwner = me , publicKeyPem = PEM "PUBLIC KEY" [] actorKey diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 7c6869a..6900c88 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -49,7 +49,8 @@ import Control.Monad.Trans.Writer (Writer) import Crypto.Error (CryptoFailable (..)) import Data.Aeson import Data.Aeson.Types (Parser) -import Data.Bifunctor (bimap) +import Data.Bifunctor (bimap, first) +import Data.Bitraversable (bitraverse) import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.PEM @@ -160,7 +161,7 @@ data Actor = Actor , actorType :: ActorType , actorUsername :: Text , actorInbox :: URI - , actorPublicKey :: PublicKey + , actorPublicKey :: Either URI PublicKey } instance FromJSON Actor where @@ -170,7 +171,7 @@ instance FromJSON Actor where <*> o .: "type" <*> o .: "preferredUsername" <*> (parseHttpsURI =<< o .: "inbox") - <*> o .: "publicKey" + <*> (bitraverse parseHttpsURI pure . toEither =<< o .: "publicKey") instance ToJSON Actor where toJSON = error "toJSON Actor" @@ -181,7 +182,7 @@ instance ToJSON Actor where <> "type" .= typ <> "preferredUsername" .= username <> "inbox" .= renderURI inbox - <> "publicKey" .= pkey + <> "publicKey" .= fromEither (first renderURI pkey) -- | This may seem trivial, but it exists for a good reason: In the 'FromJSON' -- instance we perform sanity checks. We just don't need to remember the fields @@ -343,12 +344,20 @@ fetchKey manager sigAlgo u = runExceptT $ do if uriAuthority (publicKeyOwner pkey) == uriAuthority u then do actor <- fetch $ publicKeyOwner pkey - return (actor, pkey) + case actorPublicKey actor of + Left uri -> + if uri == u + then return (actor, pkey) + else throwE "Mismatch between pkey @id and actor publicKey URI" + Right _ -> throwE "Actor publicKey is an object, not the pkey @id URI" else throwE "Actor and key on different domains, we reject" - Right' actor -> + Right' actor -> do if actorId actor == u { uriFragment = "" } - then return (actor, actorPublicKey actor) + then return () else throwE "Actor ID doesn't match the keyid URI we fetched" + case actorPublicKey actor of + Left _ -> throwE "keyId resolved to document that has no key" + Right pk -> return (actor, pk) ExceptT . pure $ do if publicKeyShared pkey then Left "Actor's publicKey is shared, we're rejecting it!"