content: {-# LANGUAGE BangPatterns       #-}
  {-# LANGUAGE DeriveGeneric      #-}
  {-# LANGUAGE DerivingStrategies #-}
  
  -- |
  -- Module    : Aura.Core
  -- Copyright : (c) Colin Woodbury, 2012 - 2024
  -- 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 { 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
  
  -- | 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
    { repoCache :: !(TVar (Map PkgName 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
    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')
  
  ---------------------------------
  -- 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 = 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
  
  -----------
  -- THE WORK
  -----------
  liftMaybeM :: (MonadThrow m, Exception e) => e -> m (Maybe a) -> m a
  liftMaybeM a m = m >>= maybe (throwM a) pure
  
  -- | Action won't be allowed unless user is root, or using sudo.
  sudo :: RIO Env a -> RIO Env a
  sudo act = asks (hasRootPriv . envOf . settings) >>= bool (throwM . Failure $ FailMsg mustBeRoot_1) 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 action = asks settings >>= \ss ->
    if not (isTrueRoot $ envOf ss) && buildUserOf (buildConfigOf ss) /= Just (User "root")
      then action else throwM . Failure $ FailMsg 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 env = S.fromList . mapMaybe simplepkg' <$> pacmanLines env ["-Qm"]
  
  -- | Packages marked as a dependency, yet are required by no other package.
  orphans :: Environment -> IO (Set PkgName)
  orphans env = S.fromList . map PkgName <$> pacmanLines env ["-Qqdt"]
  
  -- | Any installed package whose name is suffixed by git, hg, svn, darcs, cvs,
  -- or bzr.
  develPkgs :: Environment -> IO (Set PkgName)
  develPkgs env = S.filter isDevelPkg . S.map spName <$> foreignPackages env
  
  -- | Is a package suffixed by git, hg, svn, darcs, cvs, or bzr?
  isDevelPkg :: PkgName -> Bool
  isDevelPkg (PkgName pkg) = any (`T.isSuffixOf` pkg) suffixes
    where
      suffixes :: [Text]
      suffixes = ["-git", "-hg", "-svn", "-darcs", "-cvs", "-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 env pkg = bool Nothing (Just pkg) <$> pacmanSuccess env ["-Qq", pnName pkg]
  
  -- | An @-Rsu@ call.
  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
  
  -- | 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 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
  
  -- | Block further action until the database is free.
  checkDBLock :: Settings -> IO ()
  checkDBLock ss = do
    locked <- doesFileExist lockFile
    when locked $ warn ss checkDBLock_1 *> B.getLine *> checkDBLock 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 ss f1 f2 = void . runProcess . proc "diff" $ c <> ["-u", f1, f2]
    where
      c :: [FilePath]
      c = bool ["--color"] [] $ shared ss (Colour 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 ss msg = putStrLnA ss $ green (msg $ langOf ss)
  
  -- | Print some message in yellow with Aura flair.
  warn :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m ()
  warn ss msg = putStrLnA ss $ yellow (msg $ langOf ss)
  
  -- | Print some message in red with Aura flair.
  scold :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m ()
  scold ss msg = putStrLnA ss $ red (msg $ langOf 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 c msg pkgs = do
    ss <- asks settings
    putStrLnA ss . c . msg $ langOf ss
    putTextLn . dtot . colourCheck ss . vsep . map (cyan . pretty . pnName) $ toList pkgs
  