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

@@ -40,9 +40,10 @@ Person
     UniquePersonEmail email
 
 VerifKey
-    ident  URI
+    ident   URI
-    public PublicKey
+    expires UTCTime Maybe
-    sharer RemoteSharerId
+    public  PublicKey
+    sharer  RemoteSharerId
 
     UniqueVerifKey ident
 

migrations/2019_02_03_verifkey.model

@@ -1,7 +1,8 @@
 VerifKey
-    ident  String
+    ident   String
-    public ByteString
+    expires UTCTime Maybe
-    sharer RemoteSharerId
+    public  ByteString
+    sharer  RemoteSharerId
 
     UniqueVerifKey ident
 

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
+                    (k, mexp, ua) <- fetchKey' u
-                    return (Nothing, k, ua)
+                    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') <-
+        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
                     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)
+                            then return (True, newKey, newExp)
-                            else err
+                            else errSig
-                    else err
+                    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

src/Vervis/Handler/Person.hs

@@ -155,11 +155,12 @@ getPersonR shr = do
             , actorInbox      = route2uri InboxR
             , actorPublicKeys = PublicKeySet
                 { 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
                 }

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
+    { 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
@@ -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"