Merge pull request #220 from lolepezy/optimise/remove-multiple-versions

Do no store many older versions of payloads

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,

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 
 

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