{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
module Aura.Core
(
Env(..)
, Repository(..)
, liftMaybeM
, sudo, trueRoot
, foreignPackages, orphans, develPkgs
, Unsatisfied(..), Satisfied(..)
, areSatisfied, isInstalled
, checkDBLock
, removePkgs, partitionPkgs, packageBuildable
, notify, warn, scold, report
) where
import Aura.Colour
import Aura.IO
import Aura.Languages
import Aura.Pacman
import Aura.Pkgbuild.Editing (hotEdit)
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
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
packageBuildable :: Settings -> Buildable -> IO Package
packageBuildable ss b = FromAUR <$> hotEdit ss 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 :: IO (Set SimplePkg)
foreignPackages = S.fromList . mapMaybe simplepkg' <$> pacmanLines ["-Qm"]
orphans :: IO (Set PkgName)
orphans = S.fromList . map PkgName <$> pacmanLines ["-Qqdt"]
develPkgs :: IO (Set PkgName)
develPkgs = S.filter isDevelPkg . S.map spName <$> foreignPackages
where isDevelPkg (PkgName pkg) = any (`T.isSuffixOf` pkg) suffixes
suffixes = ["-git", "-hg", "-svn", "-darcs", "-cvs", "-bzr"]
isInstalled :: PkgName -> IO (Maybe PkgName)
isInstalled pkg = bool Nothing (Just pkg) <$> pacmanSuccess ["-Qq", pnName pkg]
removePkgs :: NonEmpty PkgName -> RIO Env ()
removePkgs pkgs = do
pacOpts <- asks (commonConfigOf . settings)
liftIO . pacman $ ["-Rsu"] <> asFlag pkgs <> asFlag pacOpts
newtype Unsatisfied = Unsatisfied (NonEmpty Dep)
newtype Satisfied = Satisfied (NonEmpty Dep)
areSatisfied :: NonEmpty Dep -> IO (These Unsatisfied Satisfied)
areSatisfied ds = do
unsats <- S.fromList . mapMaybe parseDep <$> unsat
pure . bimap Unsatisfied Satisfied $ partNonEmpty (f unsats) ds
where
unsat :: IO [Text]
unsat = pacmanLines $ "-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
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