sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-28 07:34:53 +09:00
Code Issues Activity

Support actor key expiration

Browse source 
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 2019-02-05 04:05:44 +00:00
parent 37b3416a41
commit c2c4e24497
5 changed files with 51 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/models
View file

@ -41,6 +41,7 @@ Person
VerifKey
ident URI
expires UTCTime Maybe
public PublicKey
sharer RemoteSharerId

1
migrations/2019_02_03_verifkey.model
View file

@ -1,5 +1,6 @@
VerifKey
ident String
expires UTCTime Maybe
public ByteString
sharer RemoteSharerId

39
src/Vervis/Foundation.hs
View file

@ -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

1
src/Vervis/Handler/Person.hs
View file

@ -156,6 +156,7 @@ getPersonR shr = do
, actorPublicKeys = PublicKeySet
{ publicKey1 = Right PublicKey
{ publicKeyId = me { uriFragment = "#key" }
, publicKeyExpires = Nothing
, publicKeyOwner = me
, publicKeyPem = PEM "PUBLIC KEY" [] actorKey
, publicKeyAlgo = Just AlgorithmEd25519

10
src/Web/ActivityPub.hs
View file

@ -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)
@ -117,6 +118,7 @@ instance ToJSON Algorithm where
data PublicKey = PublicKey
{ publicKeyId :: URI
, publicKeyExpires :: Maybe UTCTime
, publicKeyOwner :: URI
, publicKeyPem :: PEM
, publicKeyAlgo :: Maybe Algorithm
@ -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"