{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Aura.Core
(
Env(..)
, Repository(..)
, liftEither, liftEitherM
, liftMaybe, 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 BasePrelude hiding ((<>))
import Control.Compactable (fmapEither)
import Control.Effect (Carrier, Member)
import Control.Effect.Error (Error, throwError)
import Control.Effect.Lift (Lift, sendM)
import Control.Effect.Reader (Reader, asks)
import Control.Monad.Trans.Maybe
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Generics.Product (field)
import qualified Data.List.NonEmpty as NEL
import Data.Map.Strict (Map)
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as S
import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NES
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import Data.These (These(..))
import Lens.Micro ((^.))
import Lens.Micro.Extras (view)
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
liftEither :: (Carrier sig m, Member (Error a) sig) => Either a b -> m b
liftEither = either throwError pure
liftEitherM :: (Carrier sig m, Member (Error a) sig) => m (Either a b) -> m b
liftEitherM m = m >>= liftEither
liftMaybe :: (Carrier sig m, Member (Error a) sig) => a -> Maybe b -> m b
liftMaybe a = maybe (throwError a) pure
liftMaybeM :: (Carrier sig m, Member (Error a) sig) => a -> m (Maybe b) -> m b
liftMaybeM a m = m >>= liftMaybe a
sudo :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig) => m a -> m a
sudo action = asks (hasRootPriv . envOf . settings) >>= bool (throwError $ Failure mustBeRoot_1) action
trueRoot :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig) => m a -> m a
trueRoot action = asks settings >>= \ss ->
if not (isTrueRoot $ envOf ss) && buildUserOf (buildConfigOf ss) /= Just (User "root")
then action else throwError $ Failure trueRoot_3
foreignPackages :: IO (Set SimplePkg)
foreignPackages = S.fromList . mapMaybe (simplepkg' . strictText) . BL.lines <$> pacmanOutput ["-Qm"]
orphans :: IO (Set PkgName)
orphans = S.fromList . map (PkgName . strictText) . BL.lines <$> pacmanOutput ["-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 :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>
NESet PkgName -> m ()
removePkgs pkgs = do
pacOpts <- asks (commonConfigOf . settings)
liftEitherM . sendM . 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 (\d -> S.member d unsats) ds
where
unsat :: IO [T.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) *> 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 :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) =>
(Doc AnsiStyle -> Doc AnsiStyle) -> (Language -> Doc AnsiStyle) -> NonEmpty PkgName -> m ()
report c msg pkgs = do
ss <- asks settings
sendM . putStrLnA ss . c . msg $ langOf ss
sendM . T.putStrLn . dtot . colourCheck ss . vsep . map (cyan . pretty . view (field @"name")) $ toList pkgs