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"