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

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

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]
 

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 {..}