{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}

-- |
-- Module    : Aura.Core
-- Copyright : (c) Colin Woodbury, 2012 - 2021
-- License   : GPL3
-- Maintainer: Colin Woodbury <colin@fosskers.ca>
--
-- Core types and functions which belong nowhere else.

module Aura.Core
  ( -- * Types
    Env(..)
  , Repository(..)
  , liftMaybeM
    -- * User Privileges
  , sudo, trueRoot
    -- * Querying the Package Database
  , foreignPackages, orphans
  , develPkgs, isDevelPkg
  , Unsatisfied(..), Satisfied(..)
  , areSatisfied, isInstalled
  , checkDBLock
    -- * Misc. Package Handling
  , removePkgs, partitionPkgs
    -- * Content Diffing
  , diff
    -- * IO
  , 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           Prettyprinter
import           Prettyprinter.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)

---

--------
-- TYPES
--------

-- | The complete Aura runtime environment. `Repository` has internal caches
-- instantiated in `IO`, while `Settings` is mostly static and derived from
-- command-line arguments.
data Env = Env { Env -> Repository
repository :: !Repository, Env -> Settings
settings :: !Settings }
  deriving stock ((forall x. Env -> Rep Env x)
-> (forall x. Rep Env x -> Env) -> Generic Env
forall x. Rep Env x -> Env
forall x. Env -> Rep Env x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Env x -> Env
$cfrom :: forall x. Env -> Rep Env x
Generic)

settingsL :: Lens' Env Settings
settingsL :: (Settings -> f Settings) -> Env -> f Env
settingsL Settings -> f Settings
f Env
e = (\Settings
ss -> Env
e { settings :: Settings
settings = Settings
ss }) (Settings -> Env) -> f Settings -> f Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> f Settings
f (Env -> Settings
settings Env
e)

instance HasLogFunc Env where
  logFuncL :: (LogFunc -> f LogFunc) -> Env -> f Env
logFuncL = (Settings -> f Settings) -> Env -> f Env
Lens' Env Settings
settingsL ((Settings -> f Settings) -> Env -> f Env)
-> ((LogFunc -> f LogFunc) -> Settings -> f Settings)
-> (LogFunc -> f LogFunc)
-> Env
-> f Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogFunc -> f LogFunc) -> Settings -> f Settings
Lens' Settings LogFunc
logFuncOfL

-- | A `Repository` is a place where packages may be fetched from. Multiple
-- repositories can be combined with the `Semigroup` instance. Checks packages
-- in batches for efficiency.
data Repository = Repository
  { Repository -> TVar (Map PkgName Package)
repoCache :: !(TVar (Map PkgName Package))
  , Repository
-> Settings
-> NonEmpty PkgName
-> IO (Maybe (Set PkgName, Set Package))
repoLookup :: Settings -> NonEmpty PkgName -> IO (Maybe (Set PkgName, Set Package)) }

-- NOTE The `repoCache` value passed to the combined `Repository` constructor is
-- irrelevant, and only sits there for typechecking purposes. Each `Repository`
-- is expected to leverage its own cache within its `repoLookup` function.
instance Semigroup Repository where
  Repository
a <> :: Repository -> Repository -> Repository
<> Repository
b = TVar (Map PkgName Package)
-> (Settings
    -> NonEmpty PkgName -> IO (Maybe (Set PkgName, Set Package)))
-> Repository
Repository (Repository -> TVar (Map PkgName Package)
repoCache Repository
a) ((Settings
  -> NonEmpty PkgName -> IO (Maybe (Set PkgName, Set Package)))
 -> Repository)
-> (Settings
    -> NonEmpty PkgName -> IO (Maybe (Set PkgName, Set Package)))
-> Repository
forall a b. (a -> b) -> a -> b
$ \Settings
ss NonEmpty PkgName
ps -> MaybeT IO (Set PkgName, Set Package)
-> IO (Maybe (Set PkgName, Set Package))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (Set PkgName, Set Package)
 -> IO (Maybe (Set PkgName, Set Package)))
-> MaybeT IO (Set PkgName, Set Package)
-> IO (Maybe (Set PkgName, Set Package))
forall a b. (a -> b) -> a -> b
$ do
    items :: (Set PkgName, Set Package)
items@(Set PkgName
bads, Set Package
goods) <- IO (Maybe (Set PkgName, Set Package))
-> MaybeT IO (Set PkgName, Set Package)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (Set PkgName, Set Package))
 -> MaybeT IO (Set PkgName, Set Package))
