diff --git a/config/models b/config/models index 544b572..731fbc3 100644 --- a/config/models +++ b/config/models @@ -41,11 +41,16 @@ Person VerifKey ident URI - actor URI public PublicKey + sharer RemoteSharerId UniqueVerifKey ident +RemoteSharer + ident URI + + UniqueRemoteSharer ident + SshKey ident KyIdent person PersonId diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index f37cdd9..a253a2e 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -1,6 +1,11 @@ VerifKey ident String - actor String public ByteString + sharer RemoteSharerId UniqueVerifKey ident + +RemoteSharer + ident String + + UniqueRemoteSharer ident diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 2a0d961..323467c 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -581,10 +581,18 @@ instance YesodHttpSig App where CryptoPassed s -> Right s CryptoFailed e -> Left "Parsing Ed25519 signature failed" (mvkid, key, uActor) <- do - ment <- lift $ runDB $ getBy $ UniqueVerifKey u - case ment of - Just (Entity vkid vk) -> - return (Just vkid, verifKeyPublic vk, verifKeyActor vk) + ments <- lift $ runDB $ do + mvk <- getBy $ UniqueVerifKey u + for mvk $ \ vk@(Entity _ verifkey) -> do + remote <- getJust $ verifKeySharer verifkey + return (vk, remote) + case ments of + Just (Entity vkid vk, remote) -> + return + ( Just vkid + , verifKeyPublic vk + , remoteSharerIdent remote + ) Nothing -> do (k, ua) <- fetchKey' u return (Nothing, k, ua) @@ -604,10 +612,25 @@ instance YesodHttpSig App where then return (True, newKey) else err else err - when write $ lift $ runDB $ + when write $ ExceptT $ runDB $ case mvkid of - Nothing -> insert_ $ VerifKey u uActor key' - Just vkid -> update vkid [VerifKeyPublic =. key'] + Nothing -> do + ment <- getBy $ UniqueRemoteSharer uActor + case ment of + Nothing -> do + rsid <- insert $ RemoteSharer uActor + insert_ $ VerifKey u key' rsid + return $ Right () + Just (Entity rsid rs) -> do + n <- count [VerifKeySharer ==. rsid] + if n < 2 + then do + insert_ $ VerifKey u key' rsid + return $ Right () + else return $ Left "We already store 2 keys" + Just vkid -> do + update vkid [VerifKeyPublic =. key'] + return $ Right () return uActor where fetchKey' u = do diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 5168bd8..b042d7f 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -149,16 +149,19 @@ getPersonR shr = do secure <- getSecure defaultLayout $(widgetFile "person") provideAP Actor - { actorId = me - , actorType = ActorTypePerson - , actorUsername = shr2text shr - , actorInbox = route2uri InboxR - , actorPublicKey = Right PublicKey - { publicKeyId = me { uriFragment = "#key" } - , publicKeyOwner = me - , publicKeyPem = PEM "PUBLIC KEY" [] actorKey - , publicKeyAlgo = Just AlgorithmEd25519 - , publicKeyShared = False + { actorId = me + , actorType = ActorTypePerson + , actorUsername = shr2text shr + , actorInbox = route2uri InboxR + , actorPublicKeys = PublicKeySet + { publicKey1 = Right PublicKey + { publicKeyId = me { uriFragment = "#key" } + , publicKeyOwner = me + , publicKeyPem = PEM "PUBLIC KEY" [] actorKey + , publicKeyAlgo = Just AlgorithmEd25519 + , publicKeyShared = False + } + , publicKey2 = Nothing } } diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 6900c88..71b6548 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -21,6 +21,7 @@ module Web.ActivityPub ActorType (..) , Algorithm (..) , PublicKey (..) + , PublicKeySet (..) , Actor (..) -- * Activity @@ -43,6 +44,7 @@ import Prelude import Control.Applicative ((<|>), optional) import Control.Exception (Exception, displayException, try) +import Control.Monad ((<=<)) import Control.Monad.IO.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Writer (Writer) @@ -70,7 +72,7 @@ import Yesod.Core.Handler (ProvidedRep, provideRepType) import qualified Crypto.PubKey.Ed25519 as E (PublicKey, publicKey) import qualified Data.HashMap.Strict as M (lookup) import qualified Data.Text as T (unpack) -import qualified Data.Vector as V (fromList) +import qualified Data.Vector as V (fromList, toList) import Data.Aeson.Local @@ -156,12 +158,39 @@ instance ToJSON PublicKey where <> (frg <> "algorithm") .=? malgo <> (frg <> "shared") .= shared +data PublicKeySet = PublicKeySet + { publicKey1 :: Either URI PublicKey + , publicKey2 :: Maybe (Either URI PublicKey) + } + +instance FromJSON PublicKeySet where + parseJSON v = + case v of + Array a -> + case V.toList a of + [] -> fail "No public keys" + [k1] -> PublicKeySet <$> parseKey k1 <*> pure Nothing + [k1, k2] -> PublicKeySet <$> parseKey k1 <*> (Just <$> parseKey k2) + _ -> fail "More than 2 public keys isn't supported" + _ -> PublicKeySet <$> parseKey v <*> pure Nothing + where + parseKey = bitraverse parseHttpsURI pure . toEither <=< parseJSON + +instance ToJSON PublicKeySet where + toJSON = error "toJSON PublicKeySet" + toEncoding (PublicKeySet k1 mk2) = + case mk2 of + Nothing -> toEncoding $ renderKey k1 + Just k2 -> toEncodingList [renderKey k1, renderKey k2] + where + renderKey = fromEither . first renderURI + data Actor = Actor - { actorId :: URI - , actorType :: ActorType - , actorUsername :: Text - , actorInbox :: URI - , actorPublicKey :: Either URI PublicKey + { actorId :: URI + , actorType :: ActorType + , actorUsername :: Text + , actorInbox :: URI + , actorPublicKeys :: PublicKeySet } instance FromJSON Actor where @@ -171,18 +200,18 @@ instance FromJSON Actor where <*> o .: "type" <*> o .: "preferredUsername" <*> (parseHttpsURI =<< o .: "inbox") - <*> (bitraverse parseHttpsURI pure . toEither =<< o .: "publicKey") + <*> o .: "publicKey" instance ToJSON Actor where toJSON = error "toJSON Actor" - toEncoding (Actor id_ typ username inbox pkey) = + toEncoding (Actor id_ typ username inbox pkeys) = pairs $ "@context" .= actorContext <> "id" .= renderURI id_ <> "type" .= typ <> "preferredUsername" .= username <> "inbox" .= renderURI inbox - <> "publicKey" .= fromEither (first renderURI pkey) + <> "publicKey" .= pkeys -- | This may seem trivial, but it exists for a good reason: In the 'FromJSON' -- instance we perform sanity checks. We just don't need to remember the fields @@ -340,31 +369,37 @@ fetchKey manager sigAlgo u = runExceptT $ do obj <- fetch u (actor, pkey) <- case obj of - Left' pkey -> + Left' pkey -> do + if publicKeyId pkey == u + then return () + else throwE "Public key's ID doesn't match the keyid URI" if uriAuthority (publicKeyOwner pkey) == uriAuthority u - then do - actor <- fetch $ publicKeyOwner pkey - case actorPublicKey actor of - Left uri -> - if uri == u - then return (actor, pkey) - else throwE "Mismatch between pkey @id and actor publicKey URI" - Right _ -> throwE "Actor publicKey is an object, not the pkey @id URI" + then return () else throwE "Actor and key on different domains, we reject" + actor <- fetch $ publicKeyOwner pkey + let PublicKeySet k1 mk2 = actorPublicKeys actor + match (Left uri) = uri == u + match (Right _) = False + if match k1 || maybe False match mk2 + then return (actor, pkey) + else throwE "Actor publicKey has no URI matching pkey @id" Right' actor -> do if actorId actor == u { uriFragment = "" } then return () else throwE "Actor ID doesn't match the keyid URI we fetched" - case actorPublicKey actor of - Left _ -> throwE "keyId resolved to document that has no key" - Right pk -> return (actor, pk) + let PublicKeySet k1 mk2 = actorPublicKeys actor + match (Left _) = Nothing + match (Right pk) = + if publicKeyId pk == u + then Just pk + else Nothing + 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 (actor, pk) ExceptT . pure $ do if publicKeyShared pkey then Left "Actor's publicKey is shared, we're rejecting it!" else Right () - if publicKeyId pkey == u - then Right () - else Left "Actor's publicKey's ID doesn't match the keyid URI" if publicKeyOwner pkey == actorId actor then Right () else Left "Actor's publicKey's owner doesn't match the actor's ID"