Merge pull request #3698 from input-output-hk/adinapoli/feature/cbr-460

[CBR-460] Improve the archive pruner

pkgs/default.nix

@@ -18120,6 +18120,7 @@ license = stdenv.lib.licenses.mit;
 , string-conv
 , swagger2
 , tabl
+, tar
 , text
 , time
 , time-units
@@ -18136,6 +18137,7 @@ license = stdenv.lib.licenses.mit;
 , x509
 , x509-store
 , yaml
+, zlib
 }:
 mkDerivation {
 
@@ -18224,6 +18226,7 @@ sqlite-simple
 sqlite-simple-errors
 stm
 swagger2
+tar
 text
 time
 time-units
@@ -18239,6 +18242,7 @@ wai-middleware-throttle
 warp
 x509
 x509-store
+zlib
 ];
 executableHaskellDepends = [
 aeson

wallet-new/cardano-sl-wallet-new.cabal

@@ -241,6 +241,7 @@ library
                      , stm
                      , stm
                      , swagger2
+                     , tar
                      , text
                      , time
                      , time-units
@@ -256,6 +257,7 @@ library
                      , warp
                      , x509
                      , x509-store
+                     , zlib
 
   default-language:    Haskell2010
   default-extensions: TypeOperators

wallet-new/src/Cardano/Wallet/Server/Plugins/AcidState.hs

@@ -9,11 +9,18 @@ import           Universum
 
 import           Control.Concurrent (threadDelay)
 import           Data.Acid (AcidState, createArchive, createCheckpoint)
+import qualified Data.ByteString.Lazy as B
+import           Data.List (isInfixOf)
+import           Data.Time (defaultTimeLocale, formatTime, getCurrentTime,
+                     iso8601DateFormat)
 import           Data.Time.Units (Minute, toMicroseconds)
 import           System.Directory (getModificationTime, listDirectory,
                      removeFile)
 import           System.FilePath ((</>))
 
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Compression.GZip as GZip
+
 import           Pos.Util.Wlog (logError, logInfo)
 
 import           Cardano.Wallet.Kernel (DatabaseMode (..), DatabaseOptions (..))
@@ -37,25 +44,57 @@ createAndArchiveCheckpoints dbRef delay dbMode =
     go dbPath = do
         logInfo "createAndArchiveCheckpoints is starting..."
 
-        res <- liftIO . try $ do
-            createCheckpoint dbRef
-            createArchive dbRef
+        res <- try $ do
+            liftIO (createCheckpoint dbRef >> createArchive dbRef)
+            pruneAndCompress 3 dbPath
         case res of
              Left (err :: SomeException) -> logError (show err)
-             Right ()                    -> pruneOldArchives dbPath
+             Right ()                    -> return ()
 
         --  Wait for the next compaction cycle.
         liftIO . threadDelay . fromInteger $ toMicroseconds delay
-    -- Prunes old acid-state archives.
-    pruneOldArchives :: FilePath -> Kernel.WalletMode ()
-    pruneOldArchives dbPath = liftIO $ do
-        let archiveDir = dbPath </> "Archive"
-        archiveCheckpoints <- map (archiveDir </>) <$> listDirectory archiveDir
-        -- same files, but newest first
-        newestFirst <-
-            map fst . reverse . sortWith snd <$>
-            mapM (\f -> (f,) <$> liftIO (getModificationTime f)) archiveCheckpoints
-        let oldFiles = drop 10 newestFirst
-        forM_ oldFiles removeFile
-
-        logInfo ("pruneOldArchives pruned " <> show (length oldFiles) <> " old archives.")
+
+-- | Prunes old acid-state archives, keeping only the most @n@ recent of them.
+-- After the clean-up it tar and gzip compressed them.
+pruneAndCompress :: Int
+                 -- ^ How many to keep.
+                 -> FilePath
+                 -- ^ The path to the database folder
+                 -> Kernel.WalletMode ()
+pruneAndCompress n dbPath = liftIO $ do
+    let archiveDir  = dbPath </> "Archive"
+        fullRelPath = (archiveDir </>)
+    archives <- listDirectory archiveDir
+
+    newestFirst <-
+        map fst . reverse . sortWith snd <$>
+        sequence [(f,) <$> getModificationTime (fullRelPath f) | f <- archives]
+
+    -- Partition the files into @toPrune@ and @toCompress@ (the @n@ newest).
+    -- Filter from the first subset any previously-created tarball.
+    let (toCompress, toPrune) = first (filter (not . isTarball))
+                              . splitAt n
+                              $ newestFirst
+
+    -- Prune the old archives (including tarballs, if necessary).
+    mapM_ (removeFile . fullRelPath) toPrune
+    logInfo ("pruneAndCompress pruned " <> show (length toPrune) <> " old archives.")
+
+    now <- getCurrentTime
+    let tarName = "archive_"
+                <> formatTime defaultTimeLocale (iso8601DateFormat (Just "%H_%M_%S")) now
+                <> ".tar.gz"
+
+    -- Compress and archive (no pun intended) the rest.
+    -- As per documentation, 'Tar.pack' wants @toCompress@ to be relative paths
+    -- to @archiveDir@.
+    B.writeFile (archiveDir </> tarName) . GZip.compress
+                                         . Tar.write =<< Tar.pack archiveDir toCompress
+
+    logInfo ("pruneAndCompress compressed " <> show (length toCompress) <> " archives.")
+
+    -- Remove the archived files.
+    mapM_ (removeFile . fullRelPath) toCompress
+  where
+      isTarball :: FilePath -> Bool
+      isTarball fp = ".tar.gz" `isInfixOf` fp