diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs
index 9d22980..e81ccf8 100644
--- a/src/Vervis/Handler/Person.hs
+++ b/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
- { publicKey1 = Left $ route2local ActorKey1R
- , publicKey2 = Just $ Left $ route2local ActorKey2R
- }
+ , actorPublicKeys =
+ Left (route2local ActorKey1R) :|
+ [ Left $ route2local ActorKey2R ]
}
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 1421cfa..d40b7be 100644
--- a/src/Web/ActivityPub.hs
+++ b/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
- [] -> 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
- Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
- Just pk -> return pk
+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"