Allow actor publicKey to be a URI, and require the URI to match the Sig keyId

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#"
 

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

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!"