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

This commit is contained in:
fr33domlover 2019-02-24 01:21:42 +00:00
parent 0912b8e291
commit 17524b6ee1
2 changed files with 34 additions and 33 deletions

View file

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

View file

@ -30,7 +30,7 @@ module Web.ActivityPub
, Algorithm (..) , Algorithm (..)
, Owner (..) , Owner (..)
, PublicKey (..) , PublicKey (..)
, PublicKeySet (..) --, PublicKeySet (..)
, Actor (..) , Actor (..)
-- * Activity -- * Activity
@ -57,7 +57,7 @@ import Prelude
import Control.Applicative ((<|>), optional) import Control.Applicative ((<|>), optional)
import Control.Exception (Exception, displayException, try) 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.IO.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer (Writer) import Control.Monad.Trans.Writer (Writer)
@ -69,10 +69,10 @@ import Data.Bifunctor
import Data.Bitraversable (bitraverse) import Data.Bitraversable (bitraverse)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Foldable (for_) import Data.Foldable (for_)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Proxy import Data.Proxy
import Data.PEM import Data.PEM
import Data.Semigroup (Endo) import Data.Semigroup (Endo, First (..))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
@ -235,24 +235,24 @@ instance ActivityPub PublicKey where
mkOwner h OwnerInstance = FedURI h "" "" mkOwner h OwnerInstance = FedURI h "" ""
mkOwner h (OwnerActor lu) = l2f h lu mkOwner h (OwnerActor lu) = l2f h lu
{-
data PublicKeySet = PublicKeySet data PublicKeySet = PublicKeySet
{ publicKey1 :: Either LocalURI PublicKey { publicKey1 :: Either LocalURI PublicKey
, publicKey2 :: Maybe (Either LocalURI PublicKey) , publicKey2 :: Maybe (Either LocalURI PublicKey)
} }
-}
parsePublicKeySet :: Value -> Parser (Text, PublicKeySet) parsePublicKeySet :: Value -> Parser (Text, NonEmpty (Either LocalURI PublicKey))
parsePublicKeySet v = parsePublicKeySet v =
case v of case v of
Array a -> 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 where
parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t) parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t)
parseKey (Object o) = second Right <$> parseObject o parseKey (Object o) = second Right <$> parseObject o
@ -263,11 +263,11 @@ parsePublicKeySet v =
then return v then return v
else fail "URI host mismatch" 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 where
renderKey (Left lu) = toEncoding $ l2f host lu renderKey (Left lu) = toEncoding $ l2f host lu
renderKey (Right pk) = pairs $ toSeries host pk renderKey (Right pk) = pairs $ toSeries host pk
@ -277,7 +277,7 @@ data Actor = Actor
, actorType :: ActorType , actorType :: ActorType
, actorUsername :: Text , actorUsername :: Text
, actorInbox :: LocalURI , actorInbox :: LocalURI
, actorPublicKeys :: PublicKeySet , actorPublicKeys :: NonEmpty (Either LocalURI PublicKey)
} }
instance ActivityPub Actor where 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" else throwE "Actor publicKey has no URI matching pkey @id"
where where
keyUriListed uk a = keyUriListed uk a =
let PublicKeySet k1 mk2 = actorPublicKeys a let match (Left uri) = uri == uk
match (Left uri) = uri == uk
match (Right _) = False 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 where
find' :: Foldable f => (a -> Maybe b) -> f a -> Maybe b
find' p = join . fmap getFirst . foldMap (Just . First . p)
match _ (Left _) = Nothing match _ (Left _) = Nothing
match luk (Right pk) = match luk (Right pk) =
if publicKeyId pk == luk if publicKeyId pk == luk
@ -626,7 +627,7 @@ fetchUnknownKey manager sigAlgo host mluActor luKey = do
pk <- matchKeyObj luKey $ actorPublicKeys actor pk <- matchKeyObj luKey $ actorPublicKeys actor
owner <- case publicKeyOwner pk of 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" 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 if owner == actorId actor
then return owner then return owner
else throwE "Actor's publicKey's owner doesn't match the actor's ID" else throwE "Actor's publicKey's owner doesn't match the actor's ID"