{-# LANGUAGE FlexibleContexts #-}

module Package.C.Db.GarbageCollect ( cleanSymlinks
                                   , cleanCache
                                   , garbageCollect
                                   ) where

import           Control.Monad.Reader  (MonadReader)
import           CPkgPrelude
import qualified Data.Set              as S
import qualified Data.Text             as T
import           Package.C.Db.Memory   (globalPkgDir)
import           Package.C.Db.Monad    (MonadDb)
import           Package.C.Db.Register
import           Package.C.Db.Type
import           Package.C.Logging     (putDiagnostic)
import           Package.C.Type        (TargetTriple, Verbosity)
import           System.Directory      (doesDirectoryExist, doesFileExist, getSymbolicLinkTarget, listDirectory, removeDirectoryRecursive, removeFile)
import           System.FilePath       ((</>))

getTransitiveDepsByName :: (MonadIO m, MonadDb m) => String -> Maybe TargetTriple -> m (S.Set BuildCfg)
getTransitiveDepsByName :: forall (m :: * -> *).
(MonadIO m, MonadDb m) =>
String -> Maybe TargetTriple -> m (Set BuildCfg)
getTransitiveDepsByName = BuildCfg -> m (Set BuildCfg)
forall (m :: * -> *).
(MonadIO m, MonadDb m) =>
BuildCfg -> m (Set BuildCfg)
getTransitiveDeps (BuildCfg -> m (Set BuildCfg))
-> (String -> Maybe TargetTriple -> m BuildCfg)
-> String
-> Maybe TargetTriple
-> m (Set BuildCfg)
forall (m :: * -> *) c d a b.
Monad m =>
(c -> m d) -> (a -> b -> m c) -> a -> b -> m d
<=*< String -> Maybe TargetTriple -> m BuildCfg
forall (m :: * -> *).
(MonadIO m, MonadDb m) =>
String -> Maybe TargetTriple -> m BuildCfg
lookupOrFail

garbageCollect :: (MonadIO m, MonadDb m, MonadReader Verbosity m)
               => m ()
garbageCollect :: forall (m :: * -> *).
(MonadIO m, MonadDb m, MonadReader Verbosity m) =>
m ()
garbageCollect = m ()
forall (m :: * -> *).
(MonadIO m, MonadDb m, MonadReader Verbosity m) =>
m ()
garbageCollectPkgs m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
forall (m :: * -> *). (MonadReader Verbosity m, MonadIO m) => m ()
cleanSymlinks

-- TODO: garbage collect old packages as well, and things which are broken b/c
-- their dependencies are gone
--
-- | @since 0.2.3.0
garbageCollectPkgs :: (MonadIO m, MonadDb m, MonadReader Verbosity m)
                   => m ()
garbageCollectPkgs :: forall (m :: * -> *).
(MonadIO m, MonadDb m, MonadReader Verbosity m) =>
m ()
garbageCollectPkgs = do
    Set BuildCfg
allPkgs <- m (Set BuildCfg)
forall (m :: * -> *). (MonadIO m, MonadDb m) => m (Set BuildCfg)
installedDb
    let manuals :: [BuildCfg]
manuals = (Set BuildCfg -> [BuildCfg]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set BuildCfg -> [BuildCfg])
-> (Set BuildCfg -> Set BuildCfg) -> Set BuildCfg -> [BuildCfg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildCfg -> Bool) -> Set BuildCfg -> Set BuildCfg
forall a. (a -> Bool) -> Set a -> Set a
S.filter BuildCfg -> Bool
manual) Set BuildCfg
allPkgs
    String -> m ()
forall (m :: * -> *).
(MonadReader Verbosity m, MonadIO m) =>
String -> m ()
putDiagnostic (String
"Manually installed packages: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (BuildCfg -> String
buildName (BuildCfg -> String) -> [BuildCfg] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BuildCfg]
manuals))
    Set BuildCfg
allDeps <- [Set BuildCfg] -> Set BuildCfg
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set BuildCfg] -> Set BuildCfg)
-> m [Set BuildCfg] -> m (Set BuildCfg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BuildCfg -> m (Set BuildCfg)) -> [BuildCfg] -> m [Set BuildCfg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse BuildCfg -> m (Set BuildCfg)
forall (m :: * -> *).
(MonadIO m, MonadDb m) =>
BuildCfg -> m (Set BuildCfg)
getTransitiveDeps [BuildCfg]
manuals
    let redundant :: Set BuildCfg
redundant = Set BuildCfg
allPkgs Set BuildCfg -> Set BuildCfg -> Set BuildCfg
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set BuildCfg
allDeps
    String -> m ()
forall (m :: * -> *).
(MonadReader Verbosity m, MonadIO m) =>
String -> m ()
putDiagnostic (String
"Redundant packages: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (BuildCfg -> String
buildName (BuildCfg -> String) -> [BuildCfg] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set BuildCfg -> [BuildCfg]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set BuildCfg
redundant))
    (BuildCfg -> m ()) -> Set BuildCfg -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ BuildCfg -> m ()