-> IO (Maybe (Set PkgName, Set Package))
-> MaybeT IO (Set PkgName, Set Package)
forall a b. (a -> b) -> a -> b
$ Repository
-> Settings
-> NonEmpty PkgName
-> IO (Maybe (Set PkgName, Set Package))
repoLookup Repository
a Settings
ss NonEmpty PkgName
ps
    case Set PkgName -> Maybe (NonEmpty PkgName)
forall a. Set a -> Maybe (NonEmpty a)
nes Set PkgName
bads of
      Maybe (NonEmpty PkgName)
Nothing    -> (Set PkgName, Set Package) -> MaybeT IO (Set PkgName, Set Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set PkgName, Set Package)
items
      Just NonEmpty PkgName
bads' -> (Set Package -> Set Package)
-> (Set PkgName, Set Package) -> (Set PkgName, Set Package)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Set Package
goods Set Package -> Set Package -> Set Package
forall a. Semigroup a => a -> a -> a
<>) ((Set PkgName, Set Package) -> (Set PkgName, Set Package))
-> MaybeT IO (Set PkgName, Set Package)
-> MaybeT IO (Set PkgName, Set Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Set PkgName, Set Package))
-> MaybeT IO (Set PkgName, Set Package)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Repository
-> Settings
-> NonEmpty PkgName
-> IO (Maybe (Set PkgName, Set Package))
repoLookup Repository
b Settings
ss NonEmpty PkgName
bads')

---------------------------------
-- Functions common to `Package`s
---------------------------------
-- | Partition a list of packages into pacman and buildable groups. Yes, this is
-- the correct signature. As far as this function (in isolation) is concerned,
-- there is no way to guarantee that the list of `NonEmpty`s will itself be
-- non-empty.
partitionPkgs :: NonEmpty (NonEmpty Package) -> ([Prebuilt], [NonEmpty Buildable])
partitionPkgs :: NonEmpty (NonEmpty Package) -> ([Prebuilt], [NonEmpty Buildable])
partitionPkgs = ([[Prebuilt]] -> [Prebuilt])
-> ([[Buildable]] -> [NonEmpty Buildable])
-> ([[Prebuilt]], [[Buildable]])
-> ([Prebuilt], [NonEmpty Buildable])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [[Prebuilt]] -> [Prebuilt]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [[Buildable]] -> [NonEmpty Buildable]
forall a. [[a]] -> [NonEmpty a]
f (([[Prebuilt]], [[Buildable]])
 -> ([Prebuilt], [NonEmpty Buildable]))
