mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-16 08:25:08 +09:00
Refactor HTTP sig verification DB update code
This commit is contained in:
fr33domlover
parent
d3e14b3edf
commit
1affe269bb
2 changed files with 168 additions and 174 deletions
|
|
@ -603,7 +603,20 @@ actorRoom rsid =
|
|||
(count [VerifKeySharedUsageUser ==. rsid])
|
||||
(count [VerifKeySharer ==. Just rsid])
|
||||
|
||||
keyListedByActor'
|
||||
-- | Given a shared key we have in our DB, verify that the given actor lists
|
||||
-- this key, and update the DB accordingly.
|
||||
--
|
||||
-- * If we know the actor and we have a record that it lists the key, return
|
||||
-- success, otherwise no action
|
||||
-- * If we know the actor but we don't have a record of usage, fetch the
|
||||
-- actor and verify usage. If the actor already has 2 known keys, return
|
||||
-- error, otherwise store usage in DB.
|
||||
-- * If we don't know the actor, fetch actor, verify usage, store actor and
|
||||
-- usage in DB.
|
||||
--
|
||||
-- If we get success, that means the actor lists the key, and both the actor
|
||||
-- and the usage exist in our DB now.
|
||||
keyListedByActorShared
|
||||
:: Manager
|
||||
-> InstanceId
|
||||
-> VerifKeyId
|
||||
|
|
@ -611,7 +624,7 @@ keyListedByActor'
|
|||
-> LocalURI
|
||||
-> LocalURI
|
||||
-> Handler (Either String ())
|
||||
keyListedByActor' manager iid vkid host luKey luActor = do
|
||||
keyListedByActorShared manager iid vkid host luKey luActor = do
|
||||
mresult <- do
|
||||
ments <- runDB $ do
|
||||
mrs <- getBy $ UniqueRemoteSharer iid luActor
|
||||
|
|
@ -640,92 +653,15 @@ keyListedByActor' manager iid vkid host luKey luActor = do
|
|||
return $ Right ()
|
||||
else return $ Left "Actor already has at least 2 keys"
|
||||
|
||||
data AddVerifKey = AddVerifKey
|
||||
{ addvkHost :: Text
|
||||
, addvkKeyId :: LocalURI
|
||||
, addvkExpires :: Maybe UTCTime
|
||||
, addvkKey :: PublicKey
|
||||
, addvkActorId :: LocalURI
|
||||
, addvkActorInbox :: LocalURI
|
||||
}
|
||||
|
||||
addSharedKey :: AddVerifKey -> AppDB (Maybe String)
|
||||
addSharedKey (AddVerifKey host luKey mexpires key luActor luInbox) = do
|
||||
(iid, rsid, inew) <- instanceAndActor host luActor luInbox
|
||||
room <-
|
||||
case inew of
|
||||
Nothing -> pure True
|
||||
Just rsnew -> do
|
||||
iRoom <- instanceRoom iid
|
||||
if iRoom
|
||||
then if rsnew
|
||||
then pure True
|
||||
else actorRoom rsid
|
||||
else return False
|
||||
if room
|
||||
then do
|
||||
vkid <- insert $ VerifKey luKey iid mexpires key Nothing
|
||||
insert_ $ VerifKeySharedUsage vkid rsid
|
||||
return Nothing
|
||||
else return $ Just "We already store 2 keys"
|
||||
where
|
||||
instanceRoom iid =
|
||||
(< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
|
||||
|
||||
addPersonalKey :: AddVerifKey -> AppDB (Maybe String)
|
||||
addPersonalKey (AddVerifKey host luKey mexpires key luActor luInbox) = do
|
||||
(iid, rsid, inew) <- instanceAndActor host luActor luInbox
|
||||
room <-
|
||||
if inew == Just False
|
||||
then actorRoom rsid
|
||||
else pure True
|
||||
if room
|
||||
then do
|
||||
insert_ $ VerifKey luKey iid mexpires key (Just rsid)
|
||||
return Nothing
|
||||
else return $ Just "We already store 2 keys"
|
||||
|
||||
data UpdateVerifKey = UpdateVerifKey
|
||||
{ updvkId :: VerifKeyId
|
||||
, updvkExpires :: Maybe UTCTime
|
||||
, updvkKey :: PublicKey
|
||||
}
|
||||
|
||||
updateVerifKey :: UpdateVerifKey -> AppDB (Maybe String)
|
||||
updateVerifKey (UpdateVerifKey vkid mexpires key) = do
|
||||
update vkid [VerifKeyExpires =. mexpires, VerifKeyPublic =. key]
|
||||
return Nothing
|
||||
|
||||
data VerifKeyUpdate
|
||||
= VKUAddSharedKey AddVerifKey
|
||||
| VKUAddPersonalKey AddVerifKey
|
||||
| VKUUpdateKey UpdateVerifKey
|
||||
|
||||
updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String)
|
||||
updateVerifKeyInDB (VKUAddSharedKey avk) = addSharedKey avk
|
||||
updateVerifKeyInDB (VKUAddPersonalKey avk) = addPersonalKey avk
|
||||
updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk
|
||||
|
||||
data VerifKeyDetail = VerifKeyDetail
|
||||
{ vkdKeyId :: LocalURI
|
||||
, vkdInboxOrId :: Either LocalURI VerifKeyId
|
||||
-- , vkdInboxOrId :: Either LocalURI VerifKeyId
|
||||
, vkdKey :: PublicKey
|
||||
, vkdExpires :: Maybe UTCTime
|
||||
, vkdActorId :: LocalURI
|
||||
, vkdShared :: Bool
|
||||
}
|
||||
|
||||
makeVerifKeyUpdate :: Text -> VerifKeyDetail -> VerifKeyUpdate
|
||||
makeVerifKeyUpdate
|
||||
host (VerifKeyDetail luKey iori key mexpires luActor shared) =
|
||||
case iori of
|
||||
Left luInbox ->
|
||||
let avk = AddVerifKey host luKey mexpires key luActor luInbox
|
||||
in if shared
|
||||
then VKUAddSharedKey avk
|
||||
else VKUAddPersonalKey avk
|
||||
Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key
|
||||
|
||||
instance YesodHttpSig App where
|
||||
data HttpSigVerResult App = HttpSigVerResult (Either String FedURI)
|
||||
httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor]
|
||||
|
|
@ -735,32 +671,11 @@ instance YesodHttpSig App where
|
|||
toSeconds :: TimeInterval -> Second
|
||||
toSeconds = toTimeUnit
|
||||
httpVerifySig (Verification malgo (KeyId keyid) input (Signature sig)) = fmap HttpSigVerResult $ runExceptT $ do
|
||||
ExceptT . pure $ case malgo of
|
||||
Nothing -> Right ()
|
||||
Just algo ->
|
||||
case algo of
|
||||
S.AlgorithmEd25519 -> Right ()
|
||||
S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
|
||||
(host, luKey) <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of
|
||||
Left e -> Left $ "keyId in Sig header isn't a valid FedURI: " ++ e
|
||||
Right uri -> Right $ f2l uri
|
||||
signature <- ExceptT . pure $ do
|
||||
case signature sig of
|
||||
CryptoPassed s -> Right s
|
||||
CryptoFailed e -> Left "Parsing Ed25519 signature failed"
|
||||
mluActorHeader <- do
|
||||
bs <- lookupHeaders hActivityPubActor
|
||||
case bs of
|
||||
[] -> return Nothing
|
||||
[b] -> fmap Just . ExceptT . pure $ do
|
||||
t <- first displayException $ decodeUtf8' b
|
||||
(h, lu) <- f2l <$> parseFedURI t
|
||||
if h == host
|
||||
then Right ()
|
||||
else Left "Key and actor have different hosts"
|
||||
Right lu
|
||||
_ -> throwE "Multiple ActivityPub-Actor headers"
|
||||
vkd <- do
|
||||
verifySigAlgo malgo
|
||||
(host, luKey) <- f2l <$> parseKeyId keyid
|
||||
signature <- parseSig sig
|
||||
mluActorHeader <- getActorHeader host
|
||||
(inboxOrVkid, vkd) <- do
|
||||
ments <- lift $ runDB $ do
|
||||
mvk <- runMaybeT $ do
|
||||
Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
|
||||
|
|
@ -785,33 +700,37 @@ instance YesodHttpSig App where
|
|||
Just u -> return u
|
||||
manager <- getsYesod appHttpManager
|
||||
let iid = verifKeyInstance vk
|
||||
ExceptT $
|
||||
keyListedByActor' manager iid vkid host luKey ua
|
||||
ExceptT $ keyListedByActorShared manager iid vkid host luKey ua
|
||||
return (ua, True)
|
||||
return VerifKeyDetail
|
||||
return
|
||||
( Right vkid
|
||||
, VerifKeyDetail
|
||||
{ vkdKeyId = luKey
|
||||
, vkdInboxOrId = Right vkid
|
||||
, vkdKey = verifKeyPublic vk
|
||||
, vkdExpires = verifKeyExpires vk
|
||||
, vkdActorId = ua
|
||||
, vkdShared = s
|
||||
}
|
||||
)
|
||||
Nothing -> fetched2vkd luKey <$> fetchKey' 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
|
||||
-- existsInDB = isRight $ vkdInboxOrId vkd
|
||||
now <- liftIO getCurrentTime
|
||||
let stillValid Nothing = True
|
||||
stillValid (Just expires) = expires > now
|
||||
|
||||
mvkd <-
|
||||
if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
|
||||
then return $ if existsInDB
|
||||
then Nothing
|
||||
else Just vkd
|
||||
else if existsInDB
|
||||
then do
|
||||
then case inboxOrVkid of
|
||||
Left uinb -> ExceptT $ runDB $ addVerifKey host uinb vkd
|
||||
Right _vkid -> 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 ()
|
||||
|
|
@ -824,29 +743,90 @@ instance YesodHttpSig App where
|
|||
then return ()
|
||||
else errTime
|
||||
if verify' newKey
|
||||
then return $ Just vkd
|
||||
then lift $ runDB $ updateVerifKey vkid vkd
|
||||
{ vkdKey = newKey
|
||||
, vkdExpires = newExp
|
||||
}
|
||||
else errSig
|
||||
else if stillValid $ vkdExpires vkd
|
||||
then errSig
|
||||
else errTime
|
||||
|
||||
for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate host
|
||||
return $ l2f host $ vkdActorId vkd
|
||||
where
|
||||
verifySigAlgo = traverse_ $ \ algo ->
|
||||
case algo of
|
||||
S.AlgorithmEd25519 -> return ()
|
||||
S.AlgorithmOther _ -> throwE "Unsupported algo in Sig header"
|
||||
parseKeyId k =
|
||||
case parseFedURI =<< (first displayException . decodeUtf8') k of
|
||||
Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e
|
||||
Right u -> return u
|
||||
parseSig b =
|
||||
case signature b of
|
||||
CryptoPassed s -> return s
|
||||
CryptoFailed e -> throwE "Parsing Ed25519 signature failed"
|
||||
getActorHeader host = do
|
||||
bs <- lookupHeaders hActivityPubActor
|
||||
case bs of
|
||||
[] -> return Nothing
|
||||
[b] -> fmap Just . ExceptT . pure $ do
|
||||
t <- first displayException $ decodeUtf8' b
|
||||
(h, lu) <- f2l <$> parseFedURI t
|
||||
if h == host
|
||||
then Right ()
|
||||
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) = VerifKeyDetail
|
||||
fetched2vkd uk (Fetched k mexp ua uinb s) =
|
||||
( Left uinb
|
||||
, VerifKeyDetail
|
||||
{ vkdKeyId = uk
|
||||
, vkdInboxOrId = Left uinb
|
||||
, vkdKey = k
|
||||
, vkdExpires = mexp
|
||||
, vkdActorId = ua
|
||||
, vkdShared = s
|
||||
}
|
||||
)
|
||||
addVerifKey h uinb vkd =
|
||||
if vkdShared vkd
|
||||
then addSharedKey h uinb vkd
|
||||
else addPersonalKey h uinb vkd
|
||||
where
|
||||
addSharedKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do
|
||||
(iid, rsid, inew) <- instanceAndActor host luActor luInbox
|
||||
room <-
|
||||
case inew of
|
||||
Nothing -> pure True
|
||||
Just rsnew -> do
|
||||
iRoom <- instanceRoom iid
|
||||
if iRoom
|
||||
then if rsnew
|
||||
then pure True
|
||||
else actorRoom rsid
|
||||
else return False
|
||||
if room
|
||||
then do
|
||||
vkid <- insert $ VerifKey luKey iid mexpires key Nothing
|
||||
insert_ $ VerifKeySharedUsage vkid rsid
|
||||
return $ Right ()
|
||||
else return $ Left "We already store 2 keys"
|
||||
where
|
||||
instanceRoom iid =
|
||||
(< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
|
||||
addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do
|
||||
(iid, rsid, inew) <- instanceAndActor host luActor luInbox
|
||||
room <-
|
||||
if inew == Just False
|
||||
then actorRoom rsid
|
||||
else pure True
|
||||
if room
|
||||
then do
|
||||
insert_ $ VerifKey luKey iid mexpires key (Just rsid)
|
||||
return $ Right ()
|
||||
else return $ Left "We already store 2 keys"
|
||||
updateVerifKey vkid vkd =
|
||||
update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]
|
||||
|
||||
instance YesodBreadcrumbs App where
|
||||
breadcrumb route = return $ case route of
|
||||
|
|
|
|||
|
|
@ -545,23 +545,34 @@ fetchKey
|
|||
-> m (Either String Fetched)
|
||||
fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
|
||||
obj <- fetchAPIDOrH manager publicKeyId host luKey
|
||||
(actor, pkey) <-
|
||||
(pem, mkFetched, malgo) <-
|
||||
case obj of
|
||||
Left pkey -> do
|
||||
luActor <-
|
||||
(oi, luActor) <-
|
||||
case publicKeyOwner pkey of
|
||||
OwnerInstance ->
|
||||
case mluActor of
|
||||
Nothing -> throwE "Key is shared but actor header not specified!"
|
||||
Just u -> return u
|
||||
Just u -> return (True, u)
|
||||
OwnerActor owner -> do
|
||||
for_ mluActor $ \ lu ->
|
||||
if owner == lu
|
||||
then return ()
|
||||
else throwE "Key's owner doesn't match actor header"
|
||||
return owner
|
||||
actor <- ExceptT $ keyListedByActor manager host luKey luActor
|
||||
return (actor, pkey)
|
||||
return (False, owner)
|
||||
inbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
|
||||
return
|
||||
( publicKeyPem pkey
|
||||
, \ k ->
|
||||
Fetched
|
||||
{ fetchedPublicKey = k
|
||||
, fetchedKeyExpires = publicKeyExpires pkey
|
||||
, fetchedActorId = luActor
|
||||
, fetchedActorInbox = inbox
|
||||
, fetchedKeyShared = oi
|
||||
}
|
||||
, publicKeyAlgo pkey
|
||||
)
|
||||
Right actor -> do
|
||||
if actorId actor == luKey { luriFragment = "" }
|
||||
then return ()
|
||||
|
|
@ -581,15 +592,24 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
|
|||
Just pk ->
|
||||
case publicKeyOwner pk of
|
||||
OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
|
||||
OwnerActor _ -> return (actor, pk)
|
||||
ExceptT . pure $ do
|
||||
case publicKeyOwner pkey of
|
||||
OwnerInstance -> Right ()
|
||||
OwnerActor owner ->
|
||||
OwnerActor owner -> do
|
||||
if owner == actorId actor
|
||||
then Right ()
|
||||
else Left "Actor's publicKey's owner doesn't match the actor's ID"
|
||||
case publicKeyAlgo pkey of
|
||||
then return ()
|
||||
else throwE "Actor's publicKey's owner doesn't match the actor's ID"
|
||||
return
|
||||
( publicKeyPem pk
|
||||
, \ k ->
|
||||
Fetched
|
||||
{ fetchedPublicKey = k
|
||||
, fetchedKeyExpires = publicKeyExpires pk
|
||||
, fetchedActorId = owner
|
||||
, fetchedActorInbox = actorInbox actor
|
||||
, fetchedKeyShared = False
|
||||
}
|
||||
, publicKeyAlgo pk
|
||||
)
|
||||
ExceptT . pure $ do
|
||||
case malgo of
|
||||
Nothing ->
|
||||
Left $
|
||||
if sigAlgo
|
||||
|
|
@ -603,12 +623,6 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
|
|||
if sigAlgo
|
||||
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 Fetched
|
||||
{ fetchedPublicKey = k
|
||||
, fetchedKeyExpires = publicKeyExpires pkey
|
||||
, fetchedActorId = actorId actor
|
||||
, fetchedActorInbox = actorInbox actor
|
||||
, fetchedKeyShared = ownerShared $ publicKeyOwner pkey
|
||||
}
|
||||
case E.publicKey $ pemContent pem of
|
||||
CryptoPassed k -> Right $ mkFetched k
|
||||
CryptoFailed _ -> Left "Parsing Ed25519 public key failed"
|
||||
|
|
|
|||
Loading…
Reference in a new issue