{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module Aura.Install
( install
, displayPkgDeps
) where
import Aura.Build
import Aura.Cache (Cache(..), cacheContents)
import Aura.Colour
import Aura.Core
import Aura.Dependencies (resolveDeps)
import Aura.IO
import Aura.Languages
import Aura.Packages.AUR (aurLookup)
import Aura.Pacman (pacman, pacmanSuccess)
import Aura.Pkgbuild.Records
import Aura.Security
import Aura.Settings
import Aura.Types
import Aura.Utils
import Control.Scheduler (Comp(..), traverseConcurrently)
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import RIO
import RIO.Directory (setCurrentDirectory)
import RIO.FilePath (takeFileName)
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NEL
import qualified RIO.Set as S
import Text.Printf (printf)
install :: NonEmpty PkgName -> RIO Env ()
install pkgs = do
ss <- asks settings
if not $ switch ss DeleteMakeDeps
then install' pkgs
else do
orphansBefore <- liftIO . orphans $ envOf ss
install' pkgs
orphansAfter <- liftIO . orphans $ envOf ss
let makeDeps = nes $ orphansAfter S.\\ orphansBefore
traverse_ (\mds -> liftIO (notify ss removeMakeDepsAfter_1) *> removePkgs mds) makeDeps
install' :: NonEmpty PkgName -> RIO Env ()
install' pkgs = do
rpstry <- asks repository
ss <- asks settings
let !env = envOf ss
unneeded <- bool
(pure S.empty)
(S.fromList . catMaybes <$> liftIO (traverseConcurrently Par' (isInstalled env) $ toList pkgs))
$ shared ss NeededOnly
let !pkgs' = S.fromList $ NEL.toList pkgs
if shared ss NeededOnly && unneeded == pkgs'
then warn ss install_2
else do
let (ignored, notIgnored) = S.partition (`S.member` ignoresOf ss) pkgs'
installAnyway <- confirmIgnored ignored
case nes $ (notIgnored <> installAnyway) S.\\ unneeded of
Nothing -> warn ss install_2
Just toInstall -> do
traverse_ (report yellow reportUnneededPackages_1) . NEL.nonEmpty
$ toList unneeded
(nons, toBuild) <- liftMaybeM (Failure $ FailMsg connectFailure_1) . liftIO
$ aurLookup (managerOf ss) toInstall
pkgbuildDiffs toBuild
traverse_ (report red reportNonPackages_1) . NEL.nonEmpty $ toList nons
let !explicits = bool (S.map (\b -> b { bIsExplicit = True }) toBuild) toBuild
$ switch ss AsDeps
case nes explicits of
Nothing -> throwM . Failure $ FailMsg install_2
Just toBuild' -> do
notify ss install_5 *> hFlush stdout
allPkgs <- if switch ss SkipDepCheck
then pure . (:| []) $ NEL.map FromAUR toBuild'
else depsToInstall rpstry toBuild'
let (repoPkgs, buildPkgs) = second uniquePkgBase $ partitionPkgs allPkgs
unless (switch ss NoPkgbuildCheck)
$ traverse_ (traverse_ analysePkgbuild) buildPkgs
reportPkgsToInstall repoPkgs buildPkgs
unless (switch ss DryRun) . withOkay ss install_3 install_4 $ do
traverse_ repoInstall $ NEL.nonEmpty repoPkgs
let !mbuildPkgs = NEL.nonEmpty buildPkgs
traverse_ (liftIO . storePkgbuilds . fold1) mbuildPkgs
traverse_ buildAndInstall mbuildPkgs
annotateDeps :: Environment -> NonEmpty Buildable -> IO ()
annotateDeps env bs = unless (null bs') . void . pacmanSuccess env
$ ["-D", "--asdeps"] <> asFlag (map bName bs')
where
bs' :: [Buildable]
bs' = NEL.filter (not . bIsExplicit) bs
uniquePkgBase :: [NonEmpty Buildable] -> [NonEmpty Buildable]
uniquePkgBase bs = mapMaybe g bs
where
bs' :: [Buildable]
bs' = foldMap NEL.toList bs
g :: NonEmpty Buildable -> Maybe (NonEmpty Buildable)
g = NEL.nonEmpty . nubOrd . NEL.filter (\b -> bName b `S.member` goods)
f :: Buildable -> Buildable -> Buildable
f a b | bName a == bBase a = a
| bName b == bBase b = b
| otherwise = a
goods :: Set PkgName
goods = S.fromList . map bName . M.elems . M.fromListWith f $ map (bBase &&& id) bs'
confirmIgnored :: Set PkgName -> RIO Env (Set PkgName)
confirmIgnored (toList -> ps) = do
ss <- asks settings
S.fromList <$> filterM (liftIO . optionalPrompt ss . confirmIgnored_1) ps
depsToInstall :: Repository -> NonEmpty Buildable -> RIO Env (NonEmpty (NonEmpty Package))
depsToInstall repo bs = resolveDeps repo $ NEL.map FromAUR bs
repoInstall :: NonEmpty Prebuilt -> RIO Env ()
repoInstall ps = do
ss <- asks settings
let !pacOpts = asFlag $ commonConfigOf ss
liftIO . pacman (envOf ss) $ ["-S", "--asdeps"] <> pacOpts <> asFlag (NEL.map pName ps)
buildAndInstall :: NonEmpty (NonEmpty Buildable) -> RIO Env ()
buildAndInstall bss = do
ss <- asks settings
let !pth = either id id . cachePathOf $ commonConfigOf ss
!allsource = S.member AllSource . makepkgFlagsOf $ buildConfigOf ss
cache <- liftIO $ cacheContents pth
when allsource $ notify ss buildPackages_2
traverse_ (f ss cache) bss
when allsource $ do
let !allsourcePath = fromMaybe srcPkgStore . allsourcePathOf $ buildConfigOf ss
notify ss $ buildPackages_3 allsourcePath
where
f :: Settings -> Cache -> NonEmpty Buildable -> RIO Env ()
f ss cache bs = do
let (ps, cached) = fmapEither (g ss cache) $ NEL.toList bs
when (switch ss HotEdit && not (null cached)) $ do
warn ss buildPackages_4
traverse_ (liftIO . printf " - %s\n" . takeFileName . ppPath) cached
warn ss buildPackages_5
built <- traverse buildPackages $ NEL.nonEmpty ps
traverse_ installPkgFiles $ (built <> Just cached) >>= NEL.nonEmpty
liftIO $ annotateDeps (envOf ss) bs
g :: Settings -> Cache -> Buildable -> Either Buildable PackagePath
g ss (Cache cache) b = case bToSP b `M.lookup` cache of
Just pp | not (switch ss ForceBuilding) -> Right pp
_ -> Left b
displayPkgDeps :: NonEmpty PkgName -> RIO Env ()
displayPkgDeps ps = do
logDebug "-Ad: Checking dependencies."
rpstry <- asks repository
ss <- asks settings
let f :: NonEmpty Buildable -> RIO Env ()
f = depsToInstall rpstry >=> reportDeps (switch ss LowVerbosity) . partitionPkgs
liftIO (aurLookup (managerOf ss) ps) >>= \case
Nothing -> do
logDebug "-Ad: Receiving `Nothing` from `aurLookup`."
throwM . Failure $ FailMsg connectFailure_1
Just (_, goods) -> do
logDebug "-Ad: Initial AUR lookup successful."
traverse_ f $ nes goods
where
reportDeps :: Bool -> ([Prebuilt], [NonEmpty Buildable]) -> RIO Env ()
reportDeps True = liftIO . uncurry reportListOfDeps
reportDeps False = uncurry reportPkgsToInstall
reportPkgsToInstall :: [Prebuilt] -> [NonEmpty Buildable] -> RIO Env ()
reportPkgsToInstall rps bps = do
let (explicits, ds) = L.partition bIsExplicit $ foldMap NEL.toList bps
f reportPkgsToInstall_1 $ map pName rps
f reportPkgsToInstall_3 $ map bName ds
f reportPkgsToInstall_2 $ map bName explicits
where
f :: (Language -> Doc AnsiStyle) -> [PkgName] -> RIO Env ()
f m xs = traverse_ (report green m) . NEL.nonEmpty $ L.sort xs
reportListOfDeps :: [Prebuilt] -> [NonEmpty Buildable] -> IO ()
reportListOfDeps rps bps = f (map pName rps) *> f (map bName $ foldMap NEL.toList bps)
where
f :: [PkgName] -> IO ()
f = traverse_ putTextLn . L.sort . map pnName
pkgbuildDiffs :: Set Buildable -> RIO Env ()
pkgbuildDiffs ps = asks settings >>= check
where
check :: Settings -> RIO Env ()
check ss | not $ switch ss DiffPkgbuilds = pure ()
| otherwise = traverse_ displayDiff ps
displayDiff :: Buildable -> RIO Env ()
displayDiff p = do
ss <- asks settings
let pn = bName p
isStored <- liftIO $ hasPkgbuildStored pn
if not isStored
then warn ss $ reportPkgbuildDiffs_1 pn
else liftIO $ do
setCurrentDirectory "/tmp"
let new = "/tmp/new.pb"
writeFileBinary new . pkgbuild $ bPkgbuild p
warn ss $ reportPkgbuildDiffs_3 pn
diff ss (pkgbuildPath pn) new