Allow actor public key to be in a separate document

config/models

@@ -41,6 +41,7 @@ Person
 
 VerifKey
     ident  URI
+    actor  URI
     public PublicKey
 
     UniqueVerifKey ident

migrations/2019_02_03_verifkey.model

@@ -1,5 +1,6 @@
 VerifKey
     ident  String
+    actor  String
     public ByteString
 
     UniqueVerifKey ident

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

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, uActor) <- do
-        (mvkid, key) <- do
             ment <- lift $ runDB $ getBy $ UniqueVerifKey u
             case ment of
-                Just (Entity vkid vk) -> return (Just vkid, verifKeyPublic vk)
+                Just (Entity vkid vk) ->
-                Nothing -> (,) Nothing <$> fetchKey u uActor
+                    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 $ fetchKey manager (isJust malgo) 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

src/Web/ActivityPub.hs

@@ -35,17 +35,21 @@ module Web.ActivityPub
     , APGetError (..)
     , httpGetAP
     , httpPostAP
+    , fetchKey
     )
 where
 
 import Prelude
 
-import Control.Applicative ((<|>))
+import Control.Applicative ((<|>), optional)
-import Control.Exception (Exception, try)
+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"