{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
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.Languages
import Aura.Pacman
import Aura.Pkgbuild.Editing (hotEdit)
import Aura.Settings
import Aura.Types
import Aura.Utils
import Control.Compactable (fmapEither)
import Control.Monad.Trans.Maybe
import Data.Bifunctor (bimap)
import Data.Generics.Product (field)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NEL
import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NES
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import Data.These (These(..))
import Lens.Micro ((^.))
import RIO hiding ((<>))
import qualified RIO.ByteString as B
import RIO.List (unzip)
import qualified RIO.Set as S
import qualified RIO.Text as T
import System.Path.IO (doesFileExist)
data Env = Env { repository :: !Repository, settings :: !Settings }
data Repository = Repository
{ repoCache :: !(TVar (Map PkgName Package))
, repoLookup :: Settings -> NESet 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.nonEmptySet bads of
Nothing -> pure items
Just bads' -> second (goods <>) <$> MaybeT (repoLookup b ss bads')
partitionPkgs :: NonEmpty (NESet Package) -> ([Prebuilt], [NESet Buildable])
partitionPkgs = bimap fold f . unzip . map g . toList
where g = fmapEither toEither . toList
f = mapMaybe (fmap NES.fromList . NEL.nonEmpty)
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 (^. field @"name") <$> 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", pkg ^. field @"name"]
removePkgs :: NESet PkgName -> RIO Env ()
removePkgs pkgs = do
pacOpts <- asks (commonConfigOf . settings)
liftIO . pacman $ ["-Rsu"] <> asFlag pkgs <> asFlag pacOpts
newtype Unsatisfied = Unsatisfied (NESet Dep)
newtype Satisfied = Satisfied (NESet Dep)
areSatisfied :: NESet Dep -> IO (These Unsatisfied Satisfied)
areSatisfied ds = do
unsats <- S.fromList . mapMaybe parseDep <$> unsat
pure . bimap Unsatisfied Satisfied $ NES.partition (`S.member` unsats) ds
where
unsat :: IO [Text]
unsat = pacmanLines $ "-T" : map renderedDep (toList ds)
checkDBLock :: Settings -> IO ()
checkDBLock ss = do
locked <- doesFileExist lockFile
when locked $ (warn ss . checkDBLock_1 $ langOf ss) *> B.getLine *> checkDBLock ss
notify :: Settings -> Doc AnsiStyle -> IO ()
notify ss = putStrLnA ss . green
warn :: Settings -> Doc AnsiStyle -> IO ()
warn ss = putStrLnA ss . yellow
scold :: Settings -> Doc AnsiStyle -> IO ()
scold ss = putStrLnA ss . red
report :: (Doc AnsiStyle -> Doc AnsiStyle) -> (Language -> Doc AnsiStyle) -> NonEmpty PkgName -> RIO Env ()
report c msg pkgs = do
ss <- asks settings
liftIO . putStrLnA ss . c . msg $ langOf ss
liftIO . putTextLn . dtot . colourCheck ss . vsep . map (cyan . pretty . view (field @"name")) $ toList pkgs