From c2c4e2449730b8df0cee47f055aec068af0cd2b1 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 5 Feb 2019 04:05:44 +0000 Subject: [PATCH] Support actor key expiration Allow keys to specify expiration time using w3c security vocabulary. If a key has expired, we treat it like sig validation failure and re-fetch the key from the other server. And we never accept a sig, even a valid sig, if the key has expired. Since servers keep actors and keys in the DB, expiration can be a nice way to ask that keys aren't used more than we want them to. The security vocab spec also recommends to set expiration time on keys, so it's nice to support this feature. --- config/models | 7 ++--- migrations/2019_02_03_verifkey.model | 7 ++--- src/Vervis/Foundation.hs | 39 ++++++++++++++++++---------- src/Vervis/Handler/Person.hs | 11 ++++---- src/Web/ActivityPub.hs | 20 ++++++++------ 5 files changed, 51 insertions(+), 33 deletions(-) diff --git a/config/models b/config/models index 731fbc3..5088aeb 100644 --- a/config/models +++ b/config/models @@ -40,9 +40,10 @@ Person UniquePersonEmail email VerifKey - ident URI - public PublicKey - sharer RemoteSharerId + ident URI + expires UTCTime Maybe + public PublicKey + sharer RemoteSharerId UniqueVerifKey ident diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index a253a2e..8ae8e16 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -1,7 +1,8 @@ VerifKey - ident String - public ByteString - sharer RemoteSharerId + ident String + expires UTCTime Maybe + public ByteString + sharer RemoteSharerId UniqueVerifKey ident diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 323467c..eddce07 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -580,7 +580,7 @@ instance YesodHttpSig App where case signature sig of CryptoPassed s -> Right s CryptoFailed e -> Left "Parsing Ed25519 signature failed" - (mvkid, key, uActor) <- do + (mvkid, key, mexpires, uActor) <- do ments <- lift $ runDB $ do mvk <- getBy $ UniqueVerifKey u for mvk $ \ vk@(Entity _ verifkey) -> do @@ -591,27 +591,37 @@ instance YesodHttpSig App where return ( Just vkid , verifKeyPublic vk + , verifKeyExpires vk , remoteSharerIdent remote ) Nothing -> do - (k, ua) <- fetchKey' u - return (Nothing, k, ua) + (k, mexp, ua) <- fetchKey' u + return (Nothing, k, mexp, ua) let verify' k = verify k input signature - err = throwE "Ed25519 sig verification says not valid" + errSig = throwE "Ed25519 sig verification says not valid" + errTime = throwE "Key expired" existsInDB = isJust mvkid - (write, key') <- - if verify' key - then return (not existsInDB, key) + now <- liftIO getCurrentTime + let stillValid Nothing = True + stillValue (Just expires) = expires > now + (write, key', mexpires') <- + if verify' key && stillValid mexpires + then return (not existsInDB, key, mexpires) else if existsInDB then do - (newKey, newActor) <- fetchKey' u + (newKey, newExp, newActor) <- fetchKey' u if newActor == uActor then return () else throwE "Key owner changed, we reject that" + if stillValid newExp + then return () + else errTime if verify' newKey - then return (True, newKey) - else err - else err + then return (True, newKey, newExp) + else errSig + else if stillValid mexpires + then errSig + else errTime when write $ ExceptT $ runDB $ case mvkid of Nothing -> do @@ -619,17 +629,18 @@ instance YesodHttpSig App where case ment of Nothing -> do rsid <- insert $ RemoteSharer uActor - insert_ $ VerifKey u key' rsid + insert_ $ VerifKey u mexpires' key' rsid return $ Right () Just (Entity rsid rs) -> do n <- count [VerifKeySharer ==. rsid] if n < 2 then do - insert_ $ VerifKey u key' rsid + insert_ $ VerifKey u mexpires' key' rsid return $ Right () else return $ Left "We already store 2 keys" Just vkid -> do - update vkid [VerifKeyPublic =. key'] + update vkid + [VerifKeyExpires =. mexpires', VerifKeyPublic =. key'] return $ Right () return uActor where diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index b042d7f..f364132 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -155,11 +155,12 @@ getPersonR shr = do , actorInbox = route2uri InboxR , actorPublicKeys = PublicKeySet { publicKey1 = Right PublicKey - { publicKeyId = me { uriFragment = "#key" } - , publicKeyOwner = me - , publicKeyPem = PEM "PUBLIC KEY" [] actorKey - , publicKeyAlgo = Just AlgorithmEd25519 - , publicKeyShared = False + { publicKeyId = me { uriFragment = "#key" } + , publicKeyExpires = Nothing + , 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 71b6548..dbc6234 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -59,6 +59,7 @@ import Data.PEM import Data.Semigroup (Endo) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Time.Clock (UTCTime) import Network.HTTP.Client import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Client.Signature (signRequest) @@ -116,11 +117,12 @@ instance ToJSON Algorithm where AlgorithmOther t -> t data PublicKey = PublicKey - { publicKeyId :: URI - , publicKeyOwner :: URI - , publicKeyPem :: PEM - , publicKeyAlgo :: Maybe Algorithm - , publicKeyShared :: Bool + { publicKeyId :: URI + , publicKeyExpires :: Maybe UTCTime + , publicKeyOwner :: URI + , publicKeyPem :: PEM + , publicKeyAlgo :: Maybe Algorithm + , publicKeyShared :: Bool } instance FromJSON PublicKey where @@ -134,6 +136,7 @@ instance FromJSON PublicKey where else fail "PublicKey @type isn't Key" PublicKey <$> (parseHttpsURI =<< o .: "id") + <*> o .:? "expires" <*> (parseHttpsURI =<< o .: "owner") <*> (parsePEM =<< o .: "publicKeyPem") <*> o .:? (frg <> "algorithm") @@ -150,9 +153,10 @@ instance FromJSON PublicKey where instance ToJSON PublicKey where toJSON = error "toJSON PublicKey" - toEncoding (PublicKey id_ owner pem malgo shared) = + toEncoding (PublicKey id_ mexpires owner pem malgo shared) = pairs $ "id" .= renderURI id_ + <> "expires" .=? mexpires <> "owner" .= renderURI owner <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem) <> (frg <> "algorithm") .=? malgo @@ -362,7 +366,7 @@ fetchKey => Manager -> Bool -> URI - -> m (Either String (E.PublicKey, URI)) + -> m (Either String (E.PublicKey, Maybe UTCTime, URI)) fetchKey manager sigAlgo u = runExceptT $ do let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u @@ -418,5 +422,5 @@ fetchKey manager sigAlgo u = runExceptT $ do then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" else "No algo in Sig, unsupported algo in actor" case E.publicKey $ pemContent $ publicKeyPem pkey of - CryptoPassed k -> Right (k, actorId actor) + CryptoPassed k -> Right (k, publicKeyExpires pkey, actorId actor) CryptoFailed e -> Left "Parsing Ed25519 public key failed"