forall (m :: * -> *).
(MonadIO m, MonadDb m, MonadReader Verbosity m) =>
BuildCfg -> m ()
uninstallPkg Set BuildCfg
redundant

getTransitiveDeps :: (MonadIO m, MonadDb m) => BuildCfg -> m (S.Set BuildCfg)
getTransitiveDeps :: forall (m :: * -> *).
(MonadIO m, MonadDb m) =>
BuildCfg -> m (Set BuildCfg)
getTransitiveDeps BuildCfg
cfg = do
    let names :: [Text]
names = (Text, Version) -> Text
forall a b. (a, b) -> a
fst ((Text, Version) -> Text) -> [(Text, Version)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuildCfg -> [(Text, Version)]
pinnedDeps BuildCfg
cfg
        host :: Maybe TargetTriple
host = BuildCfg -> Maybe TargetTriple
targetArch BuildCfg
cfg
    [Set BuildCfg]
next <- (String -> m (Set BuildCfg)) -> [String] -> m [Set BuildCfg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\String
n -> String -> Maybe TargetTriple -> m (Set BuildCfg)
forall (m :: * -> *).
(MonadIO m, MonadDb m) =>
String -> Maybe TargetTriple -> m (Set BuildCfg)
getTransitiveDepsByName String
n Maybe TargetTriple
host) (Text -> String
T.unpack (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
names)
    Set BuildCfg -> m (Set BuildCfg)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set BuildCfg -> m (Set BuildCfg))
-> Set BuildCfg -> m (Set BuildCfg)
forall a b. (a -> b) -> a -> b
$ BuildCfg -> Set BuildCfg -> Set BuildCfg
forall a. Ord a => a -> Set a -> Set a
S.insert BuildCfg
cfg ([Set BuildCfg] -> Set BuildCfg
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set BuildCfg]
next)

-- | @since 0.2.3.0
cleanCache :: MonadIO m => m ()
cleanCache :: forall (m :: * -> *). MonadIO m => m ()
cleanCache = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String
ccDir <- (String -> String -> String
</> String
"cache") (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
forall (m :: * -> *). MonadIO m => m String
globalPkgDir
    Bool
exists <- String -> IO Bool
doesDirectoryExist String
ccDir
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
removeDirectoryRecursive String
ccDir

cleanSymlinks :: (MonadReader Verbosity m, MonadIO m) => m ()
cleanSymlinks :: forall (m :: * -> *). (MonadReader Verbosity m, MonadIO m) => m ()
cleanSymlinks = do
    String
pkDir <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
forall (m :: * -> *). MonadIO m => m String
globalPkgDir
    let binDir :: String
binDir = String
pkDir String -> String -> String
</> String
"bin"
        manDir :: String
manDir = String
pkDir String -> String -> String
</> String
"share" String -> String -> String
</> String
"man"
        man1Dir :: String
man1Dir = String
manDir String -> String -> String
</> String
"man1"
        man3Dir :: String
man3Dir = String
manDir String -> String -> String
</> String
"man3"
    (String -> m ()) -> [String] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> m ()
forall (m :: * -> *).
(MonadReader Verbosity m, MonadIO m) =>
String -> m ()
cleanDir
        [String
binDir, String
man1Dir, String
man3Dir]


cleanDir :: (MonadReader Verbosity m, MonadIO m) => FilePath -> m ()
cleanDir :: forall (m :: * -> *).
(MonadReader Verbosity m, MonadIO m) =>
String -> m ()
cleanDir String
dir = do
    Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
dir
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [String]
links <- IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> m [String]) -> IO [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
listDirectory String
dir
        [String] -> (String -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
links ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
link -> do
            let linkAbs :: String
linkAbs = String
dir String -> String -> String
</> String
link
            Bool
brk <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
isBroken String
linkAbs
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
brk (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                String -> m ()
forall (m :: * -> *).
(MonadReader Verbosity m, MonadIO m) =>
String -> m ()
putDiagnostic (String
"Removing link " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
linkAbs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"...") m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
removeFile String
linkAbs)

isBroken :: FilePath -> IO Bool
isBroken :: String -> IO Bool
isBroken = ((Bool -> Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool) -> (String -> IO Bool) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesFileExist) (String -> IO Bool) -> (String -> IO String) -> String -> IO Bool
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> IO String
getSymbolicLinkTarget

-- getSymbolicLinkTarget