-> (NonEmpty (NonEmpty Package) -> ([[Prebuilt]], [[Buildable]]))
-> NonEmpty (NonEmpty Package)
-> ([Prebuilt], [NonEmpty Buildable])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Prebuilt], [Buildable])] -> ([[Prebuilt]], [[Buildable]])
forall a b. [(a, b)] -> ([a], [b])
L.unzip ([([Prebuilt], [Buildable])] -> ([[Prebuilt]], [[Buildable]]))
-> (NonEmpty (NonEmpty Package) -> [([Prebuilt], [Buildable])])
-> NonEmpty (NonEmpty Package)
-> ([[Prebuilt]], [[Buildable]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Package -> ([Prebuilt], [Buildable]))
-> [NonEmpty Package] -> [([Prebuilt], [Buildable])]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Package -> ([Prebuilt], [Buildable])
g ([NonEmpty Package] -> [([Prebuilt], [Buildable])])
-> (NonEmpty (NonEmpty Package) -> [NonEmpty Package])
-> NonEmpty (NonEmpty Package)
-> [([Prebuilt], [Buildable])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty Package) -> [NonEmpty Package]
forall a. NonEmpty a -> [a]
NEL.toList
  where
    g :: NonEmpty Package -> ([Prebuilt], [Buildable])
    g :: NonEmpty Package -> ([Prebuilt], [Buildable])
g = (Package -> Either Prebuilt Buildable)
-> [Package] -> ([Prebuilt], [Buildable])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
fmapEither Package -> Either Prebuilt Buildable
toEither ([Package] -> ([Prebuilt], [Buildable]))
-> (NonEmpty Package -> [Package])
-> NonEmpty Package
-> ([Prebuilt], [Buildable])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Package -> [Package]
forall a. NonEmpty a -> [a]
NEL.toList

    f :: [[a]] -> [NonEmpty a]
    f :: [[a]] -> [NonEmpty a]
f = ([a] -> Maybe (NonEmpty a)) -> [[a]] -> [NonEmpty a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty

    toEither :: Package -> Either Prebuilt Buildable
    toEither :: Package -> Either Prebuilt Buildable
toEither (FromAUR Buildable
b)  = Buildable -> Either Prebuilt Buildable
forall a b. b -> Either a b
Right Buildable
b
    toEither (FromRepo Prebuilt
b) = Prebuilt -> Either Prebuilt Buildable
forall a b. a -> Either a b
Left Prebuilt
b

-----------
-- THE WORK
-----------
liftMaybeM :: (MonadThrow m, Exception e) => e -> m (Maybe a) -> m a
liftMaybeM :: e -> m (Maybe a) -> m a
liftMaybeM e
a m (Maybe a)
m = m (Maybe a)
m m (Maybe a) -> (Maybe a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
a) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Action won't be allowed unless user is root, or using sudo.
sudo :: RIO Env a -> RIO Env a
sudo :: RIO Env a -> RIO Env a
sudo RIO Env a
act = (Env -> Bool) -> RIO Env Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Environment -> Bool
hasRootPriv (Environment -> Bool) -> (Env -> Environment) -> Env -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Environment
envOf (Settings -> Environment)
-> (Env -> Settings) -> Env -> Environment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Settings
settings) RIO Env Bool -> (Bool -> RIO Env a) -> RIO Env a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RIO Env a -> RIO Env a -> Bool -> RIO Env a
forall a. a -> a -> Bool -> a
bool (Failure -> RIO Env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Failure -> RIO Env a)
-> (FailMsg -> Failure) -> FailMsg -> RIO Env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailMsg -> Failure
Failure (FailMsg -> RIO Env a) -> FailMsg -> RIO Env a
forall a b. (a -> b) -> a -> b
$ (Language -> Doc AnsiStyle) -> FailMsg
FailMsg Language -> Doc AnsiStyle
mustBeRoot_1) RIO Env a
act

-- | Stop the user if they are the true root. Building as root isn't allowed
-- since makepkg v4.2.
trueRoot :: RIO Env a -> RIO Env a
trueRoot :: RIO Env a -> RIO Env a
trueRoot RIO Env a
action = (Env -> Settings) -> RIO Env Settings
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Settings
settings RIO Env Settings -> (Settings -> RIO Env a) -> RIO Env a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Settings
ss ->
  if Bool -> Bool
not (Environment -> Bool
isTrueRoot (Environment -> Bool) -> Environment -> Bool
forall a b. (a -> b) -> a -> b
$ Settings -> Environment
envOf Settings
ss) Bool -> Bool -> Bool
&& BuildConfig -> Maybe User
buildUserOf (Settings -> BuildConfig
buildConfigOf Settings
ss) Maybe User -> Maybe User -> Bool
forall a. Eq a => a -> a -> Bool
/= User -> Maybe User
forall a. a -> Maybe a
Just (Text -> User
User Text
"root")
    then RIO Env a
action else Failure -> RIO Env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Failure -> RIO Env a)
-> (FailMsg -> Failure) -> FailMsg -> RIO Env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailMsg -> Failure
Failure (FailMsg -> RIO Env a) -> FailMsg -> RIO Env a
forall a b. (a -> b) -> a -> b
$ (Language -> Doc AnsiStyle) -> FailMsg
FailMsg Language -> Doc AnsiStyle
trueRoot_3

-- | A list of non-prebuilt packages installed on the system.
-- @-Qm@ yields a list of sorted values.
foreignPackages :: Environment -> IO (Set SimplePkg)
foreignPackages :: Environment -> IO (Set SimplePkg)
foreignPackages Environment
env = [SimplePkg] -> Set SimplePkg
forall a. Ord a => [a] -> Set a
S.fromList ([SimplePkg] -> Set SimplePkg)
-> ([Text] -> [SimplePkg]) -> [Text] -> Set SimplePkg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe SimplePkg) -> [Text] -> [SimplePkg]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe SimplePkg
simplepkg' ([Text] -> Set SimplePkg) -> IO [Text] -> IO (Set SimplePkg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment -> [Text] -> IO [Text]
pacmanLines Environment
env [Text
"-Qm"]

