{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
module Aura.Core
(
Env(..)
, Repository(..)
, liftMaybeM
, sudo, trueRoot
, foreignPackages, orphans
, develPkgs, isDevelPkg
, Unsatisfied(..), Satisfied(..)
, areSatisfied, isInstalled
, checkDBLock
, removePkgs, partitionPkgs
, diff
, notify, warn, scold, report
) where
import Aura.Colour
import Aura.IO
import Aura.Languages
import Aura.Pacman
import Aura.Settings
import Aura.Shell
import Aura.Types
import Aura.Utils
import Control.Monad.Trans.Maybe
import Data.Bifunctor (bimap)
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import RIO hiding ((<>))
import qualified RIO.ByteString as B
import RIO.Directory (doesFileExist)
import qualified RIO.List as L
import qualified RIO.NonEmpty as NEL
import qualified RIO.Set as S
import qualified RIO.Text as T
import System.Process.Typed (proc, runProcess)
data Env = Env { repository :: !Repository, settings :: !Settings }
deriving stock (Generic)
settingsL :: Lens' Env Settings
settingsL f e = (\ss -> e { settings = ss }) <$> f (settings e)
instance HasLogFunc Env where
logFuncL = settingsL . logFuncOfL
data Repository = Repository
{ repoCache :: !(TVar (Map PkgName Package))
, repoLookup :: Settings -> NonEmpty PkgName -> IO (Maybe (Set PkgName, Set Package)) }
instance Semigroup Repository where
a <> b = Repository (repoCache a) $ \ss ps -> runMaybeT $ do
items@(bads, goods) <- MaybeT $ repoLookup a ss ps
case nes bads of
Nothing -> pure items
Just bads' -> second (goods <>) <$> MaybeT (repoLookup b ss bads')
partitionPkgs :: NonEmpty (NonEmpty Package) -> ([Prebuilt], [NonEmpty Buildable])
partitionPkgs = bimap fold f . L.unzip . map g . NEL.toList
where
g :: NonEmpty Package -> ([Prebuilt], [Buildable])
g = fmapEither toEither . NEL.toList
f :: [[a]] -> [NonEmpty a]
f = mapMaybe NEL.nonEmpty
toEither :: Package -> Either Prebuilt Buildable
toEither (FromAUR b) = Right b
toEither (FromRepo b) = Left b
liftMaybeM :: (MonadThrow m, Exception e) => e -> m (Maybe a) -> m a
liftMaybeM a m = m >>= maybe (throwM a) pure
sudo :: RIO Env a -> RIO Env a
sudo act = asks (hasRootPriv . envOf . settings) >>= bool (throwM $ Failure mustBeRoot_1) act
trueRoot :: RIO Env a -> RIO Env a
trueRoot action = asks settings >>= \ss ->
if not (isTrueRoot $ envOf ss) && buildUserOf (buildConfigOf ss) /= Just (User "root")
then action else throwM $ Failure trueRoot_3
foreignPackages :: Environment -> IO (Set SimplePkg)
foreignPackages env = S.fromList . mapMaybe simplepkg' <$> pacmanLines env ["-Qm"]
orphans :: Environment -> IO (Set PkgName)
orphans env = S.fromList . map PkgName <$> pacmanLines env ["-Qqdt"]
develPkgs :: Environment -> IO (Set PkgName)
develPkgs env = S.filter isDevelPkg . S.map spName <$> foreignPackages env
isDevelPkg :: PkgName -> Bool
isDevelPkg (PkgName pkg) = any (`T.isSuffixOf` pkg) suffixes
where
suffixes :: [Text]
suffixes = ["-git", "-hg", "-svn", "-darcs", "-cvs", "-bzr"]
isInstalled :: Environment -> PkgName -> IO (Maybe PkgName)
isInstalled env pkg = bool Nothing (Just pkg) <$> pacmanSuccess env ["-Qq", pnName pkg]
removePkgs :: NonEmpty PkgName -> RIO Env ()
removePkgs pkgs = do
ss <- asks settings
let !pacOpts = commonConfigOf ss
!env = envOf ss
liftIO . pacman env $ ["-Rsu"] <> asFlag pkgs <> asFlag pacOpts
newtype Unsatisfied = Unsatisfied (NonEmpty Dep)
newtype Satisfied = Satisfied (NonEmpty Dep)
areSatisfied :: Environment -> NonEmpty Dep -> IO (These Unsatisfied Satisfied)
areSatisfied env ds = do
unsats <- S.fromList . mapMaybe parseDep <$> unsat
pure . bimap Unsatisfied Satisfied $ partNonEmpty (f unsats) ds
where
unsat :: IO [Text]
unsat = pacmanLines env $ "-T" : map renderedDep (toList ds)
f :: Set Dep -> Dep -> These Dep Dep
f unsats d | S.member d unsats = This d
| otherwise = That d
checkDBLock :: Settings -> IO ()
checkDBLock ss = do
locked <- doesFileExist lockFile
when locked $ warn ss checkDBLock_1 *> B.getLine *> checkDBLock ss
diff :: MonadIO m => Settings -> FilePath -> FilePath -> m ()
diff ss f1 f2 = void . runProcess . proc "diff" $ c <> ["-u", f1, f2]
where
c :: [FilePath]
c = bool ["--color"] [] $ shared ss (Colour Never)
notify :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m ()
notify ss msg = putStrLnA ss $ green (msg $ langOf ss)
warn :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m ()
warn ss msg = putStrLnA ss $ yellow (msg $ langOf ss)
scold :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m ()
scold ss msg = putStrLnA ss $ red (msg $ langOf ss)
report :: (Doc AnsiStyle -> Doc AnsiStyle) -> (Language -> Doc AnsiStyle) -> NonEmpty PkgName -> RIO Env ()
report c msg pkgs = do
ss <- asks settings
putStrLnA ss . c . msg $ langOf ss
putTextLn . dtot . colourCheck ss . vsep . map (cyan . pretty . pnName) $ toList pkgs