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"