-- | Packages marked as a dependency, yet are required by no other package.
orphans :: Environment -> IO (Set PkgName)
orphans :: Environment -> IO (Set PkgName)
orphans Environment
env = [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
S.fromList ([PkgName] -> Set PkgName)
-> ([Text] -> [PkgName]) -> [Text] -> Set PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> PkgName) -> [Text] -> [PkgName]
forall a b. (a -> b) -> [a] -> [b]
map Text -> PkgName
PkgName ([Text] -> Set PkgName) -> IO [Text] -> IO (Set PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment -> [Text] -> IO [Text]
pacmanLines Environment
env [Text
"-Qqdt"]

-- | Any installed package whose name is suffixed by git, hg, svn, darcs, cvs,
-- or bzr.
develPkgs :: Environment -> IO (Set PkgName)
develPkgs :: Environment -> IO (Set PkgName)
develPkgs Environment
env = (PkgName -> Bool) -> Set PkgName -> Set PkgName
forall a. (a -> Bool) -> Set a -> Set a
S.filter PkgName -> Bool
isDevelPkg (Set PkgName -> Set PkgName)
-> (Set SimplePkg -> Set PkgName) -> Set SimplePkg -> Set PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimplePkg -> PkgName) -> Set SimplePkg -> Set PkgName
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map SimplePkg -> PkgName
spName (Set SimplePkg -> Set PkgName)
-> IO (Set SimplePkg) -> IO (Set PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment -> IO (Set SimplePkg)
foreignPackages Environment
env

-- | Is a package suffixed by git, hg, svn, darcs, cvs, or bzr?
isDevelPkg :: PkgName -> Bool
isDevelPkg :: PkgName -> Bool
isDevelPkg (PkgName Text
pkg) = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isSuffixOf` Text
pkg) [Text]
suffixes
  where
    suffixes :: [Text]
    suffixes :: [Text]
suffixes = [Text
"-git", Text
"-hg", Text
"-svn", Text
"-darcs", Text
"-cvs", Text
"-bzr"]

-- | Returns what it was given if the package is already installed.
-- Reasoning: Using raw bools can be less expressive.
isInstalled :: Environment -> PkgName -> IO (Maybe PkgName)
isInstalled :: Environment -> PkgName -> IO (Maybe PkgName)
isInstalled Environment
env PkgName
pkg = Maybe PkgName -> Maybe PkgName -> Bool -> Maybe PkgName
forall a. a -> a -> Bool -> a
bool Maybe PkgName
forall a. Maybe a
Nothing (PkgName -> Maybe PkgName
forall a. a -> Maybe a
Just PkgName
pkg) (Bool -> Maybe PkgName) -> IO Bool -> IO (Maybe PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment -> [Text] -> IO Bool
pacmanSuccess Environment
env [Text
"-Qq", PkgName -> Text
pnName PkgName
pkg]

-- | An @-Rsu@ call.
removePkgs :: NonEmpty PkgName -> RIO Env ()
removePkgs :: NonEmpty PkgName -> RIO Env ()
removePkgs NonEmpty PkgName
pkgs = do
  Settings
ss <- (Env -> Settings) -> RIO Env Settings
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Settings
settings
  let !pacOpts :: CommonConfig
pacOpts = Settings -> CommonConfig
commonConfigOf Settings
ss
      !env :: Environment
env = Settings -> Environment
envOf Settings
ss
  IO () -> RIO Env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Env ()) -> ([Text] -> IO ()) -> [Text] -> RIO Env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment -> [Text] -> IO ()
pacman Environment
env ([Text] -> RIO Env ()) -> [Text] -> RIO Env ()
forall a b. (a -> b) -> a -> b
$ [Text
"-Rsu"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> NonEmpty PkgName -> [Text]
forall a. Flagable a => a -> [Text]
asFlag NonEmpty PkgName
pkgs [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> CommonConfig -> [Text]
forall a. Flagable a => a -> [Text]
asFlag CommonConfig
pacOpts

-- | Depedencies which are not installed, or otherwise provided by some
-- installed package.
newtype Unsatisfied = Unsatisfied (NonEmpty Dep)

-- | The opposite of `Unsatisfied`.
newtype Satisfied = Satisfied (NonEmpty Dep)

-- | Similar to `isSatisfied`, but dependencies are checked in a batch, since
-- @-T@ can accept multiple inputs.
areSatisfied :: Environment -> NonEmpty Dep -> IO (These Unsatisfied Satisfied)
areSatisfied :: Environment -> NonEmpty Dep -> IO (These Unsatisfied Satisfied)
areSatisfied Environment
env NonEmpty Dep
ds = do
  Set Dep
unsats <- [Dep] -> Set Dep
forall a. Ord a => [a] -> Set a
S.fromList ([Dep] -> Set Dep) -> ([Text] -> [Dep]) -> [Text] -> Set Dep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe Dep) -> [Text] -> [Dep]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Dep
parseDep ([Text] -> Set Dep) -> IO [Text] -> IO (Set Dep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Text]
unsat
  These Unsatisfied Satisfied -> IO (These Unsatisfied Satisfied)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (These Unsatisfied Satisfied -> IO (These Unsatisfied Satisfied))
-> (These (NonEmpty Dep) (NonEmpty Dep)
    -> These Unsatisfied Satisfied)
-> These (NonEmpty Dep) (NonEmpty Dep)
-> IO (These Unsatisfied Satisfied)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Dep -> Unsatisfied)
-> (NonEmpty Dep -> Satisfied)
-> These (NonEmpty Dep) (NonEmpty Dep)
-> These Unsatisfied Satisfied
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap NonEmpty Dep -> Unsatisfied
Unsatisfied NonEmpty Dep -> Satisfied
Satisfied (These (NonEmpty Dep) (NonEmpty Dep)
 -> IO (These Unsatisfied Satisfied))
-> These (NonEmpty Dep) (NonEmpty Dep)
-> IO (These Unsatisfied Satisfied)
forall a b. (a -> b) -> a -> b
$ (Dep -> These Dep Dep)
-> NonEmpty Dep -> These (NonEmpty Dep) (NonEmpty Dep)
forall a b c.
(a -> These b c) -> NonEmpty a -> These (NonEmpty b) (NonEmpty c)
partNonEmpty (Set Dep -> Dep -> These Dep Dep
f Set Dep
unsats) NonEmpty Dep
ds
  where
    unsat :: IO [Text]
    unsat :: IO [Text]
unsat = Environment -> [Text] -> IO [Text]
pacmanLines Environment
env ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ Text
"-T" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Dep -> Text) -> [Dep] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Dep -> Text
renderedDep (NonEmpty Dep -> [Dep]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Dep
ds)

    f :: Set Dep -> Dep -> These Dep Dep
    f :: Set Dep -> Dep -> These Dep Dep
f Set Dep
unsats Dep
d | Dep -> Set Dep -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Dep
d Set Dep
unsats = Dep -> These Dep Dep
forall a b. a -> These a b
This Dep
d
               | Bool
otherwise = Dep -> These Dep Dep
forall a b. b -> These a b
That Dep
d

-- | Block further action until the database is free.
checkDBLock :: Settings -> IO ()
checkDBLock :: Settings -> IO ()
checkDBLock Settings
ss = do
  Bool
locked <- FilePath -> IO Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
lockFile
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
locked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings -> (Language -> Doc AnsiStyle) -> IO ()
forall (m :: * -> *).
MonadIO m =>
Settings -> (Language -> Doc AnsiStyle) -> m ()
warn Settings
ss Language -> Doc AnsiStyle
checkDBLock_1 IO () -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO ByteString
forall (m :: * -> *). MonadIO m => m ByteString
B.getLine IO ByteString -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Settings -> IO ()
checkDBLock Settings
ss

----------
-- DIFFING
----------

-- | Given two filepaths, output the diff of the two files.
-- Output will be coloured unless colour is deactivated by
-- `--color never` or by detection of a non-terminal output
-- target.
diff :: MonadIO m => Settings -> FilePath -> FilePath -> m ()
diff :: Settings -> FilePath -> FilePath -> m ()
diff Settings
ss FilePath
f1 FilePath
f2 = m ExitCode -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ExitCode -> m ())
-> ([FilePath] -> m ExitCode) -> [FilePath] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessConfig () () () -> m ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess (ProcessConfig () () () -> m ExitCode)
-> ([FilePath] -> ProcessConfig () () ())
-> [FilePath]
-> m ExitCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> ProcessConfig () () ()
proc FilePath
"diff" ([FilePath] -> m ()) -> [FilePath] -> m ()
forall a b. (a -> b) -> a -> b
$ [FilePath]
c [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath
"-u", FilePath
f1, FilePath
f2]
  where
    c :: [FilePath]
    c :: [FilePath]
c = [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall a. a -> a -> Bool -> a
bool [FilePath
"--color"] [] (Bool -> [FilePath]) -> Bool -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Settings -> CommonSwitch -> Bool
shared Settings
ss (ColourMode -> CommonSwitch
Colour ColourMode
Never)

-------
-- MISC  -- Too specific for `Utilities.hs` or `Aura.Utils`
-------

-- | Print some message in green with Aura flair.
notify :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m ()
notify :: Settings -> (Language -> Doc AnsiStyle) -> m ()
notify Settings
ss Language -> Doc AnsiStyle
msg = Settings -> Doc AnsiStyle -> m ()
forall (m :: * -> *).
MonadIO m =>
Settings -> Doc AnsiStyle -> m ()
putStrLnA Settings
ss (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Doc AnsiStyle
green (Language -> Doc AnsiStyle
msg (Language -> Doc AnsiStyle) -> Language -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Settings -> Language
langOf Settings
ss)

-- | Print some message in yellow with Aura flair.
warn :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m ()
warn :: Settings -> (Language -> Doc AnsiStyle) -> m ()
warn Settings
ss Language -> Doc AnsiStyle
msg = Settings -> Doc AnsiStyle -> m ()
forall (m :: * -> *).
MonadIO m =>
Settings -> Doc AnsiStyle -> m ()
putStrLnA Settings
ss (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Doc AnsiStyle
yellow (Language -> Doc AnsiStyle
msg (Language -> Doc AnsiStyle) -> Language -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Settings -> Language
langOf Settings
ss)

-- | Print some message in red with Aura flair.
scold :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m ()
scold :: Settings -> (Language -> Doc AnsiStyle) -> m ()
scold Settings
ss Language -> Doc AnsiStyle
msg = Settings -> Doc AnsiStyle -> m ()
forall (m :: * -> *).
MonadIO m =>
Settings -> Doc AnsiStyle -> m ()
putStrLnA Settings
ss (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Doc AnsiStyle
red (Language -> Doc AnsiStyle
msg (Language -> Doc AnsiStyle) -> Language -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Settings -> Language
langOf Settings
ss)

-- | Report a message with multiple associated items. Usually a list of
-- naughty packages.
report :: (Doc AnsiStyle -> Doc AnsiStyle) -> (Language -> Doc AnsiStyle) -> NonEmpty PkgName -> RIO Env ()
report :: (Doc AnsiStyle -> Doc AnsiStyle)
-> (Language -> Doc AnsiStyle) -> NonEmpty PkgName -> RIO Env ()
report Doc AnsiStyle -> Doc AnsiStyle
c Language -> Doc AnsiStyle
msg NonEmpty PkgName
pkgs = do
  Settings
ss <- (Env -> Settings) -> RIO Env Settings
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Settings
settings
  Settings -> Doc AnsiStyle -> RIO Env ()
forall (m :: * -> *).
MonadIO m =>
Settings -> Doc AnsiStyle -> m ()
putStrLnA Settings
ss (Doc AnsiStyle -> RIO Env ())
-> (Language -> Doc AnsiStyle) -> Language -> RIO Env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Doc AnsiStyle
c (Doc AnsiStyle -> Doc AnsiStyle)
-> (Language -> Doc AnsiStyle) -> Language -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Doc AnsiStyle
msg (Language -> RIO Env ()) -> Language -> RIO Env ()
forall a b. (a -> b) -> a -> b
$ Settings -> Language
langOf Settings
ss
  Text -> RIO Env ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> RIO Env ())
-> ([PkgName] -> Text) -> [PkgName] -> RIO Env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Text
dtot (Doc AnsiStyle -> Text)
-> ([PkgName] -> Doc AnsiStyle) -> [PkgName] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Settings -> Doc ann -> Doc ann
colourCheck Settings
ss (Doc AnsiStyle -> Doc AnsiStyle)
-> ([PkgName] -> Doc AnsiStyle) -> [PkgName] -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> ([PkgName] -> [Doc AnsiStyle]) -> [PkgName] -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PkgName -> Doc AnsiStyle) -> [PkgName] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (Doc AnsiStyle -> Doc AnsiStyle
cyan (Doc AnsiStyle -> Doc AnsiStyle)
-> (PkgName -> Doc AnsiStyle) -> PkgName -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc AnsiStyle)
-> (PkgName -> Text) -> PkgName -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> Text
pnName) ([PkgName] -> RIO Env ()) -> [PkgName] -> RIO Env ()
forall a b. (a -> b) -> a -> b
$ NonEmpty PkgName -> [PkgName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PkgName
pkgs