Support remote actors specifying 2 keys, and DB storage of these keys

It's now possible for activities we be attributed to actors that have more than
one key. We allow up to 2 keys. We also store in the DB. Scaling to support any
number of keys is trivial, but I'm limiting to 2 to avoid potential trouble and
because 2 is the actual number we need.

By having 2 keys, and replacing only one of them in each rotation, we avoid
race conditions. With 1 key, the following can happen:

1. We send an activity to another server
2. We rotate our key
3. The server reaches the activity in its processing queue, tries to verify our
   request signature, but fails because it can't fetch the key. It's the old
   key and we discarded it already, replaced it with the new one

When we use 2 keys, the previous key remains available and other servers have
time to finish processing our requests signed with that key. We can safely
rotate, without worrying about whether the user sent anything right before the
rotation time.

Caveat: With this feature, we allow OTHER servers to rotate freely. It's safe
because it's optional, but it's just Vervis right now. Once Vervis itself
starts using 2 keys, it will be able to rotate freely without race condition
risk, but probably Mastodon etc. won't accept its signatures because of the use
of 2 keys and because they're server-scope keys.

Maybe I can get these features adopted by the fediverse?

config/models

@@ -41,11 +41,16 @@ Person
 
 VerifKey
     ident  URI
-    actor  URI
     public PublicKey
+    sharer RemoteSharerId
 
     UniqueVerifKey ident
 
+RemoteSharer
+    ident URI
+
+    UniqueRemoteSharer ident
+
 SshKey
     ident   KyIdent
     person  PersonId

migrations/2019_02_03_verifkey.model

@@ -1,6 +1,11 @@
 VerifKey
     ident  String
-    actor  String
     public ByteString
+    sharer RemoteSharerId
 
     UniqueVerifKey ident
+
+RemoteSharer
+    ident String
+
+    UniqueRemoteSharer ident

src/Vervis/Foundation.hs

@@ -581,10 +581,18 @@ instance YesodHttpSig App where
                 CryptoPassed s -> Right s
                 CryptoFailed e -> Left "Parsing Ed25519 signature failed"
         (mvkid, key, uActor) <- do
-            ment <- lift $ runDB $ getBy $ UniqueVerifKey u
+            ments <- lift $ runDB $ do
-            case ment of
+                mvk <- getBy $ UniqueVerifKey u
-                Just (Entity vkid vk) ->
+                for mvk $ \ vk@(Entity _ verifkey) -> do
-                    return (Just vkid, verifKeyPublic vk, verifKeyActor vk)
+                    remote <- getJust $ verifKeySharer verifkey
+                    return (vk, remote)
+            case ments of
+                Just (Entity vkid vk, remote) ->
+                    return
+                        ( Just vkid
+                        , verifKeyPublic vk
+                        , remoteSharerIdent remote
+                        )
                 Nothing -> do
                     (k, ua) <- fetchKey' u
                     return (Nothing, k, ua)
@@ -604,10 +612,25 @@ instance YesodHttpSig App where
                             then return (True, newKey)
                             else err
                     else err
-        when write $ lift $ runDB $
+        when write $ ExceptT $ runDB $
             case mvkid of
-                Nothing   -> insert_ $ VerifKey u uActor key'
+                Nothing -> do
-                Just vkid -> update vkid [VerifKeyPublic =. key']
+                    ment <- getBy $ UniqueRemoteSharer uActor
+                    case ment of
+                        Nothing -> do
+                            rsid <- insert $ RemoteSharer uActor
+                            insert_ $ VerifKey u key' rsid
+                            return $ Right ()
+                        Just (Entity rsid rs) -> do
+                            n <- count [VerifKeySharer ==. rsid]
+                            if n < 2
+                                then do
+                                    insert_ $ VerifKey u key' rsid
+                                    return $ Right ()
+                                else return $ Left "We already store 2 keys"
+                Just vkid -> do
+                    update vkid [VerifKeyPublic =. key']
+                    return $ Right ()
         return uActor
         where
         fetchKey' u = do

src/Vervis/Handler/Person.hs

@@ -153,13 +153,16 @@ getPersonR shr = do
             , actorType       = ActorTypePerson
             , actorUsername   = shr2text shr
             , actorInbox      = route2uri InboxR
-            , actorPublicKey = Right PublicKey
+            , actorPublicKeys = PublicKeySet
+                { publicKey1 = Right PublicKey
                     { publicKeyId     = me { uriFragment = "#key" }
                     , publicKeyOwner  = me
                     , publicKeyPem    = PEM "PUBLIC KEY" [] actorKey
                     , publicKeyAlgo   = Just AlgorithmEd25519
                     , publicKeyShared = False
                     }
+                , publicKey2 = Nothing
+                }
             }
 
 postPersonR :: ShrIdent -> Handler TypedContent

src/Web/ActivityPub.hs

@@ -21,6 +21,7 @@ module Web.ActivityPub
       ActorType (..)
     , Algorithm (..)
     , PublicKey (..)
+    , PublicKeySet (..)
     , Actor (..)
 
       -- * Activity
@@ -43,6 +44,7 @@ import Prelude
 
 import Control.Applicative ((<|>), optional)
 import Control.Exception (Exception, displayException, try)
+import Control.Monad ((<=<))
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Writer (Writer)
@@ -70,7 +72,7 @@ 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)
+import qualified Data.Vector as V (fromList, toList)
 
 import Data.Aeson.Local
 
@@ -156,12 +158,39 @@ instance ToJSON PublicKey where
             <> (frg <> "algorithm") .=? malgo
             <> (frg <> "shared")    .=  shared
 
+data PublicKeySet = PublicKeySet
+    { publicKey1 :: Either URI PublicKey
+    , publicKey2 :: Maybe (Either URI PublicKey)
+    }
+
+instance FromJSON PublicKeySet where
+    parseJSON v =
+        case v of
+            Array a ->
+                case V.toList a of
+                    [] -> fail "No public keys"
+                    [k1] -> PublicKeySet <$> parseKey k1 <*> pure Nothing
+                    [k1, k2] -> PublicKeySet <$> parseKey k1 <*> (Just <$> parseKey k2)
+                    _ -> fail "More than 2 public keys isn't supported"
+            _ -> PublicKeySet <$> parseKey v <*> pure Nothing
+        where
+        parseKey = bitraverse parseHttpsURI pure . toEither <=< parseJSON
+
+instance ToJSON PublicKeySet where
+    toJSON = error "toJSON PublicKeySet"
+    toEncoding (PublicKeySet k1 mk2) =
+        case mk2 of
+            Nothing -> toEncoding $ renderKey k1
+            Just k2 -> toEncodingList [renderKey k1, renderKey k2]
+        where
+        renderKey = fromEither . first renderURI
+
 data Actor = Actor
     { actorId         :: URI
     , actorType       :: ActorType
     , actorUsername   :: Text
     , actorInbox      :: URI
-    , actorPublicKey :: Either URI PublicKey
+    , actorPublicKeys :: PublicKeySet
     }
 
 instance FromJSON Actor where
@@ -171,18 +200,18 @@ instance FromJSON Actor where
             <*> o .: "type"
             <*> o .: "preferredUsername"
             <*> (parseHttpsURI =<< o .: "inbox")
-            <*> (bitraverse parseHttpsURI pure . toEither =<< o .: "publicKey")
+            <*> o .: "publicKey"
 
 instance ToJSON Actor where
     toJSON = error "toJSON Actor"
-    toEncoding (Actor id_ typ username inbox pkey) =
+    toEncoding (Actor id_ typ username inbox pkeys) =
         pairs
             $  "@context"          .= actorContext
             <> "id"                .= renderURI id_
             <> "type"              .= typ
             <> "preferredUsername" .= username
             <> "inbox"             .= renderURI inbox
-            <> "publicKey"         .= fromEither (first renderURI pkey)
+            <> "publicKey"         .= pkeys
 
 -- | 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
@@ -340,31 +369,37 @@ fetchKey manager sigAlgo u = runExceptT $ do
     obj <- fetch u
     (actor, pkey) <-
         case obj of
-            Left' pkey ->
+            Left' pkey -> do
+                if publicKeyId pkey == u
+                    then return ()
+                    else throwE "Public key's ID doesn't match the keyid URI"
                 if uriAuthority (publicKeyOwner pkey) == uriAuthority u
-                    then do
+                    then return ()
-                        actor <- fetch $ publicKeyOwner 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"
+                actor <- fetch $ publicKeyOwner pkey
+                let PublicKeySet k1 mk2 = actorPublicKeys actor
+                    match (Left uri) = uri == u
+                    match (Right _)  = False
+                if match k1 || maybe False match mk2
+                    then return (actor, pkey)
+                    else throwE "Actor publicKey has no URI matching pkey @id"
             Right' actor -> do
                 if actorId actor == u { uriFragment = "" }
                     then return ()
                     else throwE "Actor ID doesn't match the keyid URI we fetched"
-                case actorPublicKey actor of
+                let PublicKeySet k1 mk2 = actorPublicKeys actor
-                    Left _ -> throwE "keyId resolved to document that has no key"
+                    match (Left _)   = Nothing
-                    Right pk -> return (actor, pk)
+                    match (Right pk) =
+                        if publicKeyId pk == u
+                            then Just pk
+                            else Nothing
+                case match k1 <|> (match =<< mk2) of
+                    Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
+                    Just pk -> return (actor, pk)
     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"