From 0912b8e2911d6c4b03b1660a48f098fdda18a764 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 23 Feb 2019 17:17:52 +0000 Subject: [PATCH] Use the DB for checking key usage by actors * When we refetch a personal key, we never need to separately fetch the actor * When we refetch a shared key, check usage in DB and insert usage to DB --- src/Vervis/Foundation.hs | 37 ++++----- src/Web/ActivityPub.hs | 157 +++++++++++++++++++++++++++++++-------- 2 files changed, 140 insertions(+), 54 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 2191181..b45acf0 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -623,10 +623,10 @@ keyListedByActorShared -> Text -> LocalURI -> LocalURI - -> Handler (Either String ()) + -> ExceptT String Handler () keyListedByActorShared manager iid vkid host luKey luActor = do mresult <- do - ments <- runDB $ do + ments <- lift $ runDB $ do mrs <- getBy $ UniqueRemoteSharer iid luActor for mrs $ \ (Entity rsid _) -> (rsid,) . isJust <$> @@ -638,7 +638,7 @@ keyListedByActorShared manager iid vkid host luKey luActor = do if used then Nothing else Just $ Just rsid - runExceptT $ for_ mresult $ \ mrsid -> do + for_ mresult $ \ mrsid -> do luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor) ExceptT $ runDB $ case mrsid of Nothing -> do @@ -655,7 +655,6 @@ keyListedByActorShared manager iid vkid host luKey luActor = do data VerifKeyDetail = VerifKeyDetail { vkdKeyId :: LocalURI - -- , vkdInboxOrId :: Either LocalURI VerifKeyId , vkdKey :: PublicKey , vkdExpires :: Maybe UTCTime , vkdActorId :: LocalURI @@ -675,6 +674,8 @@ instance YesodHttpSig App where (host, luKey) <- f2l <$> parseKeyId keyid signature <- parseSig sig mluActorHeader <- getActorHeader host + let sigAlgo = isJust malgo + manager <- getsYesod appHttpManager (inboxOrVkid, vkd) <- do ments <- lift $ runDB $ do mvk <- runMaybeT $ do @@ -700,10 +701,10 @@ instance YesodHttpSig App where Just u -> return u manager <- getsYesod appHttpManager let iid = verifKeyInstance vk - ExceptT $ keyListedByActorShared manager iid vkid host luKey ua + keyListedByActorShared manager iid vkid host luKey ua return (ua, True) return - ( Right vkid + ( Right (verifKeyInstance vk, vkid) , VerifKeyDetail { vkdKeyId = luKey , vkdKey = verifKeyPublic vk @@ -712,11 +713,10 @@ instance YesodHttpSig App where , vkdShared = s } ) - Nothing -> fetched2vkd luKey <$> fetchKey' host mluActorHeader luKey + Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager sigAlgo host mluActorHeader luKey let verify' k = verify k input signature errSig = throwE "Ed25519 sig verification says not valid" errTime = throwE "Key expired" - -- existsInDB = isRight $ vkdInboxOrId vkd now <- liftIO getCurrentTime let stillValid Nothing = True stillValid (Just expires) = expires > now @@ -724,21 +724,19 @@ instance YesodHttpSig App where if verify' (vkdKey vkd) && stillValid (vkdExpires vkd) then case inboxOrVkid of Left uinb -> ExceptT $ runDB $ addVerifKey host uinb vkd - Right _vkid -> return () + Right _ids -> return () else case inboxOrVkid of Left _uinb -> if stillValid $ vkdExpires vkd then errSig else errTime - Right vkid -> do - Fetched newKey newExp newActor _newInbox s <- fetchKey' host mluActorHeader luKey - if vkdShared vkd == s - then return () - else throwE "Key scope changed, we reject that" - unless (vkdShared vkd) $ - if newActor == vkdActorId vkd - then return () - else throwE "Key owner changed, we reject that" + Right (iid, vkid) -> do + let ua = vkdActorId vkd + listed = keyListedByActorShared manager iid vkid host luKey ua + (newKey, newExp) <- + if vkdShared vkd + then fetchKnownSharedKey manager listed sigAlgo host ua luKey + else fetchKnownPersonalKey manager sigAlgo host ua luKey if stillValid newExp then return () else errTime @@ -775,9 +773,6 @@ instance YesodHttpSig App where else Left "Key and actor have different hosts" Right lu _ -> throwE "Multiple ActivityPub-Actor headers" - fetchKey' h mua uk = do - manager <- getsYesod appHttpManager - ExceptT $ fetchKey manager (isJust malgo) h mua uk fetched2vkd uk (Fetched k mexp ua uinb s) = ( Left uinb , VerifKeyDetail diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 5c5dce2..1421cfa 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -47,7 +47,9 @@ module Web.ActivityPub , Fetched (..) , fetchAPID , keyListedByActor - , fetchKey + , fetchUnknownKey + , fetchKnownPersonalKey + , fetchKnownSharedKey ) where @@ -485,12 +487,14 @@ data Fetched = Fetched fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a fetchAP m u = ExceptT $ bimap displayException responseBody <$> httpGetAP m u +{- fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a fetchAPH m h lu = do Doc h' v <- fetchAP m $ l2f h lu if h == h' then return v else throwE "Object @id URI's host doesn't match the URI we fetched" +-} fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a) fetchAPID m getId h lu = runExceptT $ do @@ -535,15 +539,53 @@ keyListedByActor manager host luKey luActor = runExceptT $ do match (Right _) = False in match k1 || maybe False match mk2 -fetchKey +matchKeyObj luKey (PublicKeySet k1 mk2) = + let match' = match luKey + in case match' k1 <|> (match' =<< mk2) of + Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID" + Just pk -> return pk + where + match _ (Left _) = Nothing + match luk (Right pk) = + if publicKeyId pk == luk + then Just pk + else Nothing + +verifyAlgo sigAlgo Nothing = + Left $ + if sigAlgo + then "Algo mismatch, Ed25519 in Sig but none in actor" + else "Algo not given in Sig nor actor" +verifyAlgo sigAlgo (Just algo) = + case algo of + AlgorithmEd25519 -> Right () + AlgorithmOther _ -> + Left $ + if sigAlgo + then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" + else "No algo in Sig, unsupported algo in actor" + +parseKey pem = + case E.publicKey $ pemContent pem of + CryptoPassed k -> Right k + CryptoFailed _ -> Left "Parsing Ed25519 public key failed" + +-- | Fetch a key we don't have cached locally. +fetchUnknownKey :: MonadIO m => Manager + -- ^ Manager for making HTTP requests -> Bool + -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP + -- signature header -> Text + -- ^ Instance host -> Maybe LocalURI + -- ^ Actor URI possibly provided in the HTTP request's actor header -> LocalURI - -> m (Either String Fetched) -fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do + -- ^ Key URI provided in HTTP signature header + -> ExceptT String m Fetched +fetchUnknownKey manager sigAlgo host mluActor luKey = do obj <- fetchAPIDOrH manager publicKeyId host luKey (pem, mkFetched, malgo) <- case obj of @@ -603,32 +645,81 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do ExceptT . pure $ do verifyAlgo sigAlgo malgo mkFetched <$> parseKey pem - where - matchKeyObj luKey (PublicKeySet k1 mk2) = - let match' = match luKey - in case match' k1 <|> (match' =<< mk2) of - Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID" - Just pk -> return pk - where - match _ (Left _) = Nothing - match luk (Right pk) = - if publicKeyId pk == luk - then Just pk - else Nothing - verifyAlgo sigAlgo Nothing = - Left $ - if sigAlgo - then "Algo mismatch, Ed25519 in Sig but none in actor" - else "Algo not given in Sig nor actor" - verifyAlgo sigAlgo (Just algo) = - case algo of - AlgorithmEd25519 -> Right () - AlgorithmOther _ -> - Left $ - if sigAlgo - then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" - else "No algo in Sig, unsupported algo in actor" - parseKey pem = - case E.publicKey $ pemContent pem of - CryptoPassed k -> Right k - CryptoFailed _ -> Left "Parsing Ed25519 public key failed" + +keyDetail pk = (publicKeyPem pk, publicKeyExpires pk, publicKeyAlgo pk) + +-- | Fetch a personal key we already have cached locally, but we'd like to +-- refresh the local copy by fetching the key again from the server. +fetchKnownPersonalKey + :: MonadIO m + => Manager + -- ^ Manager for making HTTP requests + -> Bool + -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP + -- signature header + -> Text + -- ^ Instance host + -> LocalURI + -- ^ Key owner actor ID URI + -> LocalURI + -- ^ Key URI + -> ExceptT String m (E.PublicKey, Maybe UTCTime) +fetchKnownPersonalKey manager sigAlgo host luOwner luKey = do + obj <- fetchAPIDOrH manager publicKeyId host luKey + (pem, mexpires, malgo) <- + case obj of + Left pkey -> do + case publicKeyOwner pkey of + OwnerInstance -> throwE "Personal key became shared" + OwnerActor owner -> + when (luOwner /= owner) $ throwE "Key owner changed" + return $ keyDetail pkey + Right actor -> do + when (actorId actor /= luKey { luriFragment = "" }) $ + throwE "Actor ID doesn't match the keyid URI we fetched" + when (actorId actor /= luOwner) $ + throwE "Key owner changed" + pk <- matchKeyObj luKey $ actorPublicKeys actor + case publicKeyOwner pk of + OwnerInstance -> throwE "Personal key became shared" + OwnerActor owner -> + when (owner /= luOwner) $ + throwE "Actor's publicKey's owner doesn't match the actor's ID" + return $ keyDetail pk + ExceptT . pure $ do + verifyAlgo sigAlgo malgo + (, mexpires) <$> parseKey pem + +-- | Fetch a shared key we already have cached locally, but we'd like to +-- refresh the local copy by fetching the key again from the server. +fetchKnownSharedKey + :: MonadIO m + => Manager + -- ^ Manager for making HTTP requests + -> ExceptT String m () + -- ^ Action which checks whether the actor from HTTP actor header lists the + -- key, potentually updating our local cache if needed. + -> Bool + -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP + -- signature header + -> Text + -- ^ Instance host + -> LocalURI + -- ^ Actor ID from HTTP actor header + -> LocalURI + -- ^ Key URI + -> ExceptT String m (E.PublicKey, Maybe UTCTime) +fetchKnownSharedKey manager listed sigAlgo host luActor luKey = do + obj <- fetchAPIDOrH manager publicKeyId host luKey + pkey <- + case obj :: Either PublicKey Actor of + Left pk -> return pk + Right _actor -> throwE "Expected stand-alone key, got embedded key" + case publicKeyOwner pkey of + OwnerInstance -> return () + OwnerActor _owner -> throwE "Shared key became personal" + listed + let (pem, mexpires, malgo) = keyDetail pkey + ExceptT . pure $ do + verifyAlgo sigAlgo malgo + (, mexpires) <$> parseKey pem