Add key storage mode that replaces old keys instead of rejecting new ones

This commit is contained in:
fr33domlover 2019-02-26 14:00:22 +00:00
parent 2e705b6868
commit f09bdd4141
3 changed files with 225 additions and 79 deletions

View file

@ -129,3 +129,7 @@ capability-signing-key: config/capability_signing_key
# Salt file for encoding and decoding hashids
hashids-salt-file: config/hashids_salt
# Whether to reject an HTTP signature when we want to insert a new key or usage
# record but reached the limit setting
reject-on-max-keys: true

View file

@ -597,29 +597,126 @@ instanceAndActor host luActor luInbox = do
idAndNew (Left (Entity iid _)) = (iid, False)
idAndNew (Right iid) = (iid, True)
actorRoom :: RemoteSharerId -> AppDB Bool
actorRoom rsid = do
mn <- getsYesod $ appMaxActorKeys . appSettings
case mn of
Nothing -> pure True
Just n ->
sumUpTo n
(count [VerifKeySharedUsageUser ==. rsid])
(count [VerifKeySharer ==. Just rsid])
actorRoom :: Int -> RemoteSharerId -> AppDB Bool
actorRoom limit rsid = do
sumUpTo limit
(count [VerifKeySharedUsageUser ==. rsid])
(count [VerifKeySharer ==. Just rsid])
getOldUsageId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharedUsageUser ==. rsid] [Asc VerifKeySharedUsageId, LimitTo 1]
getOldPersonalKeyId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharer ==. Just rsid] [Asc VerifKeyExpires, Asc VerifKeyId, LimitTo 1]
makeActorRoomByPersonal limit rsid vkid = do
room <-
if limit <= 1
then return False
else (< limit-1) <$> count [VerifKeySharer ==. Just rsid, VerifKeyId !=. vkid]
unless room $ delete vkid
makeActorRoomByUsage limit rsid suid = do
room <-
if limit <= 1
then return False
else
sumUpTo (limit-1)
(count [VerifKeySharedUsageUser ==. rsid, VerifKeySharedUsageId !=. suid])
(count [VerifKeySharer ==. Just rsid])
unless room $ delete suid
-- | Checks whether the given actor has room left for a new shared key usage
-- record, and if not, deletes a record to make room for a new one. It prefers
-- to delete a usage record if any exist; otherwise it deletes a personal key.
--
-- The first parameter is the actor key storage limit, and it must be above
-- zero.
makeActorRoomForUsage :: Int -> RemoteSharerId -> AppDB ()
makeActorRoomForUsage limit rsid = do
msuid <- getOldUsageId rsid
case msuid of
Nothing -> do
mvkid <- getOldPersonalKeyId rsid
case mvkid of
Nothing -> return ()
Just vkid -> makeActorRoomByPersonal limit rsid vkid
Just suid -> makeActorRoomByUsage limit rsid suid
-- | Checks whether the given actor has room left for a new personal key
-- record, and if not, deletes a record to make room for a new one. It prefers
-- to delete a personal key if any exist; otherwise it deletes a usage record.
--
-- The first parameter is the actor key storage limit, and it must be above
-- zero.
makeActorRoomForPersonalKey :: Int -> RemoteSharerId -> AppDB ()
makeActorRoomForPersonalKey limit rsid = do
mvkid <- getOldPersonalKeyId rsid
case mvkid of
Nothing -> do
msuid <- getOldUsageId rsid
case msuid of
Nothing -> return ()
Just suid -> makeActorRoomByUsage limit rsid suid
Just vkid -> makeActorRoomByPersonal limit rsid vkid
-- | Checks whether the given instance has room left for a new shared key
-- record, and if not, deletes a record to make room for a new one.
--
-- The first parameter is the actor key storage limit, and it must be above
-- zero.
makeInstanceRoom :: Int -> InstanceId -> AppDB ()
makeInstanceRoom limit iid = do
mvk <- listToMaybe <$> selectList [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] [Asc VerifKeyExpires, Asc VerifKeyId, LimitTo 1]
case mvk of
Nothing -> return ()
Just (Entity vkid _) -> do
room <-
if limit <= 1
then return False
else (< limit-1) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing, VerifKeyId !=. vkid]
unless room $ delete vkid
data RoomModeDB
= RoomModeNoLimit
| RoomModeLimit Int
data RoomMode
= RoomModeInstant
| RoomModeCached RoomModeDB
roomModeFromLimit :: Maybe Int -> RoomMode
roomModeFromLimit Nothing = RoomModeCached $ RoomModeNoLimit
roomModeFromLimit (Just limit) =
if limit <= 0
then RoomModeInstant
else RoomModeCached $ RoomModeLimit limit
actorRoomMode :: AppSettings -> RoomMode
actorRoomMode = roomModeFromLimit . appMaxActorKeys
instanceRoomMode :: AppSettings -> RoomMode
instanceRoomMode = roomModeFromLimit . appMaxInstanceKeys
-- | 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 the storage limit on actor keys is zero:
-- - If we're supposed to reject signatures when there's no room, raise
-- an error! We can't store anything with a limit of 0
-- - Otherwise, fetch the actor, store in DB if we don't have it, verify
-- usage via actor JSON. Usage isn't stored in the DB.
-- * If there's no storage limit, or it's above zero:
-- - If we know the actor and we have a record that it lists the key,
-- return success, no other 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 the maximal number of
-- keys: If we're supposed to reject signatures when there's no room,
-- raise an error. Otherwise, delete an old key/usage and store the new
-- usage in the 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.
-- and the usage exist in our DB now (if the storage limit isn't zero).
keyListedByActorShared
:: Manager
-> InstanceId
@ -629,33 +726,46 @@ keyListedByActorShared
-> LocalURI
-> ExceptT String Handler ()
keyListedByActorShared manager iid vkid host luKey luActor = do
mresult <- do
ments <- lift $ runDB $ do
mrs <- getBy $ UniqueRemoteSharer iid luActor
for mrs $ \ (Entity rsid _) ->
(rsid,) . isJust <$>
getBy (UniqueVerifKeySharedUsage vkid rsid)
return $
case ments of
Nothing -> Just Nothing
Just (rsid, used) ->
if used
then Nothing
else Just $ Just rsid
for_ mresult $ \ mrsid -> do
luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
ExceptT $ runDB $ case mrsid of
Nothing -> do
rsid <- insert $ RemoteSharer luActor iid luInbox
insert_ $ VerifKeySharedUsage vkid rsid
return $ Right ()
Just rsid -> do
room <- actorRoom rsid
if room
then do
(reject, roomMode) <- do
s <- getsYesod appSettings
return (appRejectOnMaxKeys s, actorRoomMode s)
case roomMode of
RoomModeInstant -> do
when reject $ throwE "Actor key storage limit is 0 and set to reject"
luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
_ <- lift $ runDB $ insertUnique $ RemoteSharer luActor iid luInbox
return ()
RoomModeCached m -> do
mresult <- do
ments <- lift $ runDB $ do
mrs <- getBy $ UniqueRemoteSharer iid luActor
for mrs $ \ (Entity rsid _) ->
(rsid,) . isJust <$>
getBy (UniqueVerifKeySharedUsage vkid rsid)
return $
case ments of
Nothing -> Just Nothing
Just (rsid, used) ->
if used
then Nothing
else Just $ Just rsid
for_ mresult $ \ mrsid -> do
luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
ExceptT $ runDB $ case mrsid of
Nothing -> do
rsid <- insert $ RemoteSharer luActor iid luInbox
insert_ $ VerifKeySharedUsage vkid rsid
return $ Right ()
else return $ Left "Actor already has at least 2 keys"
Just rsid -> runExceptT $ do
case m of
RoomModeNoLimit -> return ()
RoomModeLimit limit -> do
if reject
then do
room <- lift $ actorRoom limit rsid
unless room $ throwE "Actor key storage limit reached"
else lift $ makeActorRoomForUsage limit rsid
lift $ insert_ $ VerifKeySharedUsage vkid rsid
data VerifKeyDetail = VerifKeyDetail
{ vkdKeyId :: LocalURI
@ -792,42 +902,58 @@ instance YesodHttpSig App where
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've reached key storage limit"
addSharedKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = runExceptT $ do
(reject, roomModeA, roomModeI) <- do
s <- getsYesod appSettings
return (appRejectOnMaxKeys s, actorRoomMode s, instanceRoomMode s)
(iid, rsid, inew) <- lift $ instanceAndActor host luActor luInbox
case roomModeI of
RoomModeInstant ->
when reject $ throwE "Instance key storage limit is 0 and set to reject"
RoomModeCached m -> do
case m of
RoomModeNoLimit -> return ()
RoomModeLimit limit ->
if reject
then when (isJust inew) $ do
room <- lift $ instanceRoom limit iid
unless room $ throwE "Instance key storage limit reached"
else when (isJust inew) $ lift $ makeInstanceRoom limit iid
vkid <- lift $ insert $ VerifKey luKey iid mexpires key Nothing
case roomModeA of
RoomModeInstant ->
when reject $ throwE "Actor key storage limit is 0 and set to reject"
RoomModeCached m -> do
case m of
RoomModeNoLimit -> return ()
RoomModeLimit limit ->
if reject
then when (inew == Just False) $ do
room <- lift $ actorRoom limit rsid
unless room $ throwE "Actor key storage limit reached"
else when (inew == Just False) $ lift $ makeActorRoomForUsage limit rsid
lift $ insert_ $ VerifKeySharedUsage vkid rsid
where
instanceRoom iid = do
mn <- getsYesod $ appMaxInstanceKeys . appSettings
case mn of
Nothing -> pure True
Just n ->
(< n) <$> 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've reached key storage limit"
instanceRoom n iid =
(< n) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = runExceptT $ do
(reject, roomMode) <- do
s <- getsYesod appSettings
return (appRejectOnMaxKeys s, actorRoomMode s)
(iid, rsid, inew) <- lift $ instanceAndActor host luActor luInbox
case roomMode of
RoomModeInstant ->
when reject $ throwE "Actor key storage limit is 0 and set to reject"
RoomModeCached m -> do
case m of
RoomModeNoLimit -> return ()
RoomModeLimit limit ->
if reject
then when (inew == Just False) $ do
room <- lift $ actorRoom limit rsid
unless room $ throwE "Actor key storage limit reached"
else when (inew == Just False) $ lift $ makeActorRoomForPersonalKey limit rsid
lift $ insert_ $ VerifKey luKey iid mexpires key (Just rsid)
updateVerifKey vkid vkd =
update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]

View file

@ -109,10 +109,25 @@ data AppSettings = AppSettings
-- details. If set to 'Nothing', no email will be sent.
, appMail :: Maybe MailSettings
-- Signing key file for signing object capabilities sent to remote users
-- | Signing key file for signing object capabilities sent to remote
-- users
, appCapabilitySigningKeyFile :: FilePath
-- Salt for encoding and decoding hashids
-- | Salt for encoding and decoding hashids
, appHashidsSaltFile :: FilePath
-- | What do to when we wish to insert a new 'VerifKey' or
-- 'VerifKeySharedUsage' into the database, but we've reached the
-- configured storage limit.
--
-- 'True' means we simply reject HTTP signatures when it happens, which
-- means we basically don't support servers that use more keys or custom
-- setup other than what Vervis does.
--
-- 'False' means we do accept HTTP signatures even if we've reached the
-- storage limit setting. We simply handle it by remembering only the
-- amount of keys the limit allows, and otherwise we have to refetch keys
-- over HTTP, which possibly means we have to do more HTTP key fetching,
-- and the target server gets a higher load of key fetch GET requests.
, appRejectOnMaxKeys :: Bool
}
instance FromJSON AppSettings where
@ -156,6 +171,7 @@ instance FromJSON AppSettings where
appCapabilitySigningKeyFile <- o .: "capability-signing-key"
appHashidsSaltFile <- o .: "hashids-salt-file"
appRejectOnMaxKeys <- o .: "reject-on-max-keys"
return AppSettings {..}