From f09bdd4141c424ee5091cc15869e61869203814f Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 26 Feb 2019 14:00:22 +0000 Subject: [PATCH] Add key storage mode that replaces old keys instead of rejecting new ones --- config/settings-default.yaml | 4 + src/Vervis/Foundation.hs | 280 +++++++++++++++++++++++++---------- src/Vervis/Settings.hs | 20 ++- 3 files changed, 225 insertions(+), 79 deletions(-) diff --git a/config/settings-default.yaml b/config/settings-default.yaml index 7d1bd98..52d1f11 100644 --- a/config/settings-default.yaml +++ b/config/settings-default.yaml @@ -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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 3c34255..558ce07 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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] diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index 508e289..a6a2e5a 100644 --- a/src/Vervis/Settings.hs +++ b/src/Vervis/Settings.hs @@ -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 {..}