diff --git a/src/RPKI/Config.hs b/src/RPKI/Config.hs index 7ba65c86..c9d7902e 100644 --- a/src/RPKI/Config.hs +++ b/src/RPKI/Config.hs @@ -268,7 +268,7 @@ defaultConfig = Config { rtrConfig = Nothing, cacheCleanupInterval = Seconds $ 60 * 60 * 6, cacheLifeTime = Seconds $ 60 * 60 * 24, - versionNumberToKeep = 100, + versionNumberToKeep = 3, storageCompactionInterval = Seconds $ 60 * 60 * 120, rsyncCleanupInterval = Seconds $ 60 * 60 * 24 * 30, lmdbSizeMb = Size $ 32 * 1024, diff --git a/src/RPKI/Store/AppLmdbStorage.hs b/src/RPKI/Store/AppLmdbStorage.hs index 512c73dc..239a14c8 100644 --- a/src/RPKI/Store/AppLmdbStorage.hs +++ b/src/RPKI/Store/AppLmdbStorage.hs @@ -206,7 +206,7 @@ compactStorageWithTmpDir appContext@AppContext {..} = do Size lmdbFileSize <- cacheFsSize appContext let fileSizeMb :: Integer = fromIntegral $ lmdbFileSize `div` (1024 * 1024) - logInfo logger [i|New LMDB file size is #{fileSizeMb}mb, will perform compaction.|] + logInfo logger [i|LMDB file size after compaction is #{fileSizeMb}mb.|] Size lmdbFileSize <- cacheFsSize appContext diff --git a/src/RPKI/Store/Database.hs b/src/RPKI/Store/Database.hs index 41bc71b8..4d48e939 100644 --- a/src/RPKI/Store/Database.hs +++ b/src/RPKI/Store/Database.hs @@ -68,13 +68,13 @@ import RPKI.Time -- It is brittle and inconvenient, but so far seems to be -- the only realistic option. currentDatabaseVersion :: Integer -currentDatabaseVersion = 33 +currentDatabaseVersion = 34 -- Some constant keys -databaseVersionKey, lastValidMftKey, forAsyncFetchKey :: Text +databaseVersionKey, forAsyncFetchKey, validatedByVersionKey :: Text databaseVersionKey = "database-version" -lastValidMftKey = "last-valid-mft" forAsyncFetchKey = "for-async-fetch" +validatedByVersionKey = "validated-by-version-map" data EraseWrapper s where EraseWrapper :: forall t s . (Storage s, CanErase s t) => t -> EraseWrapper s @@ -122,7 +122,7 @@ data RpkiObjectStore s = RpkiObjectStore { certBySKI :: SMap "cert-by-ski" s SKI ObjectKey, objectMetas :: SMap "object-meta" s ObjectKey ObjectMeta, - validatedByVersion :: SMap "validated-by-version" s WorldVersion (Compressed (Set.Set ObjectKey)), + validatedByVersion :: SMap "validated-by-version" s Text (Compressed (Map.Map ObjectKey WorldVersion)), -- Object URL mapping uriToUriKey :: SMap "uri-to-uri-key" s SafeUrlAsKey UrlKey, @@ -516,21 +516,9 @@ markAsValidated :: (MonadIO m, Storage s) => Tx s 'RW -> DB s -> Set.Set ObjectKey -> WorldVersion -> m () -markAsValidated tx db@DB { objectStore = RpkiObjectStore {..} } allKeys worldVersion = liftIO $ do - existingVersions <- validationVersions tx db - - M.put tx validatedByVersion worldVersion (Compressed allKeys) - case existingVersions of - [] -> pure () - _ -> do - -- This is an optimisation, but a necessary one: - -- Delete 'validatedKeys' from the previous version if - -- they are present in the last one. In most cases it - -- will delete most of the entries. - let previousVersion = List.maximum existingVersions - ifJustM (M.get tx validatedByVersion previousVersion) $ \(Compressed previousKeys) -> - M.put tx validatedByVersion previousVersion $ - Compressed $ previousKeys `Set.difference` allKeys +markAsValidated tx db allKeys worldVersion = + liftIO $ void $ updateValidatedByVersionMap tx db $ \m -> + foldr (\k -> Map.insert k worldVersion) (fromMaybe mempty m) allKeys -- This is for testing purposes mostly @@ -784,6 +772,27 @@ saveCurrentDatabaseVersion tx DB { metadataStore = MetadataStore s } = liftIO $ M.put tx s databaseVersionKey (Text.pack $ show currentDatabaseVersion) +updateValidatedByVersionMap :: (MonadIO m, Storage s) + => Tx s 'RW + -> DB s + -> (Maybe (Map.Map ObjectKey WorldVersion) -> Map.Map ObjectKey WorldVersion) + -> m (Map.Map ObjectKey WorldVersion) +updateValidatedByVersionMap tx DB { objectStore = RpkiObjectStore {..} } f = liftIO $ do + validatedBy <- M.get tx validatedByVersion validatedByVersionKey + let validatedBy' = f $ fmap unCompressed validatedBy + M.put tx validatedByVersion validatedByVersionKey $ Compressed validatedBy' + pure validatedBy' + + +cleanupValidatedByVersionMap :: (MonadIO m, Storage s) => + Tx s RW + -> DB s + -> (WorldVersion -> Bool) + -> m (Map.Map ObjectKey WorldVersion) +cleanupValidatedByVersionMap tx db toDelete = liftIO $ do + updateValidatedByVersionMap tx db $ + maybe mempty $ Map.filter (not . toDelete) + -- More complicated operations data CleanUpResult = CleanUpResult { @@ -821,11 +830,13 @@ deleteOldestVersionsIfNeeded tx db versionNumberToKeep = let reallyToKeep = max 2 (fromIntegral versionNumberToKeep) if length versions > reallyToKeep then do - let toDelete = drop reallyToKeep $ List.sortOn Down versions - forM_ toDelete $ \v -> do + let versionsToDelete = drop reallyToKeep $ List.sortOn Down versions + forM_ versionsToDelete $ \v -> do deletePayloads tx db v - deleteVersion tx db v - pure toDelete + deleteVersion tx db v + let toDeleteSet = Set.fromList versionsToDelete + void $ cleanupValidatedByVersionMap tx db (`Set.member` toDeleteSet) + pure versionsToDelete else pure [] @@ -842,36 +853,31 @@ deleteStaleContent db@DB { objectStore = RpkiObjectStore {..} } tooOld = deleteOldNonValidationVersions tx db tooOld versions <- roTx db (`validationVersions` db) - let (toDelete, toKeep) = List.partition tooOld versions + let versionsToDelete = filter tooOld versions rwTx db $ \tx -> do -- delete versions and payloads associated with them, -- e.g. VRPs, ASPAs, BGPSec certificatees, etc. - forM_ toDelete $ \version -> do + forM_ versionsToDelete $ \version -> do deleteVersion tx db version - deletePayloads tx db version - M.delete tx validatedByVersion version - - (deletedObjects, keptObjects) <- deleteStaleObjects tx toKeep + deletePayloads tx db version + + validatedByRecentVersions <- cleanupValidatedByVersionMap tx db tooOld + + (deletedObjects, keptObjects) <- deleteStaleObjects tx validatedByRecentVersions -- Delete URLs that are now not referred by any object deletedURLs <- deleteDanglingUrls db tx pure CleanUpResult {..} where - deleteStaleObjects tx versionsToKeep = do + deleteStaleObjects tx validatedByRecentVersions = do -- Set of all objects touched by validation with versions -- that are not "too old". - touchedObjectKeys <- foldM - (\allKeys version -> - M.get tx validatedByVersion version >>= \case - Nothing -> pure $! allKeys - Just (Compressed keys') -> pure $! allKeys <> keys') - mempty - versionsToKeep - - -- Objects inserted by validation with version that is not too old. - -- We want to preseve these objects in the cache even if they are + let touchedObjectKeys = Map.keysSet validatedByRecentVersions + + -- Objects inserted by validation with version that is not "too old". + -- We want to preseve these objects in the cache even if they were -- never used, they may still be used later. That may happens if -- a repository updates a manifest aftert updating its children. recentlyInsertedObjectKeys <- M.fold tx objectMetas