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

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

migrations/2019_02_03_verifkey.model

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

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

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

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