{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Aura.Commands.C
( downgradePackages
, searchCache
, backupCache
, cleanCache
, cleanNotSaved
) where
import Aura.Cache
import Aura.Colour (red)
import Aura.Core
import Aura.Languages
import Aura.Pacman (pacman)
import Aura.Settings
import Aura.State
import Aura.Types
import Aura.Utils
import Data.Generics.Product (field)
import Data.List.NonEmpty (nonEmpty)
import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NES
import Lens.Micro ((^?), _Just)
import RIO
import RIO.List (groupBy, sort, (\\))
import qualified RIO.Map as M
import qualified RIO.Set as S
import qualified RIO.Text as T
import System.Path
import System.Path.IO (copyFile, doesDirectoryExist, removeFile)
downgradePackages :: NESet PkgName -> RIO Env ()
downgradePackages pkgs = do
ss <- asks settings
let cachePath = either id id . cachePathOf $ commonConfigOf ss
reals <- liftIO $ pkgsInCache ss pkgs
traverse_ (report red reportBadDowngradePkgs_1) . nonEmpty . toList $ NES.toSet pkgs S.\\ reals
unless (null reals) $ do
cache <- liftIO $ cacheContents cachePath
choices <- traverse (getDowngradeChoice cache) $ toList reals
liftIO . pacman $ "-U" : asFlag (commonConfigOf ss) <> map (T.pack . toFilePath . path) choices
getDowngradeChoice :: Cache -> PkgName -> RIO Env PackagePath
getDowngradeChoice cache pkg =
case nonEmpty $ getChoicesFromCache cache pkg of
Nothing -> throwM . Failure $ reportBadDowngradePkgs_2 pkg
Just choices -> do
ss <- asks settings
liftIO . notify ss . getDowngradeChoice_1 pkg $ langOf ss
liftIO $ getSelection (T.pack . toFilePath . path) choices
getChoicesFromCache :: Cache -> PkgName -> [PackagePath]
getChoicesFromCache (Cache cache) p = sort . M.elems $ M.filterWithKey (\(SimplePkg pn _) _ -> p == pn) cache
searchCache :: Text -> RIO Env ()
searchCache ps = do
ss <- asks settings
matches <- liftIO $ cacheMatches ss ps
liftIO . traverse_ (putTextLn . T.pack . toFilePath . path) $ sort matches
backupCache :: Path Absolute -> RIO Env ()
backupCache dir = do
exists <- liftIO $ doesDirectoryExist dir
if | not exists -> throwM $ Failure backupCache_3
| otherwise -> confirmBackup dir >>= backup dir
confirmBackup :: Path Absolute -> RIO Env Cache
confirmBackup dir = do
ss <- asks settings
cache <- liftIO . cacheContents . either id id . cachePathOf $ commonConfigOf ss
liftIO . notify ss $ backupCache_4 (toFilePath dir) (langOf ss)
liftIO . notify ss $ backupCache_5 (M.size $ _cache cache) (langOf ss)
okay <- liftIO $ optionalPrompt ss backupCache_6
bool (throwM $ Failure backupCache_7) (pure cache) okay
backup :: Path Absolute -> Cache -> RIO Env ()
backup dir (Cache cache) = do
ss <- asks settings
liftIO . notify ss . backupCache_8 $ langOf ss
liftIO $ putTextLn ""
copyAndNotify dir (M.elems cache) 1
copyAndNotify :: Path Absolute -> [PackagePath] -> Int -> RIO Env ()
copyAndNotify _ [] _ = pure ()
copyAndNotify dir (PackagePath p : ps) n = do
ss <- asks settings
liftIO $ raiseCursorBy 1
liftIO . warn ss . copyAndNotify_1 n $ langOf ss
liftIO $ copyFile p dir
copyAndNotify dir ps $ n + 1
cleanCache :: Word -> RIO Env ()
cleanCache toSave
| toSave == 0 = do
ss <- asks settings
liftIO . warn ss . cleanCache_2 $ langOf ss
liftIO $ pacman ["-Scc"]
| otherwise = do
ss <- asks settings
liftIO . warn ss . cleanCache_3 toSave $ langOf ss
okay <- liftIO $ optionalPrompt ss cleanCache_4
bool (throwM $ Failure cleanCache_5) (clean (fromIntegral toSave)) okay
clean :: Int -> RIO Env ()
clean toSave = do
ss <- asks settings
liftIO . notify ss . cleanCache_6 $ langOf ss
let cachePath = either id id . cachePathOf $ commonConfigOf ss
(Cache cache) <- liftIO $ cacheContents cachePath
let !files = M.elems cache
grouped = take toSave . reverse <$> groupByName files
toRemove = files \\ fold grouped
liftIO $ traverse_ (removeFile . path) toRemove
cleanNotSaved :: RIO Env ()
cleanNotSaved = do
ss <- asks settings
liftIO . notify ss . cleanNotSaved_1 $ langOf ss
sfs <- liftIO getStateFiles
states <- fmap catMaybes . liftIO $ traverse readState sfs
let cachePath = either id id . cachePathOf $ commonConfigOf ss
(Cache cache) <- liftIO $ cacheContents cachePath
let duds = M.filterWithKey (\p _ -> any (inState p) states) cache
prop <- liftIO . optionalPrompt ss $ cleanNotSaved_2 $ M.size duds
when prop . liftIO . traverse_ (removeFile . path) $ M.elems duds
groupByName :: [PackagePath] -> [[PackagePath]]
groupByName pkgs = groupBy sameBaseName $ sort pkgs
where sameBaseName a b = baseName a == baseName b
baseName p = simplepkg p ^? _Just . field @"name"