mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-29 03:14:51 +09:00
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
This commit is contained in:
fr33domlover
parent
b53a7b4f48
commit
0912b8e291
2 changed files with 140 additions and 54 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue