Remove hardcoded-to-2 limit on length of an actor's list of public keys

src/Vervis/Handler/Person.hs

@@ -23,6 +23,7 @@ where
 import Vervis.Import hiding ((==.))
 --import Prelude
 
+import Data.List.NonEmpty (NonEmpty (..))
 import Database.Esqueleto hiding (isNothing, count)
 import Vervis.Form.Person
 --import Model
@@ -143,8 +144,7 @@ getPerson shr person = do
             , actorType       = ActorTypePerson
             , actorUsername   = shr2text shr
             , actorInbox      = route2local InboxR
-            , actorPublicKeys = PublicKeySet
+            , actorPublicKeys =
-                { publicKey1 = Left $ route2local ActorKey1R
+                Left (route2local ActorKey1R) :|
-                , publicKey2 = Just $ Left $ route2local ActorKey2R
+                [ Left $ route2local ActorKey2R ]
-                }
             }

src/Web/ActivityPub.hs

@@ -30,7 +30,7 @@ module Web.ActivityPub
     , Algorithm (..)
     , Owner (..)
     , PublicKey (..)
-    , PublicKeySet (..)
+    --, PublicKeySet (..)
     , Actor (..)
 
       -- * Activity
@@ -57,7 +57,7 @@ import Prelude
 
 import Control.Applicative ((<|>), optional)
 import Control.Exception (Exception, displayException, try)
-import Control.Monad (when, unless, (<=<))
+import Control.Monad (when, unless, (<=<), join)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Writer (Writer)
@@ -69,10 +69,10 @@ import Data.Bifunctor
 import Data.Bitraversable (bitraverse)
 import Data.ByteString (ByteString)
 import Data.Foldable (for_)
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Proxy
 import Data.PEM
-import Data.Semigroup (Endo)
+import Data.Semigroup (Endo, First (..))
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Data.Time.Clock (UTCTime)
@@ -235,24 +235,24 @@ instance ActivityPub PublicKey where
         mkOwner h OwnerInstance   = FedURI h "" ""
         mkOwner h (OwnerActor lu) = l2f h lu
 
+{-
 data PublicKeySet = PublicKeySet
     { publicKey1 :: Either LocalURI PublicKey
     , publicKey2 :: Maybe (Either LocalURI PublicKey)
     }
+-}
 
-parsePublicKeySet :: Value -> Parser (Text, PublicKeySet)
+parsePublicKeySet :: Value -> Parser (Text, NonEmpty (Either LocalURI PublicKey))
 parsePublicKeySet v =
     case v of
         Array a ->
-            case V.toList a of
+            case nonEmpty $ V.toList a of
-                [] -> fail "No public keys"
+                Nothing -> fail "No public keys"
-                [k1] -> second (flip PublicKeySet Nothing) <$> parseKey k1
+                Just (k :| ks) -> do
-                [k1, k2] -> do
+                    (h, e) <- parseKey k
-                    (h, e1) <- parseKey k1
+                    es <- traverse (withHost h . parseKey) ks
-                    e2 <- withHost h $ parseKey k2
+                    return (h, e :| es)
-                    return (h, PublicKeySet e1 $ Just e2)
+        _ -> second (:| []) <$> parseKey v
-                _ -> fail "More than 2 public keys isn't supported"
-        _ -> second (flip PublicKeySet Nothing) <$> parseKey v
     where
     parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t)
     parseKey (Object o) = second Right <$> parseObject o
@@ -263,11 +263,11 @@ parsePublicKeySet v =
             then return v
             else fail "URI host mismatch"
 
-encodePublicKeySet :: Text -> PublicKeySet -> Encoding
+encodePublicKeySet :: Text -> NonEmpty (Either LocalURI PublicKey) -> Encoding
-encodePublicKeySet host (PublicKeySet k1 mk2) =
+encodePublicKeySet host (e :| es) =
-    case mk2 of
+    if null es
-        Nothing -> renderKey k1
+        then renderKey e
-        Just k2 -> listEncoding renderKey [k1, k2]
+        else listEncoding renderKey $ e : es
     where
     renderKey (Left lu)  = toEncoding $ l2f host lu
     renderKey (Right pk) = pairs $ toSeries host pk
@@ -277,7 +277,7 @@ data Actor = Actor
     , actorType       :: ActorType
     , actorUsername   :: Text
     , actorInbox      :: LocalURI
-    , actorPublicKeys :: PublicKeySet
+    , actorPublicKeys :: NonEmpty (Either LocalURI PublicKey)
     }
 
 instance ActivityPub Actor where
@@ -534,17 +534,18 @@ keyListedByActor manager host luKey luActor = runExceptT $ do
         else throwE "Actor publicKey has no URI matching pkey @id"
     where
     keyUriListed uk a =
-        let PublicKeySet k1 mk2 = actorPublicKeys a
+        let match (Left uri) = uri == uk
-            match (Left uri) = uri == uk
             match (Right _)  = False
-        in  match k1 || maybe False match mk2
+        in  any match $ actorPublicKeys a
 
-matchKeyObj luKey (PublicKeySet k1 mk2) =
+matchKeyObj :: (Foldable f, Monad m) => LocalURI -> f (Either LocalURI PublicKey) -> ExceptT String m PublicKey
-    let match' = match luKey
+matchKeyObj luKey es =
-    in  case match' k1 <|> (match' =<< mk2) of
+    case find' (match luKey) es of
-            Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
+        Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
-            Just pk -> return pk
+        Just pk -> return pk
     where
+    find' :: Foldable f => (a -> Maybe b) -> f a -> Maybe b
+    find' p = join . fmap getFirst . foldMap (Just . First . p)
     match _   (Left _)   = Nothing
     match luk (Right pk) =
         if publicKeyId pk == luk
@@ -626,7 +627,7 @@ fetchUnknownKey manager sigAlgo host mluActor luKey = do
                 pk <- matchKeyObj luKey $ actorPublicKeys actor
                 owner <- case publicKeyOwner pk of
                     OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
-                    OwnerActor owner -> do
+                    OwnerActor owner ->
                         if owner == actorId actor
                             then return owner
                             else throwE "Actor's publicKey's owner doesn't match the actor's ID"