-- Copyright 2021 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | Delete audio checkpoints with no symlinks, and those over a certain age.
    This means they correspond to some older score state, so I can delete them
    and loading a new score will still likely hit the cache.

    If I update mtimes on cache hits, the minimum age should keep alive the
    previous few generations, so undo continues to hit them.

    A more sophisticated approach would be to keep an explicit generation
    count, so I could delete by generation, but this way is simpler and
    rerendering isn't a big deal.
-}
module Synth.ImGc (
    Stats(..)
    , showStats
    , gc
    , find
) where
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Time as Time

import qualified Streaming.Prelude as S
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))

import qualified Util.Files as Files
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty

import           Global


data Stats = Stats {
    Stats -> Set Text
_instruments :: !(Set Text)
    , Stats -> Int
_deletedFiles :: !Int
    , Stats -> Int
_deletedBytes :: !Bytes
    , Stats -> Int
_remaining :: !Bytes
    } deriving (Int -> Stats -> ShowS
[Stats] -> ShowS
Stats -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Stats] -> ShowS
$cshowList :: [Stats] -> ShowS
show :: Stats -> FilePath
$cshow :: Stats -> FilePath
showsPrec :: Int -> Stats -> ShowS
$cshowsPrec :: Int -> Stats -> ShowS
Show)

type Bytes = Int

instance Semigroup Stats where
    Stats Set Text
a1 Int
a2 Int
a3 Int
a4 <> :: Stats -> Stats -> Stats
<> Stats Set Text
b1 Int
b2 Int
b3 Int
b4 =
        Set Text -> Int -> Int -> Int -> Stats
Stats (Set Text
a1forall a. Semigroup a => a -> a -> a
<>Set Text
b1) (Int
a2forall a. Num a => a -> a -> a
+Int
b2) (Int
a3forall a. Num a => a -> a -> a
+Int
b3) (Int
a4forall a. Num a => a -> a -> a
+Int
b4)
instance Monoid Stats where
    mappend :: Stats -> Stats -> Stats
mappend = forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: Stats
mempty = Set Text -> Int -> Int -> Int -> Stats
Stats forall a. Monoid a => a
mempty Int
0 Int
0 Int
0

showStats :: Stats -> Text
showStats :: Stats -> Text
showStats (Stats Set Text
instruments Int
deletedFiles Int
deletedBytes Int
remaining) =
    Text -> [Text] -> Text
Text.intercalate Text
", "
        [ Text
"GC freed " forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
Pretty.bytes Int
2 Int
deletedBytes
            forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
deletedFiles forall a. Semigroup a => a -> a -> a
<> Text
" files)"
        , Text
"remaining " forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
Pretty.bytes Int
2 Int
remaining
        , forall a. Show a => a -> Text
showt (forall a. Set a -> Int
Set.size Set Text
instruments) forall a. Semigroup a => a -> a -> a
<> Text
" instruments"
        ]

-- | Files younger than this always live.
minimumAge :: Time.NominalDiffTime
minimumAge :: NominalDiffTime
minimumAge = NominalDiffTime
10 forall a. Num a => a -> a -> a
* NominalDiffTime
min
    where min :: NominalDiffTime
min = NominalDiffTime
60

gc :: FilePath -> IO Stats
gc :: FilePath -> IO Stats
gc FilePath
root = do
    UTCTime
now <- IO UTCTime
Time.getCurrentTime
    forall (m :: * -> *) w a r.
(Monad m, Monoid w) =>
(a -> m w) -> Stream (Of a) m r -> m w
foldMapM (UTCTime -> (FilePath, [FilePath]) -> IO Stats
check UTCTime
now) forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool)
-> FilePath -> Stream (Of (FilePath, [FilePath])) IO ()
Files.walk (forall a b. a -> b -> a
const Bool
True) FilePath
root
    where
    check :: UTCTime -> (FilePath, [FilePath]) -> IO Stats
check UTCTime
now (FilePath
dir, [FilePath]
fnames)
        | ShowS
FilePath.takeFileName FilePath
dir forall a. Eq a => a -> a -> Bool
/= FilePath
"checkpoint" = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        | Bool
otherwise = do
            Set FilePath
garbage <- forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> FilePath -> [FilePath] -> IO [FilePath]
findGarbage UTCTime
now FilePath
dir [FilePath]
fnames
            Integer
deleted <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$
                forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO Integer
Directory.getFileSize (forall a. Set a -> [a]
Set.toList Set FilePath
garbage)
            Integer
remaining <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO Integer
Directory.getFileSize forall a b. (a -> b) -> a -> b
$
                forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set FilePath
garbage) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FilePath
dir</>) [FilePath]
fnames
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
Directory.removeFile Set FilePath
garbage
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Stats
                { _instruments :: Set Text
_instruments = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ FilePath -> Text
txt forall a b. (a -> b) -> a -> b
$
                    ShowS
FilePath.takeFileName forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.takeDirectory FilePath
dir
                , _deletedFiles :: Int
_deletedFiles = forall (t :: * -> *) a. Foldable t => t a -> Int
length Set FilePath
garbage
                , _deletedBytes :: Int
_deletedBytes = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
deleted
                , _remaining :: Int
_remaining = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
remaining
                }

find :: FilePath -> S.Stream (S.Of (Set FilePath)) IO ()
find :: FilePath -> Stream (Of (Set FilePath)) IO ()
find FilePath
root = do
    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime
    forall (m :: * -> *) a r.
Monad m =>
(a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m r
S.filter (forall a. Eq a => a -> a -> Bool
/=forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b r.
Monad m =>
(a -> m b) -> Stream (Of a) m r -> Stream (Of b) m r
S.mapM (forall {m :: * -> *}.
MonadIO m =>
UTCTime -> (FilePath, [FilePath]) -> m (Set FilePath)
check UTCTime
now) forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool)
-> FilePath -> Stream (Of (FilePath, [FilePath])) IO ()
Files.walk (forall a b. a -> b -> a
const Bool
True) FilePath
root
    where
    check :: UTCTime -> (FilePath, [FilePath]) -> m (Set FilePath)
check UTCTime
now (FilePath
dir, [FilePath]
fnames)
        | ShowS
FilePath.takeFileName FilePath
dir forall a. Eq a => a -> a -> Bool
/= FilePath
"checkpoint" = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        | Bool
otherwise = forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (UTCTime -> FilePath -> [FilePath] -> IO [FilePath]
findGarbage UTCTime
now FilePath
dir [FilePath]
fnames)

-- | Any file with a ###.wav symlink is alive, or with the same prefix.
-- So 000.wav -> checkpoint/000.hash.hash.wav, and also
-- 000.hash.hash.state.hash and 000.hash.hash.wav.peaks.
findGarbage :: Time.UTCTime -> FilePath -> [FilePath] -> IO [FilePath]
findGarbage :: UTCTime -> FilePath -> [FilePath] -> IO [FilePath]
findGarbage UTCTime
now FilePath
checkpoint [FilePath]
fnames = do
    [FilePath]
chunks <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
Directory.pathIsSymbolicLink
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
Files.list (ShowS
FilePath.takeDirectory FilePath
checkpoint)
    [FilePath]
alive <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO FilePath
Directory.getSymbolicLinkTarget [FilePath]
chunks
    ([FilePath]
young, [FilePath]
fnames) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM (UTCTime -> FilePath -> IO Bool
isYoung UTCTime
now forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
checkpoint</>)) [FilePath]
fnames
    -- ["000.FOBBmx5XVFmFDBvy6FaGtw.Pygpsv_oQ01n-YoqmJaGUg", ...]
    let prefixes :: [FilePath]
prefixes = forall a b. (a -> b) -> [a] -> [b]
map (ShowS
FilePath.dropExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FilePath.takeFileName)
            ([FilePath]
alive forall a. [a] -> [a] -> [a]
++ [FilePath]
young)
    let isAlive :: FilePath -> Bool
isAlive FilePath
fn = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` FilePath
fn) [FilePath]
prefixes
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FilePath
checkpoint</>) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
isAlive) [FilePath]
fnames

isYoung :: Time.UTCTime -> FilePath -> IO Bool
isYoung :: UTCTime -> FilePath -> IO Bool
isYoung UTCTime
now FilePath
fname = (forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
minimumAge) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime
now `Time.diffUTCTime`) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    FilePath -> IO UTCTime
Directory.getModificationTime FilePath
fname

foldMapM :: (Monad m, Monoid w) => (a -> m w) -> S.Stream (S.Of a) m r -> m w
foldMapM :: forall (m :: * -> *) w a r.
(Monad m, Monoid w) =>
(a -> m w) -> Stream (Of a) m r -> m w
foldMapM a -> m w
f = forall (m :: * -> *) x a b r.
Monad m =>
(x -> a -> m x) -> m x -> (x -> m b) -> Stream (Of a) m r -> m b
S.foldM_ (\ !w
accum a
a -> (w
accum<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m w
f a
a) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty) forall (m :: * -> *) a. Monad m => a -> m a
return