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.
This commit is contained in:
fr33domlover
parent
37b3416a41
commit
c2c4e24497
5 changed files with 51 additions and 33 deletions
|
|
@ -40,9 +40,10 @@ Person
|
||||||
UniquePersonEmail email
|
UniquePersonEmail email
|
||||||
|
|
||||||
VerifKey
|
VerifKey
|
||||||
ident URI
|
ident URI
|
||||||
public PublicKey
|
expires UTCTime Maybe
|
||||||
sharer RemoteSharerId
|
public PublicKey
|
||||||
|
sharer RemoteSharerId
|
||||||
|
|
||||||
UniqueVerifKey ident
|
UniqueVerifKey ident
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
VerifKey
|
VerifKey
|
||||||
ident String
|
ident String
|
||||||
public ByteString
|
expires UTCTime Maybe
|
||||||
sharer RemoteSharerId
|
public ByteString
|
||||||
|
sharer RemoteSharerId
|
||||||
|
|
||||||
UniqueVerifKey ident
|
UniqueVerifKey ident
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -580,7 +580,7 @@ instance YesodHttpSig App where
|
||||||
case signature sig of
|
case signature sig of
|
||||||
CryptoPassed s -> Right s
|
CryptoPassed s -> Right s
|
||||||
CryptoFailed e -> Left "Parsing Ed25519 signature failed"
|
CryptoFailed e -> Left "Parsing Ed25519 signature failed"
|
||||||
(mvkid, key, uActor) <- do
|
(mvkid, key, mexpires, uActor) <- do
|
||||||
ments <- lift $ runDB $ do
|
ments <- lift $ runDB $ do
|
||||||
mvk <- getBy $ UniqueVerifKey u
|
mvk <- getBy $ UniqueVerifKey u
|
||||||
for mvk $ \ vk@(Entity _ verifkey) -> do
|
for mvk $ \ vk@(Entity _ verifkey) -> do
|
||||||
|
|
@ -591,27 +591,37 @@ instance YesodHttpSig App where
|
||||||
return
|
return
|
||||||
( Just vkid
|
( Just vkid
|
||||||
, verifKeyPublic vk
|
, verifKeyPublic vk
|
||||||
|
, verifKeyExpires vk
|
||||||
, remoteSharerIdent remote
|
, remoteSharerIdent remote
|
||||||
)
|
)
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
(k, ua) <- fetchKey' u
|
(k, mexp, ua) <- fetchKey' u
|
||||||
return (Nothing, k, ua)
|
return (Nothing, k, mexp, ua)
|
||||||
let verify' k = verify k input signature
|
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
|
existsInDB = isJust mvkid
|
||||||
(write, key') <-
|
now <- liftIO getCurrentTime
|
||||||
if verify' key
|
let stillValid Nothing = True
|
||||||
then return (not existsInDB, key)
|
stillValue (Just expires) = expires > now
|
||||||
|
(write, key', mexpires') <-
|
||||||
|
if verify' key && stillValid mexpires
|
||||||
|
then return (not existsInDB, key, mexpires)
|
||||||
else if existsInDB
|
else if existsInDB
|
||||||
then do
|
then do
|
||||||
(newKey, newActor) <- fetchKey' u
|
(newKey, newExp, newActor) <- fetchKey' u
|
||||||
if newActor == uActor
|
if newActor == uActor
|
||||||
then return ()
|
then return ()
|
||||||
else throwE "Key owner changed, we reject that"
|
else throwE "Key owner changed, we reject that"
|
||||||
|
if stillValid newExp
|
||||||
|
then return ()
|
||||||
|
else errTime
|
||||||
if verify' newKey
|
if verify' newKey
|
||||||
then return (True, newKey)
|
then return (True, newKey, newExp)
|
||||||
else err
|
else errSig
|
||||||
else err
|
else if stillValid mexpires
|
||||||
|
then errSig
|
||||||
|
else errTime
|
||||||
when write $ ExceptT $ runDB $
|
when write $ ExceptT $ runDB $
|
||||||
case mvkid of
|
case mvkid of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
|
|
@ -619,17 +629,18 @@ instance YesodHttpSig App where
|
||||||
case ment of
|
case ment of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
rsid <- insert $ RemoteSharer uActor
|
rsid <- insert $ RemoteSharer uActor
|
||||||
insert_ $ VerifKey u key' rsid
|
insert_ $ VerifKey u mexpires' key' rsid
|
||||||
return $ Right ()
|
return $ Right ()
|
||||||
Just (Entity rsid rs) -> do
|
Just (Entity rsid rs) -> do
|
||||||
n <- count [VerifKeySharer ==. rsid]
|
n <- count [VerifKeySharer ==. rsid]
|
||||||
if n < 2
|
if n < 2
|
||||||
then do
|
then do
|
||||||
insert_ $ VerifKey u key' rsid
|
insert_ $ VerifKey u mexpires' key' rsid
|
||||||
return $ Right ()
|
return $ Right ()
|
||||||
else return $ Left "We already store 2 keys"
|
else return $ Left "We already store 2 keys"
|
||||||
Just vkid -> do
|
Just vkid -> do
|
||||||
update vkid [VerifKeyPublic =. key']
|
update vkid
|
||||||
|
[VerifKeyExpires =. mexpires', VerifKeyPublic =. key']
|
||||||
return $ Right ()
|
return $ Right ()
|
||||||
return uActor
|
return uActor
|
||||||
where
|
where
|
||||||
|
|
|
||||||
|
|
@ -155,11 +155,12 @@ getPersonR shr = do
|
||||||
, actorInbox = route2uri InboxR
|
, actorInbox = route2uri InboxR
|
||||||
, actorPublicKeys = PublicKeySet
|
, actorPublicKeys = PublicKeySet
|
||||||
{ publicKey1 = Right PublicKey
|
{ publicKey1 = Right PublicKey
|
||||||
{ publicKeyId = me { uriFragment = "#key" }
|
{ publicKeyId = me { uriFragment = "#key" }
|
||||||
, publicKeyOwner = me
|
, publicKeyExpires = Nothing
|
||||||
, publicKeyPem = PEM "PUBLIC KEY" [] actorKey
|
, publicKeyOwner = me
|
||||||
, publicKeyAlgo = Just AlgorithmEd25519
|
, publicKeyPem = PEM "PUBLIC KEY" [] actorKey
|
||||||
, publicKeyShared = False
|
, publicKeyAlgo = Just AlgorithmEd25519
|
||||||
|
, publicKeyShared = False
|
||||||
}
|
}
|
||||||
, publicKey2 = Nothing
|
, publicKey2 = Nothing
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -59,6 +59,7 @@ import Data.PEM
|
||||||
import Data.Semigroup (Endo)
|
import Data.Semigroup (Endo)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||||
|
import Data.Time.Clock (UTCTime)
|
||||||
import Network.HTTP.Client
|
import Network.HTTP.Client
|
||||||
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
||||||
import Network.HTTP.Client.Signature (signRequest)
|
import Network.HTTP.Client.Signature (signRequest)
|
||||||
|
|
@ -116,11 +117,12 @@ instance ToJSON Algorithm where
|
||||||
AlgorithmOther t -> t
|
AlgorithmOther t -> t
|
||||||
|
|
||||||
data PublicKey = PublicKey
|
data PublicKey = PublicKey
|
||||||
{ publicKeyId :: URI
|
{ publicKeyId :: URI
|
||||||
, publicKeyOwner :: URI
|
, publicKeyExpires :: Maybe UTCTime
|
||||||
, publicKeyPem :: PEM
|
, publicKeyOwner :: URI
|
||||||
, publicKeyAlgo :: Maybe Algorithm
|
, publicKeyPem :: PEM
|
||||||
, publicKeyShared :: Bool
|
, publicKeyAlgo :: Maybe Algorithm
|
||||||
|
, publicKeyShared :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON PublicKey where
|
instance FromJSON PublicKey where
|
||||||
|
|
@ -134,6 +136,7 @@ instance FromJSON PublicKey where
|
||||||
else fail "PublicKey @type isn't Key"
|
else fail "PublicKey @type isn't Key"
|
||||||
PublicKey
|
PublicKey
|
||||||
<$> (parseHttpsURI =<< o .: "id")
|
<$> (parseHttpsURI =<< o .: "id")
|
||||||
|
<*> o .:? "expires"
|
||||||
<*> (parseHttpsURI =<< o .: "owner")
|
<*> (parseHttpsURI =<< o .: "owner")
|
||||||
<*> (parsePEM =<< o .: "publicKeyPem")
|
<*> (parsePEM =<< o .: "publicKeyPem")
|
||||||
<*> o .:? (frg <> "algorithm")
|
<*> o .:? (frg <> "algorithm")
|
||||||
|
|
@ -150,9 +153,10 @@ instance FromJSON PublicKey where
|
||||||
|
|
||||||
instance ToJSON PublicKey where
|
instance ToJSON PublicKey where
|
||||||
toJSON = error "toJSON PublicKey"
|
toJSON = error "toJSON PublicKey"
|
||||||
toEncoding (PublicKey id_ owner pem malgo shared) =
|
toEncoding (PublicKey id_ mexpires owner pem malgo shared) =
|
||||||
pairs
|
pairs
|
||||||
$ "id" .= renderURI id_
|
$ "id" .= renderURI id_
|
||||||
|
<> "expires" .=? mexpires
|
||||||
<> "owner" .= renderURI owner
|
<> "owner" .= renderURI owner
|
||||||
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
|
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
|
||||||
<> (frg <> "algorithm") .=? malgo
|
<> (frg <> "algorithm") .=? malgo
|
||||||
|
|
@ -362,7 +366,7 @@ fetchKey
|
||||||
=> Manager
|
=> Manager
|
||||||
-> Bool
|
-> Bool
|
||||||
-> URI
|
-> URI
|
||||||
-> m (Either String (E.PublicKey, URI))
|
-> m (Either String (E.PublicKey, Maybe UTCTime, URI))
|
||||||
fetchKey manager sigAlgo u = runExceptT $ do
|
fetchKey manager sigAlgo u = runExceptT $ do
|
||||||
let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a
|
let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a
|
||||||
fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
|
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"
|
then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
|
||||||
else "No algo in Sig, unsupported algo in actor"
|
else "No algo in Sig, unsupported algo in actor"
|
||||||
case E.publicKey $ pemContent $ publicKeyPem pkey of
|
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"
|
CryptoFailed e -> Left "Parsing Ed25519 public key failed"
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue