Remove hardcoded-to-2 limit on length of an actor's list of public keys
This commit is contained in:
fr33domlover
parent
0912b8e291
commit
17524b6ee1
2 changed files with 34 additions and 33 deletions
|
|
@ -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
|
||||
{ publicKey1 = Left $ route2local ActorKey1R
|
||||
, publicKey2 = Just $ Left $ route2local ActorKey2R
|
||||
}
|
||||
, actorPublicKeys =
|
||||
Left (route2local ActorKey1R) :|
|
||||
[ Left $ route2local ActorKey2R ]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[] -> fail "No public keys"
|
||||
[k1] -> second (flip PublicKeySet Nothing) <$> parseKey k1
|
||||
[k1, k2] -> do
|
||||
(h, e1) <- parseKey k1
|
||||
e2 <- withHost h $ parseKey k2
|
||||
return (h, PublicKeySet e1 $ Just e2)
|
||||
_ -> fail "More than 2 public keys isn't supported"
|
||||
_ -> second (flip PublicKeySet Nothing) <$> parseKey v
|
||||
case nonEmpty $ V.toList a of
|
||||
Nothing -> fail "No public keys"
|
||||
Just (k :| ks) -> do
|
||||
(h, e) <- parseKey k
|
||||
es <- traverse (withHost h . parseKey) ks
|
||||
return (h, e :| es)
|
||||
_ -> second (:| []) <$> 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 host (PublicKeySet k1 mk2) =
|
||||
case mk2 of
|
||||
Nothing -> renderKey k1
|
||||
Just k2 -> listEncoding renderKey [k1, k2]
|
||||
encodePublicKeySet :: Text -> NonEmpty (Either LocalURI PublicKey) -> Encoding
|
||||
encodePublicKeySet host (e :| es) =
|
||||
if null es
|
||||
then renderKey e
|
||||
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
|
||||
match (Left uri) = uri == uk
|
||||
let 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) =
|
||||
let match' = match luKey
|
||||
in case match' k1 <|> (match' =<< mk2) of
|
||||
matchKeyObj :: (Foldable f, Monad m) => LocalURI -> f (Either LocalURI PublicKey) -> ExceptT String m PublicKey
|
||||
matchKeyObj luKey es =
|
||||
case find' (match luKey) es of
|
||||
Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
|
||||
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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue