aura 2.0.3 → 2.0.4
raw patch · 35 files changed
+698/−776 lines, 35 filesdep +riodep −base-preludedep −directorydep −fused-effects
Dependencies added: rio
Dependencies removed: base-prelude, directory, fused-effects
Files
- CHANGELOG.md +4/−0
- aura.cabal +14/−16
- doc/aura.8 +1/−1
- exec/Flags.hs +59/−58
- exec/Settings.hs +6/−6
- exec/aura.hs +33/−32
- lib/Aura/Build.hs +18/−28
- lib/Aura/Cache.hs +9/−10
- lib/Aura/Colour.hs +1/−2
- lib/Aura/Commands/A.hs +48/−53
- lib/Aura/Commands/B.hs +12/−6
- lib/Aura/Commands/C.hs +53/−60
- lib/Aura/Commands/L.hs +16/−23
- lib/Aura/Commands/O.hs +10/−15
- lib/Aura/Core.hs +24/−48
- lib/Aura/Dependencies.hs +24/−30
- lib/Aura/Diff.hs +1/−1
- lib/Aura/Install.hs +66/−76
- lib/Aura/Languages.hs +34/−31
- lib/Aura/Languages/Fields.hs +20/−20
- lib/Aura/Logo.hs +30/−30
- lib/Aura/MakePkg.hs +6/−6
- lib/Aura/Packages/AUR.hs +15/−19
- lib/Aura/Packages/Repository.hs +9/−12
- lib/Aura/Pacman.hs +26/−32
- lib/Aura/Pkgbuild/Base.hs +1/−3
- lib/Aura/Pkgbuild/Editing.hs +13/−14
- lib/Aura/Pkgbuild/Fetch.hs +8/−9
- lib/Aura/Pkgbuild/Records.hs +8/−10
- lib/Aura/Pkgbuild/Security.hs +13/−12
- lib/Aura/Settings.hs +7/−7
- lib/Aura/State.hs +33/−31
- lib/Aura/Types.hs +20/−17
- lib/Aura/Utils.hs +49/−48
- test/Test.hs +7/−10
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Aura Changelog +## 2.0.4 (2020-02-08)++- Removed `fused-effects` dependency in favour of `rio` to simplify code.+ ## 2.0.3 - Updated Spanish translations. Thanks to Max Ferrer!
aura.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: aura-version: 2.0.3+version: 2.0.4 synopsis: A secure package manager for Arch Linux and the AUR, written in Haskell. @@ -12,7 +12,7 @@ AUR package managers. category: System-homepage: https://github.com/aurapm/aura+homepage: https://github.com/fosskers/aura author: Colin Woodbury maintainer: colin@fosskers.ca license: GPL-3.0-only@@ -34,22 +34,21 @@ -funclutter-valid-hole-fits build-depends:- , base >=4.12 && <5- , base-prelude >=1.2 && <1.4- , bytestring ^>=0.10- , containers ^>=0.6- , microlens ^>=0.4- , paths ^>=0.2- , text ^>=1.2- , versions ^>=3.5+ , base >=4.12 && <5+ , bytestring ^>=0.10+ , containers ^>=0.6+ , microlens ^>=0.4+ , paths ^>=0.2+ , rio ^>=0.1.13+ , text ^>=1.2+ , versions ^>=3.5 common libexec build-depends: , errors ^>=2.3- , fused-effects >=0.4 && <1.1 , http-client >=0.5 && <0.7 , nonempty-containers ^>=0.3- , prettyprinter >=1.2 && < 1.6+ , prettyprinter >=1.2 && <1.6 , prettyprinter-ansi-terminal ^>=1.1 , transformers ^>=0.5 , typed-process ^>=0.2@@ -93,9 +92,8 @@ , algebraic-graphs >=0.1 && <0.5 , aur ^>=6.3 , compactable ^>=0.1- , directory ^>=1.3 , filepath ^>=1.4- , generic-lens >=1.1 && < 1.3+ , generic-lens >=1.1 && <1.3 , http-types >=0.9 && <0.13 , language-bash ^>=0.8 , megaparsec ^>=7@@ -106,7 +104,7 @@ , semigroupoids >=5.2 && <5.4 , stm ^>=2.5 , these ^>=1.0- , time >=1.8 && < 1.10+ , time >=1.8 && <1.10 , unliftio ^>=0.2 executable aura@@ -121,7 +119,7 @@ build-depends: , aura , http-client-tls ^>=0.3- , optparse-applicative >=0.14 && < 0.16+ , optparse-applicative >=0.14 && <0.16 , pretty-simple >=2.1 && <3.3 test-suite aura-test
doc/aura.8 view
@@ -1,7 +1,7 @@ .\" Man page for `aura` .\" Written by Colin Woodbury <colin@fosskers.ca> -.TH aura 8 "June 2018" "Aura" "Aura Manual"+.TH aura 8 "January 2020" "Aura" "Aura Manual" .\" Disable hyphenation. .nh
exec/Flags.hs view
@@ -11,14 +11,15 @@ import Aura.Pacman (defaultLogFile, pacmanConfFile) import Aura.Settings import Aura.Types-import BasePrelude hiding (Version, exp, log, option) import qualified Data.List.NonEmpty as NEL-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 Lens.Micro import Options.Applicative+import RIO hiding (exp, log)+import RIO.List.Partial (foldr1)+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Path (Absolute, Path, fromAbsoluteFilePath, toFilePath) ---@@ -26,7 +27,7 @@ -- | A description of a run of Aura to attempt. data Program = Program { -- ^ Whether Aura handles everything, or the ops and input are just passed down to Pacman.- _operation :: Either (PacmanOp, S.Set MiscOp) AuraOp+ _operation :: Either (PacmanOp, Set MiscOp) AuraOp -- ^ Settings common to both Aura and Pacman. , _commons :: CommonConfig -- ^ Settings specific to building packages.@@ -36,12 +37,12 @@ -- | Inherited operations that are fed down to Pacman. data PacmanOp = Database (Either DatabaseOp (NESet PkgName))- | Files (S.Set FilesOp)- | Query (Either QueryOp (S.Set QueryFilter, S.Set PkgName))- | Remove (S.Set RemoveOp) (NESet PkgName)- | Sync (Either SyncOp (S.Set PkgName)) (S.Set SyncSwitch)- | TestDeps (NESet T.Text)- | Upgrade (S.Set UpgradeSwitch) (NESet PkgName)+ | Files (Set FilesOp)+ | Query (Either QueryOp (Set QueryFilter, Set PkgName))+ | Remove (Set RemoveOp) (NESet PkgName)+ | Sync (Either SyncOp (Set PkgName)) (Set SyncSwitch)+ | TestDeps (NESet Text)+ | Upgrade (Set UpgradeSwitch) (NESet PkgName) deriving (Show) instance Flagable PacmanOp where@@ -57,8 +58,8 @@ asFlag (Upgrade s ps) = "-U" : asFlag s ++ asFlag ps data DatabaseOp = DBCheck- | DBAsDeps (NESet T.Text)- | DBAsExplicit (NESet T.Text)+ | DBAsDeps (NESet Text)+ | DBAsExplicit (NESet Text) deriving (Show) instance Flagable DatabaseOp where@@ -66,9 +67,9 @@ asFlag (DBAsDeps ps) = "--asdeps" : asFlag ps asFlag (DBAsExplicit ps) = "--asexplicit" : asFlag ps -data FilesOp = FilesList (NESet T.Text)- | FilesOwns T.Text- | FilesSearch T.Text+data FilesOp = FilesList (NESet Text)+ | FilesOwns Text+ | FilesSearch Text | FilesRegex | FilesRefresh | FilesMachineReadable@@ -82,14 +83,14 @@ asFlag FilesRefresh = ["--refresh"] asFlag FilesMachineReadable = ["--machinereadable"] -data QueryOp = QueryChangelog (NESet T.Text)- | QueryGroups (NESet T.Text)- | QueryInfo (NESet T.Text)- | QueryCheck (NESet T.Text)- | QueryList (NESet T.Text)- | QueryOwns (NESet T.Text)- | QueryFile (NESet T.Text)- | QuerySearch T.Text+data QueryOp = QueryChangelog (NESet Text)+ | QueryGroups (NESet Text)+ | QueryInfo (NESet Text)+ | QueryCheck (NESet Text)+ | QueryList (NESet Text)+ | QueryOwns (NESet Text)+ | QueryFile (NESet Text)+ | QuerySearch Text deriving (Show) instance Flagable QueryOp where@@ -131,12 +132,12 @@ asFlag RemoveUnneeded = ["--unneeded"] data SyncOp = SyncClean- | SyncGroups (NESet T.Text)- | SyncInfo (NESet T.Text)- | SyncList T.Text- | SyncSearch T.Text- | SyncUpgrade (S.Set T.Text)- | SyncDownload (NESet T.Text)+ | SyncGroups (NESet Text)+ | SyncInfo (NESet Text)+ | SyncList Text+ | SyncSearch Text+ | SyncUpgrade (Set Text)+ | SyncDownload (NESet Text) deriving (Show) instance Flagable SyncOp where@@ -149,8 +150,8 @@ asFlag (SyncDownload ps) = "--downloadonly" : asFlag ps data SyncSwitch = SyncRefresh- | SyncIgnore (S.Set PkgName)- | SyncIgnoreGroup (S.Set PkgGroup)+ | SyncIgnore (Set PkgName)+ | SyncIgnoreGroup (Set PkgGroup) deriving (Eq, Ord, Show) instance Flagable SyncSwitch where@@ -160,8 +161,8 @@ data UpgradeSwitch = UpgradeAsDeps | UpgradeAsExplicit- | UpgradeIgnore (S.Set PkgName)- | UpgradeIgnoreGroup (S.Set PkgGroup)+ | UpgradeIgnore (Set PkgName)+ | UpgradeIgnoreGroup (Set PkgGroup) deriving (Eq, Ord, Show) instance Flagable UpgradeSwitch where@@ -172,8 +173,8 @@ -- | Flags common to several Pacman operations. data MiscOp = MiscArch (Path Absolute)- | MiscAssumeInstalled T.Text- | MiscColor T.Text+ | MiscAssumeInstalled Text+ | MiscColor Text | MiscConfirm | MiscDBOnly | MiscDBPath (Path Absolute)@@ -183,7 +184,7 @@ | MiscNoProgress | MiscNoScriptlet | MiscPrint- | MiscPrintFormat T.Text+ | MiscPrintFormat Text | MiscRoot (Path Absolute) | MiscVerbose deriving (Eq, Ord, Show)@@ -206,7 +207,7 @@ asFlag MiscVerbose = ["--verbose"] -- | Operations unique to Aura.-data AuraOp = AurSync (Either AurOp (NESet PkgName)) (S.Set AurSwitch)+data AuraOp = AurSync (Either AurOp (NESet PkgName)) (Set AurSwitch) | Backup (Maybe BackupOp) | Cache (Either CacheOp (NESet PkgName)) | Log (Maybe LogOp)@@ -216,35 +217,35 @@ | ViewConf deriving (Show) -_AurSync :: Traversal' AuraOp (S.Set AurSwitch)+_AurSync :: Traversal' AuraOp (Set AurSwitch) _AurSync f (AurSync o s) = AurSync o <$> f s _AurSync _ x = pure x data AurOp = AurDeps (NESet PkgName) | AurInfo (NESet PkgName) | AurPkgbuild (NESet PkgName)- | AurSearch T.Text- | AurUpgrade (S.Set PkgName)+ | AurSearch Text+ | AurUpgrade (Set PkgName) | AurJson (NESet PkgName) deriving (Show) -data AurSwitch = AurIgnore (S.Set PkgName)- | AurIgnoreGroup (S.Set PkgGroup)+data AurSwitch = AurIgnore (Set PkgName)+ | AurIgnoreGroup (Set PkgGroup) deriving (Eq, Ord, Show) -_AurIgnore :: Traversal' AurSwitch (S.Set PkgName)+_AurIgnore :: Traversal' AurSwitch (Set PkgName) _AurIgnore f (AurIgnore s) = AurIgnore <$> f s _AurIgnore _ x = pure x -_AurIgnoreGroup :: Traversal' AurSwitch (S.Set PkgGroup)+_AurIgnoreGroup :: Traversal' AurSwitch (Set PkgGroup) _AurIgnoreGroup f (AurIgnoreGroup s) = AurIgnoreGroup <$> f s _AurIgnoreGroup _ x = pure x data BackupOp = BackupClean Word | BackupRestore | BackupList deriving (Show) -data CacheOp = CacheBackup (Path Absolute) | CacheClean Word | CacheCleanNotSaved | CacheSearch T.Text deriving (Show)+data CacheOp = CacheBackup (Path Absolute) | CacheClean Word | CacheCleanNotSaved | CacheSearch Text deriving (Show) -data LogOp = LogInfo (NESet PkgName) | LogSearch T.Text deriving (Show)+data LogOp = LogInfo (NESet PkgName) | LogSearch Text deriving (Show) data OrphanOp = OrphanAbandon | OrphanAdopt (NESet PkgName) deriving (Show) @@ -333,7 +334,7 @@ <|> fmap Tail (option auto (long "tail" <> metavar "N" <> hidden <> help "Only show last N search results.")) <|> pure None -buildSwitches :: Parser (S.Set BuildSwitch)+buildSwitches :: Parser (Set BuildSwitch) buildSwitches = S.fromList <$> many (lv <|> dmd <|> dsm <|> dpb <|> rbd <|> he <|> ucp <|> dr <|> sa <|> fo <|> npc) where dmd = flag' DeleteMakeDeps (long "delmakedeps" <> short 'a' <> hidden <> help "Uninstall makedeps after building.") dsm = flag' DontSuppressMakepkg (long "unsuppress" <> short 'x' <> hidden <> help "Unsuppress makepkg output.")@@ -359,7 +360,7 @@ (strOption (long "logfile" <> hidden <> help "Use an alternate Pacman log.")) <|> pure (Left defaultLogFile) -commonSwitches :: Parser (S.Set CommonSwitch)+commonSwitches :: Parser (Set CommonSwitch) commonSwitches = S.fromList <$> many (nc <|> no <|> dbg <|> clr) where nc = flag' NoConfirm (long "noconfirm" <> hidden <> help "Never ask for Aura or Pacman confirmation.") no = flag' NeededOnly (long "needed" <> hidden <> help "Don't rebuild/reinstall up-to-date packages.")@@ -403,7 +404,7 @@ fls = QueryFile <$> (flag' () (long "file" <> short 'p' <> hidden <> help "Query a package file.") *> someArgs') sch = QuerySearch <$> strOption (long "search" <> short 's' <> metavar "REGEX" <> hidden <> help "Search the local database.") -queryFilters :: Parser (S.Set QueryFilter)+queryFilters :: Parser (Set QueryFilter) queryFilters = S.fromList <$> many (dps <|> exp <|> frg <|> ntv <|> urq <|> upg) where dps = flag' QueryDeps (long "deps" <> short 'd' <> hidden <> help "[filter] Only list packages installed as deps.") exp = flag' QueryExplicit (long "explicit" <> short 'e' <> hidden <> help "[filter] Only list explicitly installed packages.")@@ -438,7 +439,7 @@ igg = SyncIgnoreGroup . S.fromList . map PkgGroup . T.split (== ',') <$> strOption (long "ignoregroup" <> metavar "PKG(,PKG,...)" <> hidden <> help "Ignore packages from the given groups.") -misc :: Parser (S.Set MiscOp)+misc :: Parser (Set MiscOp) misc = S.fromList <$> many (ar <|> dbp <|> roo <|> ver <|> gpg <|> hd <|> con <|> dbo <|> nop <|> nos <|> pf <|> nod <|> prt <|> asi) where ar = MiscArch . fromAbsoluteFilePath <$> strOption (long "arch" <> metavar "ARCH" <> hidden <> help "Use an alternate architecture.")@@ -476,26 +477,26 @@ strOption (long "ignoregroup" <> metavar "PKG(,PKG,...)" <> hidden <> help "Ignore packages from the given groups.") somePkgs :: Parser (NESet PkgName)-somePkgs = NES.fromList . fromJust . NEL.nonEmpty . map PkgName <$> some (argument str (metavar "PACKAGES"))+somePkgs = NES.fromList . NEL.fromList . map PkgName <$> some (argument str (metavar "PACKAGES")) -- | Same as `someArgs`, but the help message "brief display" won't show PACKAGES. somePkgs' :: Parser (NESet PkgName)-somePkgs' = NES.fromList . fromJust . NEL.nonEmpty . map PkgName <$> some (argument str (metavar "PACKAGES" <> hidden))+somePkgs' = NES.fromList . NEL.fromList . map PkgName <$> some (argument str (metavar "PACKAGES" <> hidden)) -- | One or more arguments.-someArgs :: Parser (NESet T.Text)-someArgs = NES.fromList . fromJust . NEL.nonEmpty <$> some (argument str (metavar "PACKAGES"))+someArgs :: Parser (NESet Text)+someArgs = NES.fromList . NEL.fromList <$> some (argument str (metavar "PACKAGES")) -- | Same as `someArgs`, but the help message "brief display" won't show PACKAGES.-someArgs' :: Parser (NESet T.Text)-someArgs' = NES.fromList . fromJust . NEL.nonEmpty <$> some (argument str (metavar "PACKAGES" <> hidden))+someArgs' :: Parser (NESet Text)+someArgs' = NES.fromList . NEL.fromList <$> some (argument str (metavar "PACKAGES" <> hidden)) -- | Zero or more arguments.-manyArgs :: Parser (S.Set T.Text)+manyArgs :: Parser (Set Text) manyArgs = S.fromList <$> many (argument str (metavar "PACKAGES")) -- | Zero or more arguments.-manyArgs' :: Parser (S.Set T.Text)+manyArgs' :: Parser (Set Text) manyArgs' = S.fromList <$> many (argument str (metavar "PACKAGES" <> hidden)) language :: Parser Language
exec/Settings.hs view
@@ -26,20 +26,20 @@ import Aura.Settings import Aura.Types import Aura.Utils-import BasePrelude hiding (FilePath) import Control.Error.Util (failWith) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except-import qualified Data.Map.Strict as M-import qualified Data.Set as S+import Data.Bifunctor (Bifunctor(..)) import qualified Data.Set.NonEmpty as NES-import qualified Data.Text as T import Flags-import Lens.Micro+import Lens.Micro (folded, (^..), _Right) import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings)+import RIO hiding (FilePath, first)+import qualified RIO.Map as M+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Environment (getEnvironment)-import System.IO (hIsTerminalDevice, stdout) ---
exec/aura.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-}@@ -51,19 +52,14 @@ import Aura.Pacman import Aura.Settings import Aura.Types-import BasePrelude hiding (Version)-import Control.Effect (Carrier, Member)-import Control.Effect.Error (Error, runError)-import Control.Effect.Lift (Lift, runM, sendM)-import Control.Effect.Reader (Reader, asks, runReader)-import Data.Set (Set)+import Aura.Utils (putTextLn)+import Data.Bifunctor (first) 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 Flags import Options.Applicative (execParser)+import RIO hiding (first) import Settings import System.Path (toFilePath) import System.Process.Typed (proc, runProcess)@@ -71,40 +67,45 @@ --- -auraVersion :: T.Text-auraVersion = "2.0.3"+#ifndef CURRENT_PACKAGE_VERSION+#define CURRENT_PACKAGE_VERSION "UNKNOWN"+#endif +auraVersion :: Text+auraVersion = CURRENT_PACKAGE_VERSION+ main :: IO () main = do options <- execParser opts esettings <- getSettings options repos <- (<>) <$> pacmanRepo <*> aurRepo case esettings of- Left err -> T.putStrLn . dtot . ($ English) $ failure err+ Left err -> putTextLn . dtot . ($ English) $ failure err Right ss -> execute ss repos options >>= exit ss execute :: Settings -> Repository -> Program -> IO (Either (Doc AnsiStyle) ())-execute ss r p = first (($ langOf ss) . failure) <$> (runM . runReader (Env r ss) . runError . executeOpts $ _operation p)+execute ss r p = first f <$> try (runRIO (Env r ss) . execOpts $ _operation p)+ where+ f (Failure fl) = fl $ langOf ss exit :: Settings -> Either (Doc AnsiStyle) () -> IO a exit ss (Left e) = scold ss e *> exitFailure exit _ (Right _) = exitSuccess -executeOpts :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- Either (PacmanOp, Set MiscOp) AuraOp -> m ()-executeOpts ops = do+execOpts :: Either (PacmanOp, Set MiscOp) AuraOp -> RIO Env ()+execOpts ops = do ss <- asks settings when (shared ss Debug) $ do- sendM @IO . pPrintNoColor $ ops- sendM @IO . pPrintNoColor $ buildConfigOf ss- sendM @IO . pPrintNoColor $ commonConfigOf ss- let p (ps, ms) = liftEitherM . sendM . pacman $+ liftIO . pPrintNoColor $ ops+ liftIO . pPrintNoColor $ buildConfigOf ss+ liftIO . pPrintNoColor $ commonConfigOf ss+ let p (ps, ms) = liftIO . pacman $ asFlag ps ++ foldMap asFlag ms ++ asFlag (commonConfigOf ss) ++ bool [] ["--quiet"] (switch ss LowVerbosity) case ops of- Left o@(Sync (Left (SyncUpgrade _)) _, _) -> sudo (sendM $ B.saveState ss) *> p o+ Left o@(Sync (Left (SyncUpgrade _)) _, _) -> sudo (liftIO $ B.saveState ss) *> p o Left o -> p o Right (AurSync o _) -> case o of@@ -117,10 +118,10 @@ Left (AurJson ps) -> A.aurJson ps Right (Backup o) -> case o of- Nothing -> sudo . sendM $ B.saveState ss- Just (BackupClean n) -> sudo . sendM $ B.cleanStates ss n+ Nothing -> sudo . liftIO $ B.saveState ss+ Just (BackupClean n) -> sudo . liftIO $ B.cleanStates ss n Just BackupRestore -> sudo B.restoreState- Just BackupList -> sendM B.listStates+ Just BackupList -> liftIO B.listStates Right (Cache o) -> case o of Right ps -> sudo $ C.downgradePackages ps@@ -132,23 +133,23 @@ case o of Nothing -> L.viewLogFile Just (LogInfo ps) -> L.logInfoOnPkg ps- Just (LogSearch s) -> asks settings >>= sendM . flip L.searchLogFile s+ Just (LogSearch s) -> asks settings >>= liftIO . flip L.searchLogFile s Right (Orphans o) -> case o of- Nothing -> sendM O.displayOrphans- Just OrphanAbandon -> sudo $ sendM orphans >>= traverse_ removePkgs . NES.nonEmptySet+ Nothing -> liftIO O.displayOrphans+ Just OrphanAbandon -> sudo $ liftIO orphans >>= traverse_ removePkgs . NES.nonEmptySet Just (OrphanAdopt ps) -> O.adoptPkg ps- Right Version -> sendM $ versionInfo >>= animateVersionMsg ss auraVersion+ Right Version -> liftIO $ versionInfo >>= animateVersionMsg ss auraVersion Right Languages -> displayOutputLanguages Right ViewConf -> viewConfFile -displayOutputLanguages :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => m ()+displayOutputLanguages :: RIO Env () displayOutputLanguages = do ss <- asks settings- sendM . notify ss . displayOutputLanguages_1 $ langOf ss- sendM $ traverse_ print [English ..]+ liftIO . notify ss . displayOutputLanguages_1 $ langOf ss+ liftIO $ traverse_ (putTextLn . tshow) [English ..] -viewConfFile :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => m ()+viewConfFile :: RIO Env () viewConfFile = do pth <- asks (either id id . configPathOf . commonConfigOf . settings)- sendM . void . runProcess @IO $ proc "less" [toFilePath pth]+ liftIO . void . runProcess @IO $ proc "less" [toFilePath pth]
lib/Aura/Build.hs view
@@ -25,25 +25,18 @@ import Aura.Settings import Aura.Types import Aura.Utils-import BasePrelude import Control.Compactable (traverseMaybe)-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.Class (lift) import Control.Monad.Trans.Except-import qualified Data.ByteString.Lazy.Char8 as BL import Data.Generics.Product (field) import qualified Data.List.NonEmpty as NEL import Data.Semigroup.Foldable (fold1)-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 Lens.Micro ((^.))-import System.Directory (setCurrentDirectory)-import System.IO (hFlush, stdout)+import RIO+import RIO.Directory (setCurrentDirectory)+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Path import System.Path.IO import System.Process.Typed@@ -55,30 +48,27 @@ srcPkgStore = fromAbsoluteFilePath "/var/cache/aura/src" -- | Expects files like: \/var\/cache\/pacman\/pkg\/*.pkg.tar.xz-installPkgFiles :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet PackagePath -> m ()+installPkgFiles :: NESet PackagePath -> RIO Env () installPkgFiles files = do ss <- asks settings- sendM $ checkDBLock ss- liftEitherM . sendM . pacman $ ["-U"] <> map (T.pack . toFilePath . path) (toList files) <> asFlag (commonConfigOf ss)+ liftIO $ checkDBLock ss+ liftIO . pacman $ ["-U"] <> map (T.pack . toFilePath . path) (toList files) <> asFlag (commonConfigOf ss) -- | All building occurs within temp directories, -- or in a location specified by the user with flags.-buildPackages :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet Buildable -> m (NESet PackagePath)+buildPackages :: NESet Buildable -> RIO Env (NESet PackagePath) buildPackages bs = do- g <- sendM createSystemRandom+ g <- liftIO createSystemRandom traverseMaybe (build g) (toList bs) >>= maybe bad (pure . fold1) . NEL.nonEmpty- where bad = throwError $ Failure buildFail_10+ where bad = throwM $ Failure buildFail_10 -- | Handles the building of Packages. Fails nicely. -- Assumed: All dependencies are already installed.-build :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- GenIO -> Buildable -> m (Maybe (NESet PackagePath))+build :: GenIO -> Buildable -> RIO Env (Maybe (NESet PackagePath)) build g p = do ss <- asks settings- sendM $ notify ss (buildPackages_1 (p ^. field @"name") (langOf ss)) *> hFlush stdout- result <- sendM $ build' ss g p+ liftIO $ notify ss (buildPackages_1 (p ^. field @"name") (langOf ss)) *> hFlush stdout+ result <- liftIO $ build' ss g p either buildFail (pure . Just) result -- | Should never throw an IO Exception. In theory all errors@@ -123,16 +113,16 @@ -- overwrite what's been downloaded before calling `makepkg`. overwritePkgbuild :: Settings -> Buildable -> IO () overwritePkgbuild ss p = when (switch ss HotEdit || switch ss UseCustomizepkg) $- BL.writeFile "PKGBUILD" $ p ^. field @"pkgbuild" . field @"pkgbuild"+ writeFileBinary "PKGBUILD" $ p ^. field @"pkgbuild" . field @"pkgbuild" -- | Inform the user that building failed. Ask them if they want to -- continue installing previous packages that built successfully.-buildFail :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) => Failure -> m (Maybe a)+buildFail :: Failure -> RIO Env (Maybe a) buildFail (Failure err) = do ss <- asks settings- sendM . scold ss . err $ langOf ss- response <- sendM $ optionalPrompt ss buildFail_6- bool (throwError $ Failure buildFail_5) (pure Nothing) response+ liftIO . scold ss . err $ langOf ss+ response <- liftIO $ optionalPrompt ss buildFail_6+ bool (throwM $ Failure buildFail_5) (pure Nothing) response -- | Moves a file to the pacman package cache and returns its location. moveToCachePath :: Settings -> Path Absolute -> IO PackagePath
lib/Aura/Cache.hs view
@@ -23,14 +23,13 @@ import Aura.Settings import Aura.Types-import BasePrelude import Data.Generics.Product (field)-import qualified Data.Map.Strict as M-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 Lens.Micro ((^.))+import RIO+import qualified RIO.Map as M+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Path (Absolute, Path, fromAbsoluteFilePath, toFilePath, (</>)) import System.Path.IO (getDirectoryContents)@@ -38,7 +37,7 @@ --- -- | Every package in the current cache, paired with its original filename.-newtype Cache = Cache { _cache :: M.Map SimplePkg PackagePath }+newtype Cache = Cache { _cache :: Map SimplePkg PackagePath } -- | The default location of the package cache: \/var\/cache\/pacman\/pkg\/ defaultPackageCache :: Path Absolute@@ -56,14 +55,14 @@ cacheContents :: Path Absolute -> IO Cache cacheContents pth = cache . map (PackagePath . (pth </>)) <$> getDirectoryContents pth --- | All packages from a given `S.Set` who have a copy in the cache.-pkgsInCache :: Settings -> NESet PkgName -> IO (S.Set PkgName)+-- | All packages from a given `Set` who have a copy in the cache.+pkgsInCache :: Settings -> NESet PkgName -> IO (Set PkgName) pkgsInCache ss ps = do c <- cacheContents . either id id . cachePathOf $ commonConfigOf ss pure . S.filter (`NES.member` ps) . S.map (^. field @"name") . M.keysSet $ _cache c --- | Any entries (filepaths) in the cache that match a given `T.Text`.-cacheMatches :: Settings -> T.Text -> IO [PackagePath]+-- | Any entries (filepaths) in the cache that match a given `Text`.+cacheMatches :: Settings -> Text -> IO [PackagePath] cacheMatches ss input = do c <- cacheContents . either id id . cachePathOf $ commonConfigOf ss pure . filter (T.isInfixOf input . T.pack . toFilePath . path) . M.elems $ _cache c
lib/Aura/Colour.hs view
@@ -13,10 +13,9 @@ , cyan, bCyan, green, yellow, red, magenta ) where -import BasePrelude-import Data.Text (Text) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal+import RIO ---
lib/Aura/Commands/A.hs view
@@ -36,46 +36,44 @@ import Aura.State (saveState) import Aura.Types import Aura.Utils-import BasePrelude hiding ((<+>))-import Control.Effect (Carrier, Member)-import Control.Effect.Error (Error)-import Control.Effect.Lift (Lift, sendM)-import Control.Effect.Reader (Reader, asks) import Control.Error.Util (hush)-import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)+import Data.Aeson.Encode.Pretty (encodePretty) import Data.Generics.Product (field) import qualified Data.List.NonEmpty as NEL-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.Lazy (toStrict)-import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal import Data.Versions (Versioning, prettyV, versioning)-import Lens.Micro (each, (^.), (^..))-import Lens.Micro.Extras (view)+import Lens.Micro (each, (^..)) import Linux.Arch.Aur+import Network.HTTP.Client (Manager)+import RIO+import qualified RIO.ByteString as B+import qualified RIO.ByteString.Lazy as BL+import RIO.List (intersperse)+import RIO.List.Partial (maximum)+import qualified RIO.Set as S+import qualified RIO.Text as T+import RIO.Text.Partial (splitOn)+import Text.Printf (printf) --- -- | The result of @-Au@.-upgradeAURPkgs :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) => S.Set PkgName -> m ()+upgradeAURPkgs :: Set PkgName -> RIO Env () upgradeAURPkgs pkgs = do ss <- asks settings- sendM . notify ss . upgradeAURPkgs_1 $ langOf ss- sendM (foreigns ss) >>= traverse_ (upgrade pkgs) . NES.nonEmptySet+ liftIO . notify ss . upgradeAURPkgs_1 $ langOf ss+ liftIO (foreigns ss) >>= traverse_ (upgrade pkgs) . NES.nonEmptySet -- | Foreign packages to consider for upgrading, after "ignored packages" have -- been taken into consideration.-foreigns :: Settings -> IO (S.Set SimplePkg)+foreigns :: Settings -> IO (Set SimplePkg) foreigns ss = S.filter (notIgnored . view (field @"name")) <$> foreignPackages where notIgnored p = not . S.member p $ ignoresOf ss -upgrade :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- S.Set PkgName -> NESet SimplePkg -> m ()+upgrade :: Set PkgName -> NESet SimplePkg -> RIO Env () upgrade pkgs fs = do ss <- asks settings toUpgrade <- possibleUpdates fs@@ -85,15 +83,14 @@ Just a -> auraUpgrade a Nothing -> do devel <- develPkgCheck- sendM . notify ss . upgradeAURPkgs_2 $ langOf ss- if | null toUpgrade && null devel -> sendM . warn ss . upgradeAURPkgs_3 $ langOf ss+ liftIO . notify ss . upgradeAURPkgs_2 $ langOf ss+ if | null toUpgrade && null devel -> liftIO . warn ss . upgradeAURPkgs_3 $ langOf ss | otherwise -> do reportPkgsToUpgrade toUpgrade (toList devel)- sendM . unless (switch ss DryRun) $ saveState ss+ liftIO . unless (switch ss DryRun) $ saveState ss traverse_ I.install . NES.nonEmptySet $ S.fromList names <> pkgs <> devel -possibleUpdates :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet SimplePkg -> m [(AurInfo, Versioning)]+possibleUpdates :: NESet SimplePkg -> RIO Env [(AurInfo, Versioning)] possibleUpdates (NES.toList -> pkgs) = do aurInfos <- aurInfo $ fmap (^. field @"name") pkgs let !names = map aurNameOf aurInfos@@ -101,30 +98,30 @@ pure . filter isntMostRecent . zip aurInfos $ aurPkgs ^.. each . field @"version" -- | Is there an update for Aura that we could apply first?-auraCheck :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => [PkgName] -> m (Maybe PkgName)+auraCheck :: [PkgName] -> RIO Env (Maybe PkgName) auraCheck ps = join <$> traverse f auraPkg where f a = do ss <- asks settings- bool Nothing (Just a) <$> sendM (optionalPrompt ss auraCheck_1)+ bool Nothing (Just a) <$> liftIO (optionalPrompt ss auraCheck_1) auraPkg | "aura" `elem` ps = Just "aura" | "aura-bin" `elem` ps = Just "aura-bin" | otherwise = Nothing -auraUpgrade :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) => PkgName -> m ()+auraUpgrade :: PkgName -> RIO Env () auraUpgrade = I.install . NES.singleton -develPkgCheck :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => m (S.Set PkgName)+develPkgCheck :: RIO Env (Set PkgName) develPkgCheck = asks settings >>= \ss ->- if switch ss RebuildDevel then sendM develPkgs else pure S.empty+ if switch ss RebuildDevel then liftIO develPkgs else pure S.empty -- | The result of @-Ai@.-aurPkgInfo :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) => NESet PkgName -> m ()+aurPkgInfo :: NESet PkgName -> RIO Env () aurPkgInfo = aurInfo . NES.toList >=> traverse_ displayAurPkgInfo -displayAurPkgInfo :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => AurInfo -> m ()-displayAurPkgInfo ai = asks settings >>= \ss -> sendM . T.putStrLn $ renderAurPkgInfo ss ai <> "\n"+displayAurPkgInfo :: AurInfo -> RIO Env ()+displayAurPkgInfo ai = asks settings >>= \ss -> liftIO . putTextLn $ renderAurPkgInfo ss ai <> "\n" -renderAurPkgInfo :: Settings -> AurInfo -> T.Text+renderAurPkgInfo :: Settings -> AurInfo -> Text renderAurPkgInfo ss ai = dtot . colourCheck ss $ entrify ss fields entries where fields = infoFields . langOf $ ss entries = [ magenta "aur"@@ -142,27 +139,26 @@ , maybe "(null)" pretty $ aurDescriptionOf ai ] -- | The result of @-As@.-aurPkgSearch :: (Monad m, Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- T.Text -> m ()+aurPkgSearch :: Text -> RIO Env () aurPkgSearch regex = do ss <- asks settings- db <- S.map (^. field @"name" . field @"name") <$> sendM foreignPackages+ db <- S.map (^. field @"name" . field @"name") <$> liftIO foreignPackages let t = case truncationOf $ buildConfigOf ss of -- Can't this go anywhere else? None -> id Head n -> take $ fromIntegral n Tail n -> reverse . take (fromIntegral n) . reverse results <- fmap (\x -> (x, aurNameOf x `S.member` db)) . t <$> aurSearch regex- sendM $ traverse_ (T.putStrLn . renderSearch ss regex) results+ liftIO $ traverse_ (putTextLn . renderSearch ss regex) results -renderSearch :: Settings -> T.Text -> (AurInfo, Bool) -> T.Text+renderSearch :: Settings -> Text -> (AurInfo, Bool) -> Text renderSearch ss r (i, e) = searchResult where searchResult = if switch ss LowVerbosity then sparseInfo else dtot $ colourCheck ss verboseInfo sparseInfo = aurNameOf i verboseInfo = repo <> n <+> v <+> "(" <> l <+> "|" <+> p <> ")" <> (if e then annotate bold " [installed]" else "") <> "\n " <> d repo = magenta "aur/"- n = fold . intersperse (bCyan $ pretty r) . map (annotate bold . pretty) . T.splitOn r $ aurNameOf i+ n = fold . intersperse (bCyan $ pretty r) . map (annotate bold . pretty) . splitOn r $ aurNameOf i d = maybe "(null)" pretty $ aurDescriptionOf i l = yellow . pretty $ aurVotesOf i -- `l` for likes? p = yellow . pretty . T.pack . printf "%0.2f" $ popularityOf i@@ -171,40 +167,39 @@ Nothing -> green . pretty $ aurVersionOf i -- | The result of @-Ap@.-displayPkgbuild :: (Monad m, Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) =>- NESet PkgName -> m ()+displayPkgbuild :: NESet PkgName -> RIO Env () displayPkgbuild ps = do man <- asks (managerOf . settings)- pbs <- catMaybes <$> traverse (sendM . getPkgbuild @IO man) (toList ps)- sendM . traverse_ (T.putStrLn . strictText) $ pbs ^.. each . field @"pkgbuild"+ pbs <- catMaybes <$> traverse (liftIO . getPkgbuild man) (toList ps)+ liftIO . traverse_ (\p -> B.putStr @IO p >> B.putStr "\n") $ pbs ^.. each . field @"pkgbuild" isntMostRecent :: (AurInfo, Versioning) -> Bool isntMostRecent (ai, v) = trueVer > Just v where trueVer = hush . versioning $ aurVersionOf ai -- | Similar to @-Ai@, but yields the raw data as JSON instead.-aurJson :: (Carrier sig m , Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet PkgName -> m ()+aurJson :: NESet PkgName -> RIO Env () aurJson ps = do m <- asks (managerOf . settings)- infos <- liftMaybeM (Failure connectionFailure_1) . fmap hush . sendM . info m . (^.. each . field @"name") $ toList ps- let json = map (toStrict . toLazyText . encodePrettyToTextBuilder) infos- sendM $ traverse_ T.putStrLn json+ infos <- liftMaybeM (Failure connectionFailure_1) . fmap hush . liftIO $ f m ps+ liftIO $ traverse_ (BL.putStrLn @IO . encodePretty) infos+ where+ f :: Manager -> NESet PkgName -> IO (Either ClientError [AurInfo])+ f m = info m . (^.. each . field @"name") . toList ------------ -- REPORTING -------------reportPkgsToUpgrade :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) =>- [(AurInfo, Versioning)] -> [PkgName] -> m ()+reportPkgsToUpgrade :: [(AurInfo, Versioning)] -> [PkgName] -> RIO Env () reportPkgsToUpgrade ups pns = do ss <- asks settings- sendM . notify ss . reportPkgsToUpgrade_1 $ langOf ss- sendM $ putDoc (colourCheck ss . vcat $ map f ups' <> map g devels) >> T.putStrLn "\n"+ liftIO . notify ss . reportPkgsToUpgrade_1 $ langOf ss+ liftIO $ putDoc (colourCheck ss . vcat $ map f ups' <> map g devels) >> putTextLn "\n" where devels = pns ^.. each . field @"name" ups' = map (second prettyV) ups nLen = maximum $ map (T.length . aurNameOf . fst) ups <> map T.length devels vLen = maximum $ map (T.length . snd) ups'- g = annotate (color Cyan) . pretty+ g = annotate (color Cyan) . pretty f (p, v) = hsep [ cyan . fill nLen . pretty $ aurNameOf p , "::" , yellow . fill vLen $ pretty v
lib/Aura/Commands/B.hs view
@@ -23,9 +23,11 @@ import Aura.Languages import Aura.Settings import Aura.State-import Aura.Utils (optionalPrompt)-import BasePrelude-import qualified Data.Text as T+import Aura.Utils (optionalPrompt, putTextLn)+import qualified Data.List.NonEmpty as NEL+import RIO+import RIO.List (partition)+import qualified RIO.Text as T import System.Path (takeFileName, toFilePath, toUnrootedFilePath) import System.Path.IO (removeFile) @@ -38,12 +40,16 @@ (pinned, others) <- partition p <$> traverse (\sf -> (sf,) <$> readState sf) stfs warn ss . cleanStates_4 (length stfs) $ langOf ss unless (null pinned) . warn ss . cleanStates_6 (length pinned) $ langOf ss- unless (null stfs) . warn ss . cleanStates_5 (T.pack . toUnrootedFilePath . takeFileName $ head stfs) $ langOf ss+ forM_ (NEL.nonEmpty stfs) $ \stfs' -> do+ let mostRecent = T.pack . toUnrootedFilePath . takeFileName $ NEL.head stfs'+ warn ss . cleanStates_5 mostRecent $ langOf ss okay <- optionalPrompt ss $ cleanStates_2 n if | not okay -> warn ss . cleanStates_3 $ langOf ss | otherwise -> traverse_ (removeFile . fst) . drop n $ others- where p = maybe False pinnedOf . snd+ where+ p :: (a, Maybe PkgState) -> Bool+ p = maybe False pinnedOf . snd -- | The result of @-Bl@. listStates :: IO ()-listStates = getStateFiles >>= traverse_ (putStrLn . toFilePath)+listStates = getStateFiles >>= traverse_ (putTextLn . T.pack . toFilePath)
lib/Aura/Commands/C.hs view
@@ -31,19 +31,16 @@ import Aura.State import Aura.Types import Aura.Utils-import BasePrelude-import Control.Effect (Carrier, Member)-import Control.Effect.Error (Error, throwError)-import Control.Effect.Lift (Lift, sendM)-import Control.Effect.Reader (Reader, asks) import Data.Generics.Product (field) import Data.List.NonEmpty (nonEmpty)-import qualified Data.Map.Strict as M-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 Lens.Micro ((^?), _Just)+import RIO+import RIO.List (groupBy, sort, (\\))+import qualified RIO.Map as M+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Path import System.Path.IO (copyFile, doesDirectoryExist, removeFile) @@ -51,113 +48,109 @@ -- | Interactive. Gives the user a choice as to exactly what versions -- they want to downgrade to.-downgradePackages :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet PkgName -> m ()+downgradePackages :: NESet PkgName -> RIO Env () downgradePackages pkgs = do ss <- asks settings let cachePath = either id id . cachePathOf $ commonConfigOf ss- reals <- sendM $ pkgsInCache ss pkgs+ reals <- liftIO $ pkgsInCache ss pkgs traverse_ (report red reportBadDowngradePkgs_1) . nonEmpty . toList $ NES.toSet pkgs S.\\ reals unless (null reals) $ do- cache <- sendM $ cacheContents cachePath+ cache <- liftIO $ cacheContents cachePath choices <- traverse (getDowngradeChoice cache) $ toList reals- liftEitherM . sendM . pacman $ "-U" : asFlag (commonConfigOf ss) <> map (T.pack . toFilePath . path) choices+ liftIO . pacman $ "-U" : asFlag (commonConfigOf ss) <> map (T.pack . toFilePath . path) choices -- | For a given package, get a choice from the user about which version of it to -- downgrade to.-getDowngradeChoice :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- Cache -> PkgName -> m PackagePath+getDowngradeChoice :: Cache -> PkgName -> RIO Env PackagePath getDowngradeChoice cache pkg = case nonEmpty $ getChoicesFromCache cache pkg of- Nothing -> throwError . Failure $ reportBadDowngradePkgs_2 pkg+ Nothing -> throwM . Failure $ reportBadDowngradePkgs_2 pkg Just choices -> do ss <- asks settings- sendM . notify ss . getDowngradeChoice_1 pkg $ langOf ss- sendM $ getSelection (T.pack . toFilePath . path) choices+ liftIO . notify ss . getDowngradeChoice_1 pkg $ langOf ss+ liftIO $ getSelection (T.pack . toFilePath . path) choices getChoicesFromCache :: Cache -> PkgName -> [PackagePath] getChoicesFromCache (Cache cache) p = sort . M.elems $ M.filterWithKey (\(SimplePkg pn _) _ -> p == pn) cache --- | Print all package filenames that match a given `T.Text`.-searchCache :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => T.Text -> m ()+-- | Print all package filenames that match a given `Text`.+searchCache :: Text -> RIO Env () searchCache ps = do ss <- asks settings- matches <- sendM $ cacheMatches ss ps- sendM . traverse_ (putStrLn . toFilePath . path) $ sort matches+ matches <- liftIO $ cacheMatches ss ps+ liftIO . traverse_ (putTextLn . T.pack . toFilePath . path) $ sort matches -- | The destination folder must already exist for the back-up to begin.-backupCache :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- Path Absolute -> m ()+backupCache :: Path Absolute -> RIO Env () backupCache dir = do- exists <- sendM $ doesDirectoryExist dir- if | not exists -> throwError $ Failure backupCache_3+ exists <- liftIO $ doesDirectoryExist dir+ if | not exists -> throwM $ Failure backupCache_3 | otherwise -> confirmBackup dir >>= backup dir -confirmBackup :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- Path Absolute -> m Cache+confirmBackup :: Path Absolute -> RIO Env Cache confirmBackup dir = do ss <- asks settings- cache <- sendM . cacheContents . either id id . cachePathOf $ commonConfigOf ss- sendM . notify ss $ backupCache_4 (toFilePath dir) (langOf ss)- sendM . notify ss $ backupCache_5 (M.size $ _cache cache) (langOf ss)- okay <- sendM $ optionalPrompt ss backupCache_6- bool (throwError $ Failure backupCache_7) (pure cache) okay+ cache <- liftIO . cacheContents . either id id . cachePathOf $ commonConfigOf ss+ liftIO . notify ss $ backupCache_4 (toFilePath dir) (langOf ss)+ liftIO . notify ss $ backupCache_5 (M.size $ _cache cache) (langOf ss)+ okay <- liftIO $ optionalPrompt ss backupCache_6+ bool (throwM $ Failure backupCache_7) (pure cache) okay -backup :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) =>- Path Absolute -> Cache -> m ()+backup :: Path Absolute -> Cache -> RIO Env () backup dir (Cache cache) = do ss <- asks settings- sendM . notify ss . backupCache_8 $ langOf ss- sendM $ putStrLn "" -- So that the cursor can rise at first.+ liftIO . notify ss . backupCache_8 $ langOf ss+ liftIO $ putTextLn "" -- So that the cursor can rise at first. copyAndNotify dir (M.elems cache) 1 -- | Manages the file copying and display of the real-time progress notifier.-copyAndNotify :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) =>- Path Absolute -> [PackagePath] -> Int -> m ()+copyAndNotify :: Path Absolute -> [PackagePath] -> Int -> RIO Env () copyAndNotify _ [] _ = pure () copyAndNotify dir (PackagePath p : ps) n = do ss <- asks settings- sendM $ raiseCursorBy 1- sendM . warn ss . copyAndNotify_1 n $ langOf ss- sendM $ copyFile p dir+ liftIO $ raiseCursorBy 1+ liftIO . warn ss . copyAndNotify_1 n $ langOf ss+ liftIO $ copyFile p dir copyAndNotify dir ps $ n + 1 -- | Keeps a certain number of package files in the cache according to -- a number provided by the user. The rest are deleted.-cleanCache :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- Word -> m ()+cleanCache :: Word -> RIO Env () cleanCache toSave- | toSave == 0 = asks settings >>= \ss -> sendM (warn ss . cleanCache_2 $ langOf ss) >> (liftEitherM . sendM . pacman $ ["-Scc"])- | otherwise = do+ | toSave == 0 = do ss <- asks settings- sendM . warn ss . cleanCache_3 toSave $ langOf ss- okay <- sendM $ optionalPrompt ss cleanCache_4- bool (throwError $ Failure cleanCache_5) (clean (fromIntegral toSave)) okay+ liftIO . warn ss . cleanCache_2 $ langOf ss+ liftIO $ pacman ["-Scc"]+ | otherwise = do+ ss <- asks settings+ liftIO . warn ss . cleanCache_3 toSave $ langOf ss+ okay <- liftIO $ optionalPrompt ss cleanCache_4+ bool (throwM $ Failure cleanCache_5) (clean (fromIntegral toSave)) okay -clean :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => Int -> m ()+clean :: Int -> RIO Env () clean toSave = do ss <- asks settings- sendM . notify ss . cleanCache_6 $ langOf ss+ liftIO . notify ss . cleanCache_6 $ langOf ss let cachePath = either id id . cachePathOf $ commonConfigOf ss- (Cache cache) <- sendM $ cacheContents cachePath+ (Cache cache) <- liftIO $ cacheContents cachePath let !files = M.elems cache grouped = take toSave . reverse <$> groupByName files toRemove = files \\ fold grouped- sendM $ traverse_ removeFile $ map path toRemove+ liftIO $ traverse_ (removeFile . path) toRemove -- | Only package files with a version not in any PkgState will be -- removed.-cleanNotSaved :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => m ()+cleanNotSaved :: RIO Env () cleanNotSaved = do ss <- asks settings- sendM . notify ss . cleanNotSaved_1 $ langOf ss- sfs <- sendM getStateFiles- states <- fmap catMaybes . sendM $ traverse readState sfs+ liftIO . notify ss . cleanNotSaved_1 $ langOf ss+ sfs <- liftIO getStateFiles+ states <- fmap catMaybes . liftIO $ traverse readState sfs let cachePath = either id id . cachePathOf $ commonConfigOf ss- (Cache cache) <- sendM $ cacheContents cachePath+ (Cache cache) <- liftIO $ cacheContents cachePath let duds = M.filterWithKey (\p _ -> any (inState p) states) cache- prop <- sendM . optionalPrompt ss $ cleanNotSaved_2 $ M.size duds- when prop . sendM . traverse_ removeFile . map path $ M.elems duds+ prop <- liftIO . optionalPrompt ss $ cleanNotSaved_2 $ M.size duds+ when prop . liftIO . traverse_ (removeFile . path) $ M.elems duds -- | Typically takes the contents of the package cache as an argument. groupByName :: [PackagePath] -> [[PackagePath]]
lib/Aura/Commands/L.hs view
@@ -25,57 +25,50 @@ import Aura.Settings import Aura.Types (PkgName(..)) import Aura.Utils-import BasePrelude hiding (FilePath) import Control.Compactable (fmapEither)-import Control.Effect (Carrier, Member)-import Control.Effect.Lift (Lift, sendM)-import Control.Effect.Reader (Reader, asks)-import qualified Data.ByteString.Char8 as BS import Data.Generics.Product (field) import qualified Data.List.NonEmpty as NEL import Data.Set.NonEmpty (NESet)-import qualified Data.Text as T-import Data.Text.Encoding as T-import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Text.IO as T import Data.Text.Prettyprint.Doc-import Lens.Micro ((^.))+import RIO hiding (FilePath)+import qualified RIO.Text as T+import qualified RIO.Text.Partial as T import System.Path (toFilePath) import System.Process.Typed (proc, runProcess) --- -- | The contents of the Pacman log file.-newtype Log = Log [T.Text]+newtype Log = Log [Text] data LogEntry = LogEntry { name :: PkgName- , firstInstall :: T.Text+ , firstInstall :: Text , upgrades :: Word- , recent :: [T.Text] }+ , recent :: [Text] } -- | Pipes the pacman log file through a @less@ session.-viewLogFile :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => m ()+viewLogFile :: RIO Env () viewLogFile = do pth <- asks (toFilePath . either id id . logPathOf . commonConfigOf . settings)- sendM . void . runProcess @IO $ proc "less" [pth]+ liftIO . void . runProcess @IO $ proc "less" [pth] --- | Print all lines in the log file which contain a given `T.Text`.-searchLogFile :: Settings -> T.Text -> IO ()+-- | Print all lines in the log file which contain a given `Text`.+searchLogFile :: Settings -> Text -> IO () searchLogFile ss input = do let pth = toFilePath . either id id . logPathOf $ commonConfigOf ss- logFile <- map (T.decodeUtf8With lenientDecode) . BS.lines <$> BS.readFile pth- traverse_ T.putStrLn $ searchLines input logFile+ logFile <- T.lines . decodeUtf8Lenient <$> readFileBinary pth+ traverse_ putTextLn $ searchLines input logFile -- | The result of @-Li@.-logInfoOnPkg :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => NESet PkgName -> m ()+logInfoOnPkg :: NESet PkgName -> RIO Env () logInfoOnPkg pkgs = do ss <- asks settings let pth = toFilePath . either id id . logPathOf $ commonConfigOf ss- logFile <- Log . map (T.decodeUtf8With lenientDecode) . BS.lines <$> sendM (BS.readFile pth)+ logFile <- Log . T.lines . decodeUtf8Lenient <$> liftIO (readFileBinary @IO pth) let (bads, goods) = fmapEither (logLookup logFile) $ toList pkgs traverse_ (report red reportNotInLog_1) $ NEL.nonEmpty bads- sendM . traverse_ T.putStrLn $ map (renderEntry ss) goods+ liftIO . traverse_ putTextLn $ map (renderEntry ss) goods logLookup :: Log -> PkgName -> Either PkgName LogEntry logLookup (Log lns) p = case matches of@@ -87,7 +80,7 @@ , recent = reverse . take 5 $ reverse t } where matches = filter (T.isInfixOf (" " <> (p ^. field @"name") <> " (")) lns -renderEntry :: Settings -> LogEntry -> T.Text+renderEntry :: Settings -> LogEntry -> Text renderEntry ss (LogEntry (PkgName pn) fi us rs) = dtot . colourCheck ss $ entrify ss fields entries <> hardline <> recents <> hardline where fields = logLookUpFields $ langOf ss
lib/Aura/Commands/O.hs view
@@ -14,25 +14,20 @@ module Aura.Commands.O ( displayOrphans, adoptPkg ) where -import Aura.Core (Env(..), liftEitherM, orphans, sudo)-import Aura.Pacman (pacman)-import Aura.Types-import BasePrelude-import Control.Effect (Carrier, Member)-import Control.Effect.Error (Error)-import Control.Effect.Lift (Lift, sendM)-import Control.Effect.Reader (Reader)-import Data.Generics.Product (field)-import Data.Set.NonEmpty (NESet)-import qualified Data.Text.IO as T-import Lens.Micro.Extras (view)+import Aura.Core (Env(..), orphans, sudo)+import Aura.Pacman (pacman)+import Aura.Types+import Aura.Utils (putTextLn)+import Data.Generics.Product (field)+import Data.Set.NonEmpty (NESet)+import RIO --- -- | Print the result of @pacman -Qqdt@ displayOrphans :: IO ()-displayOrphans = orphans >>= traverse_ (T.putStrLn . view (field @"name"))+displayOrphans = orphans >>= traverse_ (putTextLn . view (field @"name")) -- | Identical to @-D --asexplicit@.-adoptPkg :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) => NESet PkgName -> m ()-adoptPkg pkgs = sudo . liftEitherM . sendM . pacman $ ["-D", "--asexplicit"] <> asFlag pkgs+adoptPkg :: NESet PkgName -> RIO Env ()+adoptPkg pkgs = sudo . liftIO . pacman $ ["-D", "--asexplicit"] <> asFlag pkgs
lib/Aura/Core.hs view
@@ -18,8 +18,7 @@ ( -- * Types Env(..) , Repository(..)- , liftEither, liftEitherM- , liftMaybe, liftMaybeM+ , liftMaybeM -- * User Privileges , sudo, trueRoot -- * Querying the Package Database@@ -40,29 +39,23 @@ 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.Bifunctor (bimap) import Data.Generics.Product (field)+import Data.List.NonEmpty (NonEmpty) 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 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) ---@@ -114,43 +107,28 @@ ----------- -- THE WORK -------------- | Lift a common return type into the `fused-effects` world. Usually used--- after a `pacman` call.-liftEither :: (Carrier sig m, Member (Error a) sig) => Either a b -> m b-liftEither = either throwError pure---- | Like `liftEither`, but the `Either` can be embedded in something else,--- usually a `Monad`.-liftEitherM :: (Carrier sig m, Member (Error a) sig) => m (Either a b) -> m b-liftEitherM m = m >>= liftEither---- | Like `liftEither`, but for `Maybe`.-liftMaybe :: (Carrier sig m, Member (Error a) sig) => a -> Maybe b -> m b-liftMaybe a = maybe (throwError a) pure---- | Like `liftEitherM`, but for `Maybe`.-liftMaybeM :: (Carrier sig m, Member (Error a) sig) => a -> m (Maybe b) -> m b-liftMaybeM a m = m >>= liftMaybe a+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 :: (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+sudo :: RIO Env a -> RIO Env a+sudo act = asks (hasRootPriv . envOf . settings) >>= bool (throwM $ Failure mustBeRoot_1) act -- | Stop the user if they are the true root. Building as root isn't allowed -- since makepkg v4.2.-trueRoot :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig) => m a -> m a+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 throwError $ Failure trueRoot_3+ then action else throwM $ Failure trueRoot_3 -- | A list of non-prebuilt packages installed on the system. -- `-Qm` yields a list of sorted values. foreignPackages :: IO (Set SimplePkg)-foreignPackages = S.fromList . mapMaybe (simplepkg' . strictText) . BL.lines <$> pacmanOutput ["-Qm"]+foreignPackages = S.fromList . mapMaybe simplepkg' <$> pacmanLines ["-Qm"] -- | Packages marked as a dependency, yet are required by no other package. orphans :: IO (Set PkgName)-orphans = S.fromList . map (PkgName . strictText) . BL.lines <$> pacmanOutput ["-Qqdt"]+orphans = S.fromList . map PkgName <$> pacmanLines ["-Qqdt"] -- | Any package whose name is suffixed by git, hg, svn, darcs, cvs, or bzr. develPkgs :: IO (Set PkgName)@@ -164,11 +142,10 @@ isInstalled pkg = bool Nothing (Just pkg) <$> pacmanSuccess ["-Qq", pkg ^. field @"name"] -- | An @-Rsu@ call.-removePkgs :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet PkgName -> m ()+removePkgs :: NESet PkgName -> RIO Env () removePkgs pkgs = do pacOpts <- asks (commonConfigOf . settings)- liftEitherM . sendM . pacman $ ["-Rsu"] <> asFlag pkgs <> asFlag pacOpts+ liftIO . pacman $ ["-Rsu"] <> asFlag pkgs <> asFlag pacOpts -- | Depedencies which are not installed, or otherwise provided by some -- installed package.@@ -182,16 +159,16 @@ 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+ pure . bimap Unsatisfied Satisfied $ NES.partition (`S.member` unsats) ds where- unsat :: IO [T.Text]+ unsat :: IO [Text] unsat = pacmanLines $ "-T" : map renderedDep (toList ds) -- | Block further action until the database is free. checkDBLock :: Settings -> IO () checkDBLock ss = do locked <- doesFileExist lockFile- when locked $ (warn ss . checkDBLock_1 $ langOf ss) *> getLine *> checkDBLock ss+ when locked $ (warn ss . checkDBLock_1 $ langOf ss) *> B.getLine *> checkDBLock ss ------- -- MISC -- Too specific for `Utilities.hs` or `Aura.Utils`@@ -211,9 +188,8 @@ -- | Report a message with multiple associated items. Usually a list of -- naughty packages.-report :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) =>- (Doc AnsiStyle -> Doc AnsiStyle) -> (Language -> Doc AnsiStyle) -> NonEmpty PkgName -> m ()+report :: (Doc AnsiStyle -> Doc AnsiStyle) -> (Language -> Doc AnsiStyle) -> NonEmpty PkgName -> RIO Env () 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+ liftIO . putStrLnA ss . c . msg $ langOf ss+ liftIO . putTextLn . dtot . colourCheck ss . vsep . map (cyan . pretty . view (field @"name")) $ toList pkgs
lib/Aura/Dependencies.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} -- | -- Module : Aura.Dependencies@@ -27,27 +28,21 @@ import Aura.Languages import Aura.Settings import Aura.Types-import Aura.Utils (maybe')-import BasePrelude-import Control.Effect (Carrier, Member)-import Control.Effect.Error (Error, throwError)-import Control.Effect.Lift (Lift, sendM)-import Control.Effect.Reader (Reader, asks)+import Aura.Utils (maybe', putText) import Control.Error.Util (note) import Data.Generics.Product (field)+import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NEL-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M import Data.Semigroup.Foldable (foldMap1)-import Data.Set (Set)-import qualified Data.Set as S import Data.Set.NonEmpty (pattern IsEmpty, pattern IsNonEmpty, NESet) import qualified Data.Set.NonEmpty as NES-import qualified Data.Text as T import Data.These (these) import Data.Versions import Lens.Micro-import UnliftIO.Exception (catchAny, throwString)+import RIO+import qualified RIO.Map as M+import qualified RIO.Set as S+import qualified RIO.Text as T --- @@ -62,16 +57,15 @@ -- interdependent, and thus can be built and installed as a group. -- -- Deeper layers of the result list (generally) depend on the previous layers.-resolveDeps :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- Repository -> NESet Package -> m (NonEmpty (NESet Package))+resolveDeps :: Repository -> NESet Package -> RIO Env (NonEmpty (NESet Package)) resolveDeps repo ps = do ss <- asks settings- Resolution m s <- liftMaybeM (Failure connectionFailure_1) . sendM $- (Just <$> resolveDeps' ss repo ps) `catchAny` (const $ pure Nothing)- unless (length ps == length m) $ sendM (putStr "\n")+ res <- liftIO $ (Just <$> resolveDeps' ss repo ps) `catchAny` const (pure Nothing)+ Resolution m s <- maybe (throwM $ Failure connectionFailure_1) pure res+ unless (length ps == length m) $ liftIO (putText "\n") let de = conflicts ss m s- unless (null de) . throwError . Failure $ missingPkg_2 de- either throwError pure $ sortInstall m+ unless (null de) . throwM . Failure $ missingPkg_2 de+ either throwM pure $ sortInstall m -- | Solve dependencies for a set of `Package`s assumed to not be -- installed/satisfied.@@ -125,7 +119,7 @@ conflicts ss m s = foldMap f m where pm :: Map PkgName Package- pm = M.fromList $ foldr (\p acc -> (pprov p ^. field @"provides", p) : acc) [] m+ pm = M.fromList $ map (\p -> (pprov p ^. field @"provides", p)) $ toList m f :: Package -> [DepError] f (FromRepo _) = []
lib/Aura/Diff.hs view
@@ -9,7 +9,7 @@ module Aura.Diff ( diff ) where import Aura.Settings-import BasePrelude hiding (diff)+import RIO import System.Path (Absolute, Path, toFilePath) import System.Process.Typed (proc, runProcess)
lib/Aura/Install.hs view
@@ -35,105 +35,97 @@ import Aura.Pkgbuild.Security import Aura.Settings import Aura.Types-import Aura.Utils (optionalPrompt)-import BasePrelude hiding (FilePath, diff)+import Aura.Utils (optionalPrompt, putTextLn) 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.Scheduler (Comp(..), traverseConcurrently)-import qualified Data.ByteString.Lazy.Char8 as BL import Data.Generics.Product (HasField'(..), field, super)+import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NEL-import qualified Data.Map.Strict as M import Data.Semigroup.Foldable (fold1)-import qualified Data.Set as S import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NES-import qualified Data.Text.IO as T import Language.Bash.Pretty (prettyText) import Language.Bash.Syntax (ShellCommand)-import Lens.Micro (each, (^.), (^..))-import Lens.Micro.Extras (view)-import System.Directory (setCurrentDirectory)-import System.IO (hFlush, stdout)+import Lens.Micro (each, (^..))+import RIO hiding (FilePath)+import RIO.Directory (setCurrentDirectory)+import RIO.List (partition, sort)+import qualified RIO.Map as M+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Path (fromAbsoluteFilePath) --- -- | High level 'install' command. Handles installing -- dependencies.-install :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet PkgName -> m ()+install :: NESet PkgName -> RIO Env () install pkgs = do ss <- asks settings if | not $ switch ss DeleteMakeDeps -> install' pkgs | otherwise -> do -- `-a` was used.- orphansBefore <- sendM orphans+ orphansBefore <- liftIO orphans install' pkgs- orphansAfter <- sendM orphans+ orphansAfter <- liftIO orphans let makeDeps = NES.nonEmptySet (orphansAfter S.\\ orphansBefore)- traverse_ (\mds -> sendM (notify ss . removeMakeDepsAfter_1 $ langOf ss) *> removePkgs mds) makeDeps+ traverse_ (\mds -> liftIO (notify ss . removeMakeDepsAfter_1 $ langOf ss) *> removePkgs mds) makeDeps -install' :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet PkgName -> m ()+install' :: NESet PkgName -> RIO Env () install' pkgs = do rpstry <- asks repository ss <- asks settings unneeded <- bool (pure S.empty)- (S.fromList . catMaybes <$> sendM (traverseConcurrently Par' isInstalled $ toList pkgs))+ (S.fromList . catMaybes <$> liftIO (traverseConcurrently Par' isInstalled $ toList pkgs)) $ shared ss NeededOnly let !pkgs' = NES.toSet pkgs- if | shared ss NeededOnly && unneeded == pkgs' -> sendM . warn ss . install_2 $ langOf ss+ if | shared ss NeededOnly && unneeded == pkgs' -> liftIO . warn ss . install_2 $ langOf ss | otherwise -> do let (ignored, notIgnored) = S.partition (`S.member` ignoresOf ss) pkgs' installAnyway <- confirmIgnored ignored case NES.nonEmptySet $ (notIgnored <> installAnyway) S.\\ unneeded of- Nothing -> sendM . warn ss . install_2 $ langOf ss+ Nothing -> liftIO . warn ss . install_2 $ langOf ss Just toInstall -> do traverse_ (report yellow reportUnneededPackages_1) . NEL.nonEmpty $ toList unneeded- (nons, toBuild) <- liftMaybeM (Failure connectionFailure_1) . sendM $ aurLookup (managerOf ss) toInstall+ (nons, toBuild) <- liftMaybeM (Failure connectionFailure_1) . liftIO $ aurLookup (managerOf ss) toInstall pkgbuildDiffs toBuild traverse_ (report red reportNonPackages_1) . NEL.nonEmpty $ toList nons case NES.nonEmptySet $ S.map (\b -> b { isExplicit = True }) toBuild of- Nothing -> throwError $ Failure install_2+ Nothing -> throwM $ Failure install_2 Just toBuild' -> do- sendM $ notify ss (install_5 $ langOf ss) *> hFlush stdout+ liftIO $ notify ss (install_5 $ langOf ss) *> hFlush stdout allPkgs <- 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) $ do- continue <- sendM $ optionalPrompt ss install_3- if | not continue -> throwError $ Failure install_4+ continue <- liftIO $ optionalPrompt ss install_3+ if | not continue -> throwM $ Failure install_4 | otherwise -> do traverse_ repoInstall $ NEL.nonEmpty repoPkgs let !mbuildPkgs = NEL.nonEmpty buildPkgs- traverse_ (sendM . storePkgbuilds . fold1) mbuildPkgs+ traverse_ (liftIO . storePkgbuilds . fold1) mbuildPkgs traverse_ buildAndInstall mbuildPkgs -- | Determine if a package's PKGBUILD might contain malicious bash code.-analysePkgbuild :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- Buildable -> m ()+analysePkgbuild :: Buildable -> RIO Env () analysePkgbuild b = do ss <- asks settings let f = do- yes <- sendM $ optionalPrompt ss security_6- when yes . throwError $ Failure security_7+ yes <- liftIO $ optionalPrompt ss security_6+ when yes . throwM $ Failure security_7 case parsedPB $ b ^. field @"pkgbuild" of- Nothing -> sendM (warn ss (security_1 (b ^. field @"name") $ langOf ss)) *> f+ Nothing -> liftIO (warn ss (security_1 (b ^. field @"name") $ langOf ss)) *> f Just l -> case bannedTerms l of [] -> pure () bts -> do- sendM $ scold ss (security_5 (b ^. field @"name") $ langOf ss)- sendM $ traverse_ (displayBannedTerms ss) bts+ liftIO $ scold ss (security_5 (b ^. field @"name") $ langOf ss)+ liftIO $ traverse_ (displayBannedTerms ss) bts f displayBannedTerms :: Settings -> (ShellCommand, BannedTerm) -> IO () displayBannedTerms ss (stmt, b) = do- putStrLn $ "\n " <> prettyText stmt <> "\n"+ putTextLn . T.pack $ "\n " <> prettyText stmt <> "\n" warn ss $ reportExploit b lang where lang = langOf ss @@ -155,29 +147,25 @@ goods = S.fromList . (^.. each . field @"name") . M.elems . M.fromListWith f $ map (view (field @"base") &&& id) bs' bs' = foldMap toList bs -confirmIgnored :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) =>- S.Set PkgName -> m (S.Set PkgName)+confirmIgnored :: Set PkgName -> RIO Env (Set PkgName) confirmIgnored (toList -> ps) = do ss <- asks settings- S.fromList <$> filterM (sendM . optionalPrompt ss . confirmIgnored_1) ps+ S.fromList <$> filterM (liftIO . optionalPrompt ss . confirmIgnored_1) ps -depsToInstall :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- Repository -> NESet Buildable -> m (NonEmpty (NESet Package))+depsToInstall :: Repository -> NESet Buildable -> RIO Env (NonEmpty (NESet Package)) depsToInstall repo bs = do ss <- asks settings- traverse (sendM . packageBuildable ss) (NES.toList bs) >>= resolveDeps repo . NES.fromList+ traverse (liftIO . packageBuildable ss) (NES.toList bs) >>= resolveDeps repo . NES.fromList -repoInstall :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NonEmpty Prebuilt -> m ()+repoInstall :: NonEmpty Prebuilt -> RIO Env () repoInstall ps = do pacOpts <- asks (asFlag . commonConfigOf . settings)- liftEitherM . sendM . pacman $ ["-S", "--asdeps"] <> pacOpts <> asFlag (ps ^.. each . field @"name")+ liftIO . pacman $ ["-S", "--asdeps"] <> pacOpts <> asFlag (ps ^.. each . field @"name") -buildAndInstall :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NonEmpty (NESet Buildable) -> m ()+buildAndInstall :: NonEmpty (NESet Buildable) -> RIO Env () buildAndInstall bss = do pth <- asks (either id id . cachePathOf . commonConfigOf . settings)- cache <- sendM $ cacheContents pth+ cache <- liftIO $ cacheContents pth traverse_ (f cache) bss where f (Cache cache) bs = do ss <- asks settings@@ -187,52 +175,54 @@ _ -> Left b built <- traverse (buildPackages . NES.fromList) $ NEL.nonEmpty ps traverse_ installPkgFiles $ built <> (NES.fromList <$> NEL.nonEmpty cached)- sendM $ annotateDeps bs+ liftIO $ annotateDeps bs ------------ -- REPORTING ------------ -- | Display dependencies. The result of @-Ad@.-displayPkgDeps :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NESet PkgName -> m ()+displayPkgDeps :: NESet PkgName -> RIO Env () displayPkgDeps ps = do rpstry <- asks repository ss <- asks settings let f = depsToInstall rpstry >=> reportDeps (switch ss LowVerbosity) . partitionPkgs- (_, goods) <- liftMaybeM (Failure connectionFailure_1) . sendM $ aurLookup (managerOf ss) ps+ (_, goods) <- liftMaybeM (Failure connectionFailure_1) . liftIO $ aurLookup (managerOf ss) ps traverse_ f $ NES.nonEmptySet goods- where reportDeps True = sendM . uncurry reportListOfDeps+ where reportDeps True = liftIO . uncurry reportListOfDeps reportDeps False = uncurry reportPkgsToInstall -reportPkgsToInstall :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) =>- [Prebuilt] -> [NESet Buildable] -> m ()+reportPkgsToInstall :: [Prebuilt] -> [NESet Buildable] -> RIO Env () reportPkgsToInstall rps bps = do let (explicits, ds) = partition isExplicit $ foldMap toList bps f reportPkgsToInstall_1 rps f reportPkgsToInstall_3 ds f reportPkgsToInstall_2 explicits- where f m xs = traverse_ (report green m) . NEL.nonEmpty . sort $ xs ^.. each . field @"name"+ where+ f m xs = traverse_ (report green m) . NEL.nonEmpty . sort $ xs ^.. each . field @"name" reportListOfDeps :: [Prebuilt] -> [NESet Buildable] -> IO () reportListOfDeps rps bps = f rps *> f (foldMap toList bps) where f :: HasField' "name" s PkgName => [s] -> IO ()- f = traverse_ T.putStrLn . sort . (^.. each . field' @"name" . field' @"name")+ f = traverse_ putTextLn . sort . (^.. each . field' @"name" . field' @"name") -pkgbuildDiffs :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => S.Set Buildable -> m ()+pkgbuildDiffs :: Set Buildable -> RIO Env () pkgbuildDiffs ps = asks settings >>= check- where check ss | not $ switch ss DiffPkgbuilds = pure ()- | otherwise = traverse_ displayDiff ps- displayDiff :: (Carrier sig m, Member (Reader Env) sig, Member (Lift IO) sig) => Buildable -> m ()- displayDiff p = do- ss <- asks settings- let pn = p ^. field @"name"- lang = langOf ss- isStored <- sendM $ hasPkgbuildStored pn- if not isStored- then sendM . warn ss $ reportPkgbuildDiffs_1 pn lang- else sendM $ do- setCurrentDirectory "/tmp"- let new = "/tmp/new.pb"- BL.writeFile new $ p ^. field @"pkgbuild" . field @"pkgbuild"- liftIO . warn ss $ reportPkgbuildDiffs_3 pn lang- diff ss (pkgbuildPath pn) $ fromAbsoluteFilePath new+ 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 = p ^. field @"name"+ lang = langOf ss+ isStored <- liftIO $ hasPkgbuildStored pn+ if not isStored+ then liftIO . warn ss $ reportPkgbuildDiffs_1 pn lang+ else liftIO $ do+ setCurrentDirectory "/tmp"+ let new = "/tmp/new.pb"+ writeFileBinary @IO new $ p ^. field @"pkgbuild" . field @"pkgbuild"+ liftIO . warn ss $ reportPkgbuildDiffs_3 pn lang+ diff ss (pkgbuildPath pn) $ fromAbsoluteFilePath new
lib/Aura/Languages.hs view
@@ -38,18 +38,21 @@ import Aura.Colour import qualified Aura.Languages.Fields as Fields import Aura.Types-import BasePrelude hiding ((<+>)) import Data.Generics.Product (field)-import qualified Data.Map.Strict as Map (Map, fromList, mapWithKey, toList, (!))-import qualified Data.Text as T+import Data.List.NonEmpty (NonEmpty)+import Data.Ratio ((%)) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal-import Lens.Micro.Extras (view)+import RIO+import RIO.List (intersperse)+import qualified RIO.Map as M+import qualified RIO.Map.Partial as M+import qualified RIO.Text as T --- -translators :: Map.Map Language T.Text-translators = Map.fromList+translators :: Map Language Text+translators = M.fromList [ (Polish, "Chris Warrick") , (Croatian, "Denis Kasak / \"stranac\"") , (Swedish, "Fredrik Haikarainen / Daniel Beecham")@@ -68,8 +71,8 @@ ] -- These need updating! Or removing...-languageNames :: Language -> Map.Map Language T.Text-languageNames = Map.fromList . zip [ Japanese, Polish, Croatian, Swedish, German, Spanish, Portuguese, French, Russian, Italian, Serbian, Norwegian, Indonesia, Chinese, Esperanto ] . \case+languageNames :: Language -> Map Language T.Text+languageNames = M.fromList . zip [ Japanese, Polish, Croatian, Swedish, German, Spanish, Portuguese, French, Russian, Italian, Serbian, Norwegian, Indonesia, Chinese, Esperanto ] . \case Japanese -> [ "日本語", "ポーランド語", "クロアチア語", "スウェーデン語", "ドイツ語", "スペイン語", "ポルトガル語", "フランス語", "ロシア語", "イタリア語", "セルビア語", "ノルウェー語", "インドネシア語", "中国語", "エスペラント" ] Polish -> [ "Japanese", "polski", "chorwacki", "szwedzki", "niemiecki", "hiszpański", "portugalski", "francuski", "rosyjski", "", "", "", "Indonesian", "Chinese", "Esperanto" ] Croatian -> [ "Japanese", "poljski", "hrvatski", "švedski", "njemački", "španjolski", "portugalski", "francuski", "ruski", "talijanski", "srpski", "norveški", "Indonesian", "Chinese", "Esperanto" ]@@ -87,7 +90,7 @@ Esperanto -> [ "La japana", "La pola", "La kroata", "La sevda", "La germana", "La hispana", "La portugala", "La franca", "La rusa", "La itala", "La serba", "La norvega", "La indonezia", "La ĉina", "Esperanto" ] _ -> [ "Japanese", "Polish", "Croatian", "Swedish", "German", "Spanish", "Portuguese", "French", "Russian", "Italian", "Serbian", "Norwegian", "Indonesian", "Chinese", "Esperanto" ] -translatorMsgTitle :: Language -> T.Text+translatorMsgTitle :: Language -> Text translatorMsgTitle = \case Japanese -> "Auraの翻訳者：" Polish -> "Tłumacze Aury:"@@ -106,24 +109,24 @@ Esperanto -> "Tradukistoj de Aura:" _ -> "Aura Translators:" -translatorMsg :: Language -> [T.Text]+translatorMsg :: Language -> [Text] translatorMsg lang = title : names where title = translatorMsgTitle lang- names = fmap snd . Map.toList $- Map.mapWithKey (\l t -> formatLang (assocLang l t)) translators- assocLang lang' translator = (translator, langNames Map.! lang')+ names = fmap snd . M.toList $+ M.mapWithKey (\l t -> formatLang (assocLang l t)) translators+ assocLang lang' translator = (translator, langNames M.! lang') formatLang (translator, lang') = " (" <> lang' <> ") " <> translator langNames = languageNames lang -- Wrap a String in backticks-bt :: T.Text -> Doc AnsiStyle+bt :: Text -> Doc AnsiStyle bt cs = "`" <> pretty cs <> "`" whitespace :: Language -> Char whitespace Japanese = ' ' -- \12288 whitespace _ = ' ' -- \32 -langFromLocale :: T.Text -> Language+langFromLocale :: Text -> Language langFromLocale = T.take 2 >>> \case "ja" -> Japanese "pl" -> Polish@@ -300,7 +303,7 @@ -- Aura/Dependencies functions ------------------------------ -- NEEDS UPDATE TO MATCH NEW ENGLISH-getRealPkgConflicts_1 :: PkgName -> PkgName -> T.Text -> T.Text -> Language -> Doc AnsiStyle+getRealPkgConflicts_1 :: PkgName -> PkgName -> Text -> Text -> Language -> Doc AnsiStyle getRealPkgConflicts_1 (bt . view (field @"name") -> prnt) (bt . view (field @"name") -> p) (bt -> r) (bt -> d) = \case Japanese -> "パッケージ" <> p <> "はバージョン" <> d <> "を要するが" <> "一番最新のバージョンは" <> r <> "。" Polish -> "Zależność " <> p <> " powinna być w wersji " <> d <> ", ale najnowsza wersja to " <> r <> "."@@ -610,7 +613,7 @@ _ -> p <> " has no stored PKGBUILD yet." -- NEEDS TRANSLATION-reportPkgbuildDiffs_2 :: T.Text -> Language -> Doc AnsiStyle+reportPkgbuildDiffs_2 :: Text -> Language -> Doc AnsiStyle reportPkgbuildDiffs_2 (bt -> p) = \case Japanese -> p <> "のPKGBUILDは最新です。" Polish -> "PKGBUILD pakietu " <> p <> " jest aktualny."@@ -775,7 +778,7 @@ ---------------------------- -- NEEDS TRANSLATION cleanStates_2 :: Int -> Language -> Doc AnsiStyle-cleanStates_2 n@(bt . T.pack . show -> s) = \case+cleanStates_2 n@(bt . tshow -> s) = \case Japanese -> s <> "個のパッケージ状態記録だけが残される。その他削除？" Polish -> s <> " stan pakietów zostanie zachowany. Usunąć resztę?" Croatian -> s <> " stanja paketa će biti zadržano. Ukloniti ostatak?"@@ -821,13 +824,13 @@ Esperanto -> "Vi havas " <+> pretty n <+> " konservajn statojn de pakaĵoj." _ -> "You currently have" <+> pretty n <+> "saved package states." -cleanStates_5 :: T.Text -> Language -> Doc AnsiStyle+cleanStates_5 :: Text -> Language -> Doc AnsiStyle cleanStates_5 t = \case Japanese -> "一番最近に保存されたのは：" <> pretty t Spanish -> "Guardado recientemente:" <+> pretty t Russian -> "Последнее сохраненное:" <+> pretty t Esperanto -> "Lastaj konservaj:" <+> pretty t- _ -> "Mostly recently saved:" <+> pretty t+ _ -> "Most recently saved:" <+> pretty t cleanStates_6 :: Int -> Language -> Doc AnsiStyle cleanStates_6 n = \case@@ -903,7 +906,7 @@ _ -> "Backing up cache to " <> dir backupCache_5 :: Int -> Language -> Doc AnsiStyle-backupCache_5 (bt . T.pack . show -> n) = \case+backupCache_5 (bt . tshow -> n) = \case Japanese -> "パッケージのファイル数：" <> n Polish -> "Pliki będące częścią\xa0kopii zapasowej: " <> n Croatian -> "Datoteke koje su dio sigurnosne kopije: " <> n@@ -1017,7 +1020,7 @@ _ -> "This will delete the ENTIRE package cache." cleanCache_3 :: Word -> Language -> Doc AnsiStyle-cleanCache_3 n@(bt . T.pack . show -> s) = \case+cleanCache_3 n@(bt . tshow -> s) = \case Japanese -> "パッケージ・ファイルは" <> s <> "個保存されます。" Polish -> s <> " wersji każdego pakietu zostanie zachowane." Croatian -> s <> " zadnjih verzija svakog paketa će biti zadržano."@@ -1133,7 +1136,7 @@ ---------------------------- -- Aura/Commands/L functions -----------------------------logLookUpFields :: Language -> [T.Text]+logLookUpFields :: Language -> [Text] logLookUpFields = sequence [ Fields.package , Fields.firstInstall , Fields.upgrades@@ -1168,7 +1171,7 @@ Spanish -> "No se pudo contactar con el AUR. ¿Tienes conexión a internet?" _ -> "Failed to contact the AUR. Do you have an internet connection?" -infoFields :: Language -> [T.Text]+infoFields :: Language -> [Text] infoFields = sequence [ Fields.repository , Fields.name , Fields.version@@ -1221,7 +1224,7 @@ _ -> "Up to Date" -- NEEDS TRANSLATION-orphanedMsg :: Maybe T.Text -> Language -> Doc AnsiStyle+orphanedMsg :: Maybe Text -> Language -> Doc AnsiStyle orphanedMsg (Just m) = const (pretty m) orphanedMsg Nothing = red . \case Japanese -> "孤児です!"@@ -1408,17 +1411,17 @@ Spanish -> "El PKGBUILD de" <+> bt p <+> "era demasiado complejo de analizar - puede estar ofuscando código malicioso." _ -> "The PKGBUILD of" <+> bt p <+> "was too complex to parse - it may be obfuscating malicious code." -security_2 :: T.Text -> Language -> Doc AnsiStyle+security_2 :: Text -> Language -> Doc AnsiStyle security_2 (bt -> t) = \case Spanish -> t <+> "se puede usar para descargar scripts arbitrarios que este PKGBUILD no rastrea." _ -> t <+> "can be used to download arbitrary scripts that aren't tracked by this PKGBUILD." -security_3 :: T.Text -> Language -> Doc AnsiStyle+security_3 :: Text -> Language -> Doc AnsiStyle security_3 (bt -> t) = \case Spanish -> t <+> "se puede usar para ejecutar código arbitrario que este PKGBUILD no rastrea." _ -> t <+> "can be used to execute arbitrary code not tracked by this PKGBUILD." -security_4 :: T.Text -> Language -> Doc AnsiStyle+security_4 :: Text -> Language -> Doc AnsiStyle security_4 (bt -> t) = \case Spanish -> t <+> "indica que alguien puede estar intentando obtener acceso de root a su máquina." _ -> t <+> "indicates that someone may be trying to gain root access to your machine."@@ -1438,17 +1441,17 @@ Spanish -> "Se canceló el procesamiento posterior para evitar el código bash potencialmente malicioso." _ -> "Cancelled further processing to avoid potentially malicious bash code." -security_8 :: T.Text -> Language -> Doc AnsiStyle+security_8 :: Text -> Language -> Doc AnsiStyle security_8 (bt -> t) = \case Spanish -> t <+> "es un comando bash integrado en los campos de la matriz del PKGBUILD." _ -> t <+> "is a bash command inlined in your PKGBUILD array fields." -security_9 :: T.Text -> Language -> Doc AnsiStyle+security_9 :: Text -> Language -> Doc AnsiStyle security_9 (bt -> t) = \case Spanish -> t <+> "es algo extraño para tener en sus campos de matriz. ¿Es seguro?" _ -> t <+> "is a strange thing to have in your array fields. Is it safe?" -security_10 :: T.Text -> Language -> Doc AnsiStyle+security_10 :: Text -> Language -> Doc AnsiStyle security_10 (bt -> t) = \case Spanish -> t <+> "implica que alguien estaba tratando de ser astuto con las variables para ocultar comandos maliciosos." _ -> t <+> "implies that someone was trying to be clever with variables to hide malicious commands."
lib/Aura/Languages/Fields.hs view
@@ -13,12 +13,12 @@ module Aura.Languages.Fields where -import Aura.Types (Language(..))-import qualified Data.Text as T+import Aura.Types (Language(..))+import RIO (Text) --- -package :: Language -> T.Text+package :: Language -> Text package = \case Japanese -> "パッケージ" Polish -> "Pakiet"@@ -36,7 +36,7 @@ Esperanto -> "Pakaĵo" _ -> "Package" -firstInstall :: Language -> T.Text+firstInstall :: Language -> Text firstInstall = \case Japanese -> "初インストール" Polish -> "Pierwsza instalacja"@@ -54,7 +54,7 @@ Esperanto -> "Unua Instalo" _ -> "First Install" -upgrades :: Language -> T.Text+upgrades :: Language -> Text upgrades = \case Japanese -> "アップグレード回数" Polish -> "Aktualizacje"@@ -72,7 +72,7 @@ Esperanto -> "Noveldonoj" _ -> "Upgrades" -recentActions :: Language -> T.Text+recentActions :: Language -> Text recentActions = \case Japanese -> "近況" Polish -> "Ostatnie akcje"@@ -90,7 +90,7 @@ Esperanto -> "Ĵusaj Agoj" _ -> "Recent Actions" -repository :: Language -> T.Text+repository :: Language -> Text repository = \case Japanese -> "リポジトリ" Polish -> "Repozytorium"@@ -108,7 +108,7 @@ Esperanto -> "Deponejo" _ -> "Repository" -name :: Language -> T.Text+name :: Language -> Text name = \case Japanese -> "名前" Polish -> "Nazwa"@@ -126,7 +126,7 @@ Esperanto -> "Nomo" _ -> "Name" -version :: Language -> T.Text+version :: Language -> Text version = \case Japanese -> "バージョン" Polish -> "Wersja"@@ -144,7 +144,7 @@ Esperanto -> "Versio" _ -> "Version" -aurStatus :: Language -> T.Text+aurStatus :: Language -> Text aurStatus = \case Japanese -> "パッケージ状態" Polish -> "Status w AUR"@@ -161,7 +161,7 @@ _ -> "AUR Status" -- NEEDS TRANSLATION-maintainer :: Language -> T.Text+maintainer :: Language -> Text maintainer = \case Japanese -> "管理者" Spanish -> "Mantenedor"@@ -173,7 +173,7 @@ Esperanto -> "Daŭriganto" _ -> "Maintainer" -projectUrl :: Language -> T.Text+projectUrl :: Language -> Text projectUrl = \case Japanese -> "プロジェクト" Polish -> "URL Projektu"@@ -191,7 +191,7 @@ Esperanto -> "URL de Projekto" _ -> "Project URL" -aurUrl :: Language -> T.Text+aurUrl :: Language -> Text aurUrl = \case Japanese -> "パッケージページ" Polish -> "URL w AUR"@@ -206,7 +206,7 @@ Esperanto -> "URL en AUR" _ -> "AUR URL" -license :: Language -> T.Text+license :: Language -> Text license = \case Japanese -> "ライセンス" Polish -> "Licencja"@@ -224,7 +224,7 @@ Esperanto -> "Permesilo" _ -> "License" -dependsOn :: Language -> T.Text+dependsOn :: Language -> Text dependsOn = \case Japanese -> "従属パッケージ" Polish -> "Zależności"@@ -240,7 +240,7 @@ Esperanto -> "Dependi de" _ -> "Depends On" -buildDeps :: Language -> T.Text+buildDeps :: Language -> Text buildDeps = \case Japanese -> "作成時従属パ" German -> "Build-Abhängigkeiten"@@ -252,7 +252,7 @@ Esperanto -> "Muntaj Dependecoj" _ -> "Build Deps" -votes :: Language -> T.Text+votes :: Language -> Text votes = \case Japanese -> "投票数" Polish -> "Głosy"@@ -270,7 +270,7 @@ Esperanto -> "Balotiloj" _ -> "Votes" -popularity :: Language -> T.Text+popularity :: Language -> Text popularity = \case Japanese -> "人気" Spanish -> "Popularidad"@@ -278,7 +278,7 @@ Esperanto -> "Populareco" _ -> "Popularity" -description :: Language -> T.Text+description :: Language -> Text description = \case Japanese -> "概要" Polish -> "Opis"@@ -296,7 +296,7 @@ Esperanto -> "Priskribo" _ -> "Description" -makeDeps :: Language -> T.Text+makeDeps :: Language -> Text makeDeps = \case Polish -> "Zależności Make" Croatian -> "Make Zavisnosti"
lib/Aura/Logo.hs view
@@ -15,32 +15,30 @@ import Aura.Pacman (verMsgPad) import Aura.Settings import Aura.Utils-import BasePrelude-import qualified Data.Text as T-import qualified Data.Text.IO as T import Data.Text.Prettyprint.Doc-import System.IO (hFlush, stdout)+import RIO+import qualified RIO.Text as T --- -- | Show an animated version message, but only when the output target -- is a terminal.-animateVersionMsg :: Settings -> T.Text -> [T.Text] -> IO ()+animateVersionMsg :: Settings -> Text -> [Text] -> IO () animateVersionMsg ss auraVersion verMsg = do when (isTerminal ss) $ do hideCursor- traverse_ (T.putStrLn . padString verMsgPad) verMsg -- Version message+ traverse_ (putTextLn . padString verMsgPad) verMsg -- Version message raiseCursorBy 7 -- Initial reraising of the cursor. drawPills 3- traverse_ T.putStrLn $ renderPacmanHead ss 0 Open -- Initial rendering of head.+ traverse_ putTextLn $ renderPacmanHead ss 0 Open -- Initial rendering of head. raiseCursorBy 4 takeABite ss 0 -- Initial bite animation. traverse_ pillEating pillsAndWidths clearGrid- T.putStrLn auraLogo- T.putStrLn $ "AURA Version " <> auraVersion- T.putStrLn " by Colin Woodbury\n"- traverse_ T.putStrLn . translatorMsg . langOf $ ss+ putTextLn auraLogo+ putTextLn $ "AURA Version " <> auraVersion+ putTextLn " by Colin Woodbury\n"+ traverse_ putTextLn . translatorMsg . langOf $ ss when (isTerminal ss) showCursor where pillEating (p, w) = clearGrid *> drawPills p *> takeABite ss w pillsAndWidths = [(2, 5), (1, 10), (0, 15)]@@ -48,12 +46,12 @@ data MouthState = Open | Closed deriving (Eq) -- Taken from: figlet -f small "aura"-auraLogo :: T.Text+auraLogo :: Text auraLogo = " __ _ _ _ _ _ __ _ \n" <> "/ _` | || | '_/ _` |\n" <> "\\__,_|\\_,_|_| \\__,_|" -openMouth :: Settings -> [T.Text]+openMouth :: Settings -> [Text] openMouth ss = map f [ " .--." , "/ _.-'"@@ -62,7 +60,7 @@ where f | shared ss (Colour Never) = id | otherwise = dtot . yellow . pretty -closedMouth :: Settings -> [T.Text]+closedMouth :: Settings -> [Text] closedMouth ss = map f [ " .--." , "/ _..\\"@@ -71,7 +69,7 @@ where f | shared ss (Colour Never) = id | otherwise = dtot . yellow . pretty -pill :: [T.Text]+pill :: [Text] pill = [ "" , ".-." , "'-'"@@ -79,31 +77,33 @@ takeABite :: Settings -> Int -> IO () takeABite ss pad = drawMouth Closed *> drawMouth Open- where drawMouth mouth = do- traverse_ T.putStrLn $ renderPacmanHead ss pad mouth- raiseCursorBy 4- hFlush stdout- threadDelay 125000+ where+ drawMouth :: MouthState -> IO ()+ drawMouth mouth = do+ traverse_ putTextLn $ renderPacmanHead ss pad mouth+ raiseCursorBy 4+ hFlush stdout+ threadDelay 125000 drawPills :: Int -> IO ()-drawPills numOfPills = traverse_ T.putStrLn pills- where pills = renderPills numOfPills+drawPills numOfPills = traverse_ putTextLn pills+ where pills = renderPills numOfPills clearGrid :: IO ()-clearGrid = T.putStr blankLines *> raiseCursorBy 4- where blankLines = fold . replicate 4 . padString 23 $ "\n"+clearGrid = putText blankLines *> raiseCursorBy 4+ where blankLines = fold . replicate 4 . padString 23 $ "\n" -renderPill :: Int -> [T.Text]+renderPill :: Int -> [Text] renderPill pad = padString pad <$> pill -renderPills :: Int -> [T.Text]+renderPills :: Int -> [Text] renderPills numOfPills = take numOfPills pillPostitions >>= render- where pillPostitions = [17, 12, 7]- render pos = renderPill pos <> [ cursorUpLineCode 5 ]+ where pillPostitions = [17, 12, 7]+ render pos = renderPill pos <> [ decodeUtf8Lenient $ cursorUpLineCode 5 ] -renderPacmanHead :: Settings -> Int -> MouthState -> [T.Text]+renderPacmanHead :: Settings -> Int -> MouthState -> [Text] renderPacmanHead ss pad Open = map (padString pad) $ openMouth ss renderPacmanHead ss pad Closed = map (padString pad) $ closedMouth ss -padString :: Int -> T.Text -> T.Text+padString :: Int -> Text -> Text padString pad cs = T.justifyRight (pad + T.length cs) ' ' cs
lib/Aura/MakePkg.hs view
@@ -18,15 +18,15 @@ import Aura.Languages import Aura.Settings import Aura.Types-import Aura.Utils (optionalPrompt, strictText)-import BasePrelude+import Aura.Utils (optionalPrompt) import Control.Error.Util (note)-import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.List.NonEmpty as NEL import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NES-import qualified Data.Text as T-import Lens.Micro ((^.), _2)+import Lens.Micro (_2)+import RIO+import qualified RIO.ByteString.Lazy as BL+import qualified RIO.Text as T import System.Path (Absolute, Path, fromAbsoluteFilePath, toFilePath, (</>)) import System.Path.IO (getCurrentDirectory, getDirectoryContents)@@ -64,7 +64,7 @@ make ss (User usr) pc = do (ec, se) <- runIt ss pc res <- readProcess $ proc "sudo" ["-u", T.unpack usr, toFilePath makepkgCmd, "--packagelist"]- let fs = map (fromAbsoluteFilePath . T.unpack . strictText) . BL.lines $ res ^. _2+ let fs = map (fromAbsoluteFilePath . T.unpack) . T.lines . decodeUtf8Lenient . BL.toStrict $ res ^. _2 pure (ec, se, fs) runIt :: MonadIO m => Settings -> ProcessConfig stdin stdout stderr -> m (ExitCode, BL.ByteString)
lib/Aura/Packages/AUR.hs view
@@ -32,36 +32,34 @@ import Aura.Pkgbuild.Fetch import Aura.Settings import Aura.Types-import BasePrelude hiding (head) import Control.Compactable (fmapEither) import Control.Concurrent.STM.TVar (modifyTVar')-import Control.Effect (Carrier, Member)-import Control.Effect.Error (Error)-import Control.Effect.Lift (Lift, sendM)-import Control.Effect.Reader (Reader, asks) import Control.Error.Util (hush, note) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import Control.Scheduler (Comp(..), traverseConcurrently) import Data.Generics.Product (field)+import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NEL-import qualified Data.Map.Strict as M-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 Data.Versions (versioning)-import Lens.Micro (each, non, to, (^.), (^..))+import Lens.Micro (each, non, (^..)) import Linux.Arch.Aur import Network.HTTP.Client (Manager)+import RIO+import RIO.List (sortBy)+import qualified RIO.Map as M+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Path import System.Path.IO (getCurrentDirectory) import System.Process.Typed --- --- | Attempt to retrieve info about a given `S.Set` of packages from the AUR.-aurLookup :: Manager -> NESet PkgName -> IO (Maybe (S.Set PkgName, S.Set Buildable))+-- | Attempt to retrieve info about a given `Set` of packages from the AUR.+aurLookup :: Manager -> NESet PkgName -> IO (Maybe (Set PkgName, Set Buildable)) aurLookup m names = runMaybeT $ do infos <- MaybeT . fmap hush . info m $ foldr (\(PkgName pn) acc -> pn : acc) [] names badsgoods <- lift $ traverseConcurrently Par' (buildable m) infos@@ -76,7 +74,7 @@ -- TODO Use `data-or` here to offer `Or (NESet PkgName) (NESet Package)`? -- Yes that sounds like a good idea :)- let f :: Settings -> NESet PkgName -> IO (Maybe (S.Set PkgName, S.Set Package))+ let f :: Settings -> NESet PkgName -> IO (Maybe (Set PkgName, Set Package)) f ss ps = do --- Retrieve cached Packages --- cache <- readTVarIO tv@@ -121,7 +119,7 @@ aurLink = fromUnrootedFilePath "https://aur.archlinux.org" -- | A package's home URL on the AUR.-pkgUrl :: PkgName -> T.Text+pkgUrl :: PkgName -> Text pkgUrl (PkgName pkg) = T.pack . toUnrootedFilePath $ aurLink </> fromUnrootedFilePath "packages" </> fromUnrootedFilePath (T.unpack pkg) -------------------@@ -148,17 +146,15 @@ _ -> \x y -> compare (aurVotesOf y) (aurVotesOf x) -- | Frontend to the `aur` library. For @-As@.-aurSearch :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- T.Text -> m [AurInfo]+aurSearch :: Text -> RIO Env [AurInfo] aurSearch regex = do ss <- asks settings- res <- liftMaybeM (Failure connectionFailure_1) . fmap hush . sendM $ search (managerOf ss) regex+ res <- liftMaybeM (Failure connectionFailure_1) . fmap hush . liftIO $ search (managerOf ss) regex pure $ sortAurInfo (bool Nothing (Just SortAlphabetically) $ switch ss SortAlphabetically) res -- | Frontend to the `aur` library. For @-Ai@.-aurInfo :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- NonEmpty PkgName -> m [AurInfo]+aurInfo :: NonEmpty PkgName -> RIO Env [AurInfo] aurInfo pkgs = do m <- asks (managerOf . settings)- res <- liftMaybeM (Failure connectionFailure_1) . fmap hush . sendM . info m . map (^. field @"name") $ toList pkgs+ res <- liftMaybeM (Failure connectionFailure_1) . fmap hush . liftIO . info m . map (^. field @"name") $ toList pkgs pure $ sortAurInfo (Just SortAlphabetically) res
lib/Aura/Packages/Repository.hs view
@@ -22,20 +22,17 @@ import Aura.Pacman (pacmanLines, pacmanOutput) import Aura.Settings (CommonSwitch(..), Settings(..), shared) import Aura.Types-import Aura.Utils (getSelection, strictText)-import BasePrelude hiding (try)-import Control.Compactable (fmapEither)-import Control.Compactable (traverseEither)-import Control.Concurrent.STM.TVar (modifyTVar')+import Aura.Utils (getSelection)+import Control.Compactable (fmapEither, traverseEither) import Control.Error.Util (hush, note) import Control.Scheduler (Comp(..), traverseConcurrently) import Data.Generics.Product (field)-import qualified Data.Map.Strict as M-import qualified Data.Set as S+import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Set.NonEmpty as NES-import qualified Data.Text as T import Data.Versions-import Lens.Micro ((^.))+import RIO hiding (try)+import qualified RIO.Map as M+import qualified RIO.Set as S import Text.Megaparsec import Text.Megaparsec.Char @@ -47,7 +44,7 @@ pacmanRepo = do tv <- newTVarIO mempty - let g :: Settings -> NES.NESet PkgName -> IO (Maybe (S.Set PkgName, S.Set Package))+ let g :: Settings -> NES.NESet PkgName -> IO (Maybe (Set PkgName, Set Package)) g ss names = do --- Retrieve cached Packages --- cache <- readTVarIO tv@@ -96,11 +93,11 @@ -- | The most recent version of a package, if it exists in the respositories. mostRecent :: PkgName -> IO (Either PkgName Versioning)-mostRecent p@(PkgName s) = note p . extractVersion . strictText <$> pacmanOutput ["-Si", s]+mostRecent p@(PkgName s) = note p . extractVersion . decodeUtf8Lenient <$> pacmanOutput ["-Si", s] -- | Parses the version number of a package from the result of a -- @pacman -Si@ call.-extractVersion :: T.Text -> Maybe Versioning+extractVersion :: Text -> Maybe Versioning extractVersion = hush . parse p "extractVersion" where p = do void $ takeWhile1P Nothing (/= '\n') *> newline
lib/Aura/Pacman.hs view
@@ -35,21 +35,17 @@ import Aura.Languages import Aura.Types-import Aura.Utils (strictText)-import BasePrelude hiding (setEnv, some, try)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.Map.Strict as M-import Data.Set (Set)-import qualified Data.Set as S+import Data.Bifunctor (first) import Data.Set.NonEmpty (NESet)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import Lens.Micro+import Lens.Micro (at, (^?), _2, _Just, _head) import Lens.Micro.GHC ()+import RIO hiding (first, some, try)+import qualified RIO.ByteString as BS+import qualified RIO.ByteString.Lazy as BL+import RIO.List.Partial ((!!))+import qualified RIO.Map as M+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Path (Absolute, Path, fromAbsoluteFilePath, toFilePath) import System.Process.Typed import Text.Megaparsec hiding (single)@@ -59,16 +55,16 @@ --- -- | The (meaningful) contents of the Pacman config file.-newtype Config = Config (M.Map T.Text [T.Text]) deriving (Show)+newtype Config = Config (Map Text [Text]) deriving (Show) -- | Parse a `Config`, the pacman configuration file.-config :: Parsec Void T.Text Config+config :: Parsec Void Text Config config = Config . M.fromList . rights <$> (garbage *> some (fmap Right (try pair) <|> fmap Left single) <* eof) -single :: Parsec Void T.Text ()+single :: Parsec Void Text () single = L.lexeme garbage . void $ manyTill letterChar newline -pair :: Parsec Void T.Text (T.Text, [T.Text])+pair :: Parsec Void Text (Text, [Text]) pair = L.lexeme garbage $ do n <- takeWhile1P Nothing (/= ' ') space@@ -78,7 +74,7 @@ pure (n, rest) -- | Using `[]` as block comment markers is a trick to skip conf file "section" lines.-garbage :: Parsec Void T.Text ()+garbage :: Parsec Void Text () garbage = L.space space1 (L.skipLineComment "#") (L.skipBlockComment "[" "]") -- | Default location of the pacman config file: \/etc\/pacman.conf@@ -96,7 +92,7 @@ -- | Given a filepath to the pacman config, try to parse its contents. getPacmanConf :: Path Absolute -> IO (Either Failure Config) getPacmanConf fp = do- file <- decodeUtf8With lenientDecode <$> BS.readFile (toFilePath fp)+ file <- decodeUtf8Lenient <$> BS.readFile (toFilePath fp) pure . first (const (Failure confParsing_1)) $ parse config "pacman config" file -- | Fetches the @IgnorePkg@ entry from the config, if it's there.@@ -109,12 +105,10 @@ -- | Given a `Set` of package groups, yield all the packages they contain. groupPackages :: NESet PkgGroup -> IO (Set PkgName)-groupPackages igs- | null igs = pure S.empty- | otherwise = fmap f . pacmanOutput $ "-Qg" : asFlag igs+groupPackages igs = fmap (f . decodeUtf8Lenient) . pacmanOutput $ "-Qg" : asFlag igs where- f :: BL.ByteString -> Set PkgName- f = S.fromList . map (PkgName . strictText . (!! 1) . BL.words) . BL.lines+ f :: Text -> Set PkgName+ f = S.fromList . map (PkgName . (!! 1) . T.words) . T.lines -- | Fetches the @CacheDir@ entry from the config, if it's there. getCachePath :: Config -> Maybe (Path Absolute)@@ -132,26 +126,26 @@ pacmanProc :: [String] -> ProcessConfig () () () pacmanProc args = setEnv [("LC_ALL", "C")] $ proc "pacman" args --- | Run a pacman action that may fail. Will never throw an IO exception.-pacman :: [T.Text] -> IO (Either Failure ())+-- | Run a pacman action that may fail.+pacman :: [Text] -> IO () pacman (map T.unpack -> args) = do ec <- runProcess $ pacmanProc args- pure . bool (Left $ Failure pacmanFailure_1) (Right ()) $ ec == ExitSuccess+ unless (ec == ExitSuccess) $ throwM (Failure pacmanFailure_1) -- | Run some `pacman` process, but only care about whether it succeeded. pacmanSuccess :: [T.Text] -> IO Bool pacmanSuccess = fmap (== ExitSuccess) . runProcess . setStderr closed . setStdout closed . pacmanProc . map T.unpack -- | Runs pacman silently and returns only the stdout.-pacmanOutput :: [T.Text] -> IO BL.ByteString-pacmanOutput = fmap (^. _2) . readProcess . pacmanProc . map T.unpack+pacmanOutput :: [Text] -> IO ByteString+pacmanOutput = fmap (^. _2 . to BL.toStrict) . readProcess . pacmanProc . map T.unpack -- | Runs pacman silently and returns the stdout as UTF8-decoded `Text` lines.-pacmanLines :: [T.Text] -> IO [T.Text]-pacmanLines s = T.lines . TL.toStrict . TL.decodeUtf8With lenientDecode <$> pacmanOutput s+pacmanLines :: [Text] -> IO [Text]+pacmanLines s = T.lines . decodeUtf8Lenient <$> pacmanOutput s -- | Yields the lines given by `pacman -V` with the pacman image stripped.-versionInfo :: IO [T.Text]+versionInfo :: IO [Text] versionInfo = map (T.drop verMsgPad) <$> pacmanLines ["-V"] -- | The amount of whitespace before text in the lines given by `pacman -V`
lib/Aura/Pkgbuild/Base.hs view
@@ -13,10 +13,8 @@ ) where import Aura.Types-import qualified Data.Text as T+import qualified RIO.Text as T import System.Path- (Absolute, FileExt(..), Path, fromAbsoluteFilePath, fromUnrootedFilePath,- (<.>), (</>)) ---
lib/Aura/Pkgbuild/Editing.hs view
@@ -12,18 +12,17 @@ module Aura.Pkgbuild.Editing ( hotEdit ) where -import Aura.Languages-import Aura.Settings-import Aura.Types-import Aura.Utils-import BasePrelude-import qualified Data.ByteString.Lazy.Char8 as BL-import Data.Generics.Product (field)-import Lens.Micro ((.~), (^.))-import System.Directory (setCurrentDirectory)-import System.Path (toFilePath)-import System.Path.IO (getCurrentDirectory, getTemporaryDirectory)-import System.Process.Typed (proc, runProcess)+import Aura.Languages+import Aura.Settings+import Aura.Types+import Aura.Utils+import Data.Generics.Product (field)+import Lens.Micro ((.~))+import RIO+import RIO.Directory (setCurrentDirectory)+import System.Path (toFilePath)+import System.Path.IO (getCurrentDirectory, getTemporaryDirectory)+import System.Process.Typed (proc, runProcess) --- @@ -32,9 +31,9 @@ -- package building. edit :: (FilePath -> IO a) -> Buildable -> IO Buildable edit f p = do- BL.writeFile filename $ p ^. field @"pkgbuild" . field @"pkgbuild"+ writeFileBinary filename $ p ^. field @"pkgbuild" . field @"pkgbuild" void $ f filename- newPB <- BL.readFile filename+ newPB <- readFileBinary filename pure (p & field @"pkgbuild" .~ Pkgbuild newPB) where filename = "PKGBUILD"
lib/Aura/Pkgbuild/Fetch.hs view
@@ -18,19 +18,15 @@ import Aura.Types (PkgName(..), Pkgbuild(..)) import Aura.Utils (urlContents)-import BasePrelude-import Control.Exception (SomeException, catch) import Data.Generics.Product (field)-import qualified Data.Text as T-import Lens.Micro ((^.)) import Network.HTTP.Client (Manager) import Network.URI (escapeURIString, isUnescapedInURIComponent)-import System.FilePath ((</>))+import RIO+import RIO.FilePath ((</>))+import qualified RIO.Text as T --- -type E = SomeException- baseUrl :: String baseUrl = "https://aur.archlinux.org/" @@ -40,8 +36,11 @@ ++ escapeURIString isUnescapedInURIComponent p -- | The PKGBUILD of a given package, retrieved from the AUR servers.-getPkgbuild :: MonadIO m => Manager -> PkgName -> m (Maybe Pkgbuild)+getPkgbuild :: Manager -> PkgName -> IO (Maybe Pkgbuild) getPkgbuild m p = e $ do t <- urlContents m . pkgbuildUrl . T.unpack $ p ^. field @"name" pure $ fmap Pkgbuild t- where e f = liftIO $ f `catch` (\(_ :: E) -> return Nothing)+ where+ -- TODO Make this less "baby's first Haskell".+ e :: IO (Maybe a) -> IO (Maybe a)+ e f = f `catch` (\(_ :: SomeException) -> return Nothing)
lib/Aura/Pkgbuild/Records.hs view
@@ -14,15 +14,13 @@ , storePkgbuilds ) where -import Aura.Pkgbuild.Base-import Aura.Types-import BasePrelude-import qualified Data.ByteString.Lazy.Char8 as BL-import Data.Generics.Product (field)-import Data.Set.NonEmpty (NESet)-import Lens.Micro ((^.))-import System.Path (toFilePath)-import System.Path.IO (createDirectoryIfMissing, doesFileExist)+import Aura.Pkgbuild.Base+import Aura.Types+import Data.Generics.Product (field)+import Data.Set.NonEmpty (NESet)+import RIO+import System.Path (toFilePath)+import System.Path.IO (createDirectoryIfMissing, doesFileExist) --- @@ -38,4 +36,4 @@ traverse_ (\p -> writePkgbuild (p ^. field @"name") (p ^. field @"pkgbuild")) bs writePkgbuild :: PkgName -> Pkgbuild -> IO ()-writePkgbuild pn (Pkgbuild pb) = BL.writeFile (toFilePath $ pkgbuildPath pn) pb+writePkgbuild pn (Pkgbuild pb) = writeFileBinary (toFilePath $ pkgbuildPath pn) pb
lib/Aura/Pkgbuild/Security.hs view
@@ -19,24 +19,23 @@ import Aura.Languages import Aura.Types (Language, Pkgbuild(..))-import Aura.Utils (strictText)-import BasePrelude hiding (Last, Word) import Control.Error.Util (hush)-import Data.Generics.Product-import qualified Data.Map.Strict as M-import qualified Data.Text as T+import Data.Generics.Product (typed, types) import Data.Text.Prettyprint.Doc (Doc) import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle) import Language.Bash.Parse (parse) import Language.Bash.Syntax import Language.Bash.Word (Span(..), Word, unquote)-import Lens.Micro+import Lens.Micro (each, (.~), (^..), _Just)+import RIO hiding (Word)+import qualified RIO.Map as M+import qualified RIO.Text as T --- -- | A bash term which should never appear in a PKGBUILD. If one does, it's -- either a sign of maintainer negligence or malicious behaviour.-data BannedTerm = BannedTerm T.Text BanCategory deriving (Eq, Ord, Show, Generic)+data BannedTerm = BannedTerm Text BanCategory deriving (Eq, Ord, Show, Generic) -- | The reason why the bash term is black-listed. data BanCategory = Downloading@@ -47,15 +46,17 @@ | CleverRedirect deriving (Eq, Ord, Show) -blacklist :: M.Map T.Text BannedTerm+blacklist :: Map Text BannedTerm blacklist = M.fromList $ downloading <> running <> permissions- where downloading = map (\t -> (t, BannedTerm t Downloading)) ["curl", "wget", "rsync", "scp"]- running = map (\t -> (t, BannedTerm t ScriptRunning)) ["sh", "bash", "eval", "zsh", "fish"]- permissions = map (\t -> (t, BannedTerm t Permissions)) ["sudo", "ssh"]+ where+ downloading = map (\t -> (t, BannedTerm t Downloading)) ["curl", "wget", "rsync", "scp"]+ running = map (\t -> (t, BannedTerm t ScriptRunning)) ["sh", "bash", "eval", "zsh", "fish"]+ permissions = map (\t -> (t, BannedTerm t Permissions)) ["sudo", "ssh"] +-- TODO wasteful conversion! -- | Attempt to parse a PKGBUILD. Should succeed for all reasonable PKGBUILDs. parsedPB :: Pkgbuild -> Maybe List-parsedPB (Pkgbuild pb) = hush . parse "PKGBUILD" . T.unpack $ strictText pb -- TODO wasteful conversion!+parsedPB (Pkgbuild pb) = hush . parse "PKGBUILD" . T.unpack $ decodeUtf8Lenient pb -- | Discover any banned terms lurking in a parsed PKGBUILD, paired with -- the surrounding context lines.
lib/Aura/Settings.hs view
@@ -25,10 +25,10 @@ ) where import Aura.Types-import BasePrelude-import qualified Data.Set as S-import qualified Data.Text as T import Network.HTTP.Client (Manager)+import RIO+import qualified RIO.Set as S+import qualified RIO.Text as T import System.Path (Absolute, Path, fromAbsoluteFilePath, toFilePath) ---@@ -51,7 +51,7 @@ { cachePathOf :: !(Either (Path Absolute) (Path Absolute)) , configPathOf :: !(Either (Path Absolute) (Path Absolute)) , logPathOf :: !(Either (Path Absolute) (Path Absolute))- , commonSwitchesOf :: !(S.Set CommonSwitch) } deriving (Show, Generic)+ , commonSwitchesOf :: !(Set CommonSwitch) } deriving (Show, Generic) instance Flagable CommonConfig where asFlag (CommonConfig cap cop lfp cs) =@@ -81,11 +81,11 @@ -- | Settings unique to the AUR package building process. data BuildConfig = BuildConfig- { makepkgFlagsOf :: !(S.Set Makepkg)+ { makepkgFlagsOf :: !(Set Makepkg) , buildPathOf :: !(Path Absolute) , buildUserOf :: !(Maybe User) , truncationOf :: !Truncation -- For `-As`- , buildSwitchesOf :: !(S.Set BuildSwitch) } deriving (Show)+ , buildSwitchesOf :: !(Set BuildSwitch) } deriving (Show) -- | Extra options for customizing the build process. data BuildSwitch = DeleteMakeDeps@@ -116,7 +116,7 @@ , langOf :: !Language , editorOf :: !FilePath , isTerminal :: !Bool- , ignoresOf :: !(S.Set PkgName)+ , ignoresOf :: !(Set PkgName) , commonConfigOf :: !CommonConfig , buildConfigOf :: !BuildConfig }
lib/Aura/State.hs view
@@ -24,49 +24,52 @@ import Aura.Cache import Aura.Colour (red)-import Aura.Core (Env(..), liftEitherM, notify, report, warn)+import Aura.Core (Env(..), notify, report, warn) import Aura.Languages-import Aura.Pacman (pacman, pacmanOutput)+import Aura.Pacman (pacman, pacmanLines) import Aura.Settings import Aura.Types import Aura.Utils-import BasePrelude hiding (Version) import Control.Compactable (fmapMaybe)-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.Error.Util (hush) import Data.Aeson-import Data.Aeson.Types (typeMismatch)-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BL import Data.Generics.Product (field)-import Data.List.NonEmpty (nonEmpty)-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import Data.Time+import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Versions import Lens.Micro ((^.))+import RIO+import qualified RIO.ByteString.Lazy as BL+import RIO.List (intercalate, partition, sort)+import RIO.List.Partial ((!!))+import qualified RIO.Map as M+import qualified RIO.Map.Unchecked as M+import qualified RIO.Text as T+import RIO.Time import System.Path import System.Path.IO (createDirectoryIfMissing, getDirectoryContents)+import Text.Printf (printf) --- -- | All packages installed at some specific `ZonedTime`. Any "pinned" PkgState will -- never be deleted by `-Bc`.-data PkgState = PkgState { timeOf :: ZonedTime, pinnedOf :: Bool, pkgsOf :: M.Map PkgName Versioning }+data PkgState = PkgState+ { timeOf :: ZonedTime+ , pinnedOf :: Bool+ , pkgsOf :: Map PkgName Versioning } instance ToJSON PkgState where- toJSON (PkgState t pnd ps) = object [ "time" .= t, "pinned" .= pnd, "packages" .= fmap prettyV ps ]+ toJSON (PkgState t pnd ps) = object+ [ "time" .= t+ , "pinned" .= pnd+ , "packages" .= fmap prettyV ps ] instance FromJSON PkgState where- parseJSON (Object v) = PkgState+ parseJSON = withObject "PkgState" $ \v -> PkgState <$> v .: "time" <*> v .: "pinned" <*> fmap f (v .: "packages") where f = fmapMaybe (hush . versioning)- parseJSON invalid = typeMismatch "PkgState" invalid data StateDiff = StateDiff { _toAlter :: [SimplePkg], _toRemove :: [PkgName] } @@ -79,7 +82,7 @@ inState (SimplePkg n v) s = maybe False (v ==) . M.lookup n $ pkgsOf s rawCurrentState :: IO [SimplePkg]-rawCurrentState = mapMaybe (simplepkg' . strictText) . BL.lines <$> pacmanOutput ["-Q"]+rawCurrentState = mapMaybe simplepkg' <$> pacmanLines ["-Q"] currentState :: IO PkgState currentState = do@@ -132,19 +135,19 @@ mnths = [ "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ] -- | Does its best to restore a state chosen by the user.-restoreState :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) => m ()+restoreState :: RIO Env () restoreState =- sendM getStateFiles >>= maybe (throwError $ Failure restoreState_2) f . nonEmpty- where f :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) => NonEmpty (Path Absolute) -> m ()+ liftIO getStateFiles >>= maybe (throwM $ Failure restoreState_2) f . nonEmpty+ where f :: NonEmpty (Path Absolute) -> RIO Env () f sfs = do ss <- asks settings let pth = either id id . cachePathOf $ commonConfigOf ss- mpast <- sendM $ selectState sfs >>= readState+ mpast <- liftIO $ selectState sfs >>= readState case mpast of- Nothing -> throwError $ Failure readState_1+ Nothing -> throwM $ Failure readState_1 Just past -> do- curr <- sendM currentState- Cache cache <- sendM $ cacheContents pth+ curr <- liftIO currentState+ Cache cache <- liftIO $ cacheContents pth let StateDiff rein remo = compareStates past curr (okay, nope) = partition (`M.member` cache) rein traverse_ (report red restoreState_1 . fmap (^. field @"name")) $ nonEmpty nope@@ -159,14 +162,13 @@ readState = fmap decode . BL.readFile . toFilePath -- | `reinstalling` can mean true reinstalling, or just altering.-reinstallAndRemove :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>- [PackagePath] -> [PkgName] -> m ()+reinstallAndRemove :: [PackagePath] -> [PkgName] -> RIO Env () reinstallAndRemove [] [] = asks settings >>= \ss ->- sendM (warn ss . reinstallAndRemove_1 $ langOf ss)+ liftIO (warn ss . reinstallAndRemove_1 $ langOf ss) reinstallAndRemove down remo | null remo = reinstall | null down = remove | otherwise = reinstall *> remove where- remove = liftEitherM . sendM . pacman $ "-R" : asFlag remo- reinstall = liftEitherM . sendM . pacman $ "-U" : map (T.pack . toFilePath . path) down+ remove = liftIO . pacman $ "-R" : asFlag remo+ reinstall = liftIO . pacman $ "-U" : map (T.pack . toFilePath . path) down
lib/Aura/Types.hs view
@@ -46,23 +46,21 @@ , User(..) ) where -import BasePrelude hiding (try) import Control.Error.Util (hush) import Data.Aeson (FromJSONKey, ToJSONKey)+import Data.Bifunctor (Bifunctor(..)) import Data.Bitraversable-import qualified Data.ByteString.Lazy as BL import Data.Generics.Product (field, super)-import qualified Data.Map.Strict as M import Data.Semigroup.Foldable (Foldable1(..)) import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NES-import qualified Data.Text as T import Data.Text.Prettyprint.Doc hiding (list, space) import Data.Text.Prettyprint.Doc.Render.Terminal import Data.These (These(..)) import Data.Versions hiding (Traversal')-import GHC.Generics (Generic) import Lens.Micro+import RIO hiding (try)+import qualified RIO.Text as T import System.Path (Absolute, Path, takeFileName, toUnrootedFilePath) import Text.Megaparsec import Text.Megaparsec.Char@@ -71,9 +69,9 @@ -- | Types whose members can be converted to CLI flags. class Flagable a where- asFlag :: a -> [T.Text]+ asFlag :: a -> [Text] -instance Flagable T.Text where+instance Flagable Text where asFlag t = [t] instance (Foldable f, Flagable a) => Flagable (f a) where@@ -141,7 +139,7 @@ -- >>> parseDep "pacman>1.2.3" -- Just (Dep {name = PkgName {name = "pacman"}, demand = >1.2.3}) -- @-parseDep :: T.Text -> Maybe Dep+parseDep :: Text -> Maybe Dep parseDep = hush . parse dep "dep" where dep = Dep <$> n <*> v n = PkgName <$> takeWhile1P Nothing (\c -> c /= '<' && c /= '>' && c /= '=')@@ -156,10 +154,10 @@ -- | Renders the `Dep` into a form that @pacman -T@ understands. The dual of -- `parseDep`.-renderedDep :: Dep -> T.Text+renderedDep :: Dep -> Text renderedDep (Dep n ver) = (n ^. field @"name") <> asT ver where- asT :: VersionDemand -> T.Text+ asT :: VersionDemand -> Text asT (LessThan v) = "<" <> prettyV v asT (AtLeast v) = ">=" <> prettyV v asT (MoreThan v) = ">" <> prettyV v@@ -201,7 +199,7 @@ simplepkg (PackagePath t) = uncurry SimplePkg <$> bitraverse hush hush (parse n "name" t', parse v "version" t') where t' = T.pack . toUnrootedFilePath $ takeFileName t - n :: Parsec Void T.Text PkgName+ n :: Parsec Void Text PkgName n = PkgName . T.pack <$> manyTill anySingle (try finished) -- | Assumes that a version number will never start with a letter,@@ -214,7 +212,7 @@ -- | Attempt to create a `SimplePkg` from text like: -- xchat 2.8.8-19-simplepkg' :: T.Text -> Maybe SimplePkg+simplepkg' :: Text -> Maybe SimplePkg simplepkg' = hush . parse parser "name-and-version" where parser = SimplePkg <$> (PkgName <$> takeWhile1P Nothing (/= ' ')) <*> (space *> versioning') @@ -235,7 +233,7 @@ f = ((^? _Just . field @"name") &&& (^? _Just . field @"version")) . simplepkg -- | The contents of a PKGBUILD file.-newtype Pkgbuild = Pkgbuild { pkgbuild :: BL.ByteString } deriving (Eq, Ord, Show, Generic)+newtype Pkgbuild = Pkgbuild { pkgbuild :: ByteString } deriving (Eq, Ord, Show, Generic) -- | All human languages available for text output. data Language = English@@ -266,19 +264,24 @@ -- will produce a human-friendly error. newtype Failure = Failure { failure :: Language -> Doc AnsiStyle } +instance Exception Failure++instance Show Failure where+ show (Failure _) = "There was some failure."+ -- | Shell environment variables.-type Environment = M.Map T.Text T.Text+type Environment = Map Text Text -- | The name of a user account on a Linux system.-newtype User = User { user :: T.Text } deriving (Eq, Show, Generic)+newtype User = User { user :: Text } deriving (Eq, Show, Generic) -- | The name of an Arch Linux package.-newtype PkgName = PkgName { name :: T.Text }+newtype PkgName = PkgName { name :: Text } deriving stock (Eq, Ord, Show, Generic) deriving newtype (Flagable, ToJSONKey, FromJSONKey, IsString) -- | A group that a `Package` could belong too, like @base@, @base-devel@, etc.-newtype PkgGroup = PkgGroup { group :: T.Text }+newtype PkgGroup = PkgGroup { group :: Text } deriving stock (Eq, Ord, Show, Generic) deriving newtype (Flagable)
lib/Aura/Utils.hs view
@@ -12,7 +12,6 @@ ( -- * Strings Pattern(..) , replaceByPatt, searchLines- , strictText -- * Network , urlContents -- * Shell@@ -24,6 +23,8 @@ , ifFile -- * Output , putStrLnA+ , putText+ , putTextLn , colourCheck , entrify -- * User Input@@ -37,65 +38,58 @@ import Aura.Languages (whitespace, yesNoMessage, yesPattern) import Aura.Settings import Aura.Types (Environment, Language, User(..))-import BasePrelude hiding (Version, (<+>))-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy as L-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal import Network.HTTP.Client import Network.HTTP.Types.Status (statusCode)-import System.IO (hFlush, stdout)+import RIO+import qualified RIO.ByteString as B+import qualified RIO.ByteString.Lazy as BL+import RIO.List.Partial (maximum)+import qualified RIO.Map as M+import qualified RIO.Text as T+import RIO.Text.Partial (breakOn) import System.Path (Absolute, Path, toFilePath) import System.Path.IO (doesFileExist) import System.Process.Typed (proc, runProcess)+import Text.Printf (printf) --- --------- -- STRING ------------- | For regex-like find-and-replace in some `T.Text`.-data Pattern = Pattern { _pattern :: T.Text, _target :: T.Text }+-- | For regex-like find-and-replace in some `Text`.+data Pattern = Pattern { _pattern :: Text, _target :: Text } -- | Replaces a (p)attern with a (t)arget in a line if possible.-replaceByPatt :: [Pattern] -> T.Text -> T.Text+replaceByPatt :: [Pattern] -> Text -> Text replaceByPatt [] l = l-replaceByPatt (Pattern p t : ps) l = case T.breakOn p l of+replaceByPatt (Pattern p t : ps) l = case breakOn p l of -- No match. (_, "") -> replaceByPatt ps l -- Matched. The matched pattern is still present at the head of `rest`, -- so we need to drop it first. (cs, rest) -> replaceByPatt ps (cs <> t <> T.drop (T.length p) rest) --- | Find lines which contain some given `T.Text`.-searchLines :: T.Text -> [T.Text] -> [T.Text]+-- | Find lines which contain some given `Text`.+searchLines :: Text -> [Text] -> [Text] searchLines pat = filter (T.isInfixOf pat) --- | Get strict Text out of a lazy ByteString.-strictText :: BL.ByteString -> T.Text-strictText = TL.toStrict . TL.decodeUtf8With lenientDecode- ----- -- IO ----- -- | Given a number of selections, allows the user to choose one.-getSelection :: Foldable f => (a -> T.Text) -> f a -> IO a+getSelection :: Foldable f => (a -> Text) -> f a -> IO a getSelection f choiceLabels = do let quantity = length choiceLabels- valids = show <$> [1..quantity]+ valids = map tshow [1..quantity] pad = show . length . show $ quantity choices = zip valids $ toList choiceLabels traverse_ (\(l,v) -> printf ("%" <> pad <> "s. %s\n") l (f v)) choices- putStr ">> "+ BL.putStr ">> " hFlush stdout- userChoice <- getLine+ userChoice <- decodeUtf8Lenient <$> B.getLine case userChoice `lookup` choices of Just valid -> pure valid Nothing -> getSelection f choiceLabels -- Ask again.@@ -109,20 +103,22 @@ -- NETWORK ---------- -- | Assumes the given URL is correctly formatted.-urlContents :: Manager -> String -> IO (Maybe L.ByteString)+urlContents :: Manager -> String -> IO (Maybe ByteString) urlContents m url = f <$> httpLbs (parseRequest_ url) m- where f res | statusCode (responseStatus res) == 200 = Just $ responseBody res- | otherwise = Nothing+ where+ f :: Response BL.ByteString -> Maybe ByteString+ f res | statusCode (responseStatus res) == 200 = Just . BL.toStrict $ responseBody res+ | otherwise = Nothing -------- -- SHELL -------- -- | Code borrowed from `ansi-terminal` library by Max Bolingbroke.-csi :: [Int] -> T.Text -> T.Text-csi args code = "\ESC[" <> T.intercalate ";" (map (T.pack . show) args) <> code+csi :: [Int] -> ByteString -> ByteString+csi args code = "\ESC[" <> B.intercalate ";" (map (encodeUtf8 . textDisplay) args) <> code -- | Terminal code for raising the cursor.-cursorUpLineCode :: Int -> T.Text+cursorUpLineCode :: Int -> ByteString cursorUpLineCode n = csi [n] "F" -- | This will get the true user name regardless of sudo-ing.@@ -145,7 +141,7 @@ getEditor = maybe "vi" T.unpack . M.lookup "EDITOR" -- | This will get the locale variable for translations from the environment-getLocale :: Environment -> T.Text+getLocale :: Environment -> Text getLocale env = fromMaybe "C" . asum $ map (`M.lookup` env) ["LC_ALL", "LC_MESSAGES", "LANG"] -- | Mark some `Path` as being owned by a `User`.@@ -154,33 +150,32 @@ -- | Hide the cursor in a terminal. hideCursor :: IO ()-hideCursor = T.putStr hideCursorCode+hideCursor = B.putStr hideCursorCode -- | Restore a cursor to visiblity in the terminal. showCursor :: IO ()-showCursor = T.putStr showCursorCode+showCursor = B.putStr showCursorCode -hideCursorCode :: T.Text+hideCursorCode :: ByteString hideCursorCode = csi [] "?25l" -showCursorCode :: T.Text+showCursorCode :: ByteString showCursorCode = csi [] "?25h" -- | Raise the cursor by @n@ lines. raiseCursorBy :: Int -> IO ()-raiseCursorBy = T.putStr . cursorUpLineCode+raiseCursorBy = B.putStr . cursorUpLineCode ---------------- -- CUSTOM OUTPUT ----------------- -- | Print a `Doc` with Aura flair after performing a `colourCheck`. putStrLnA :: Settings -> Doc AnsiStyle -> IO () putStrLnA ss d = putStrA ss $ d <> hardline -- | Will remove all colour annotations if the user specified @--color=never@. putStrA :: Settings -> Doc AnsiStyle -> IO ()-putStrA ss d = T.putStr . dtot $ "aura >>=" <+> colourCheck ss d+putStrA ss d = B.putStr . encodeUtf8 . dtot $ "aura >>=" <+> colourCheck ss d -- | Strip colours from a `Doc` if @--color=never@ is specified, -- or if the output target isn't a terminal.@@ -190,6 +185,12 @@ | isTerminal ss = id | otherwise = unAnnotate +putText :: Text -> IO ()+putText = B.putStr . encodeUtf8++putTextLn :: Text -> IO ()+putTextLn = BL.putStrLn . BL.fromStrict . encodeUtf8+ ---------- -- PROMPTS ----------@@ -197,11 +198,11 @@ yesNoPrompt ss msg = do putStrA ss . yellow $ msg <+> yesNoMessage (langOf ss) <> " " hFlush stdout- response <- T.getLine+ response <- decodeUtf8Lenient <$> B.getLine pure $ isAffirmative (langOf ss) response -- | An empty response emplies "yes".-isAffirmative :: Language -> T.Text -> Bool+isAffirmative :: Language -> Text -> Bool isAffirmative l t = T.null t || elem (T.toCaseFold t) (yesPattern l) -- | Doesn't prompt when `--noconfirm` is used.@@ -213,16 +214,16 @@ -- MISC ------- -- | Format two lists into two nice rows a la `-Qi` or `-Si`.-entrify :: Settings -> [T.Text] -> [Doc AnsiStyle] -> Doc AnsiStyle+entrify :: Settings -> [Text] -> [Doc AnsiStyle] -> Doc AnsiStyle entrify ss fs es = vsep $ zipWith combine fs' es- where fs' = padding ss fs- combine f e = annotate bold (pretty f) <+> ":" <+> e+ where fs' = padding ss fs+ combine f e = annotate bold (pretty f) <+> ":" <+> e -- | Right-pads strings according to the longest string in the group.-padding :: Settings -> [T.Text] -> [T.Text]+padding :: Settings -> [Text] -> [Text] padding ss fs = map (T.justifyLeft longest ws) fs- where ws = whitespace $ langOf ss- longest = maximum $ map T.length fs+ where ws = whitespace $ langOf ss+ longest = maximum $ map T.length fs -- | `maybe` with the function at the end. maybe' :: b -> Maybe a -> (a -> b) -> b
test/Test.hs view
@@ -7,12 +7,9 @@ import Aura.Pacman import Aura.Pkgbuild.Security import Aura.Types-import BasePrelude-import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import qualified Data.Text.IO as T import Data.Versions+import RIO+import qualified RIO.Map as M -- import Language.Bash.Pretty (prettyText) import System.Path import Test.Tasty@@ -24,11 +21,11 @@ main :: IO () main = do- conf <- T.readFile "test/pacman.conf"- pkb <- Pkgbuild <$> BL.readFile "test/aura.PKGBUILD"+ conf <- readFileUtf8 "test/pacman.conf"+ pkb <- Pkgbuild <$> readFileBinary "test/aura.PKGBUILD" defaultMain $ suite conf pkb -suite :: T.Text -> Pkgbuild -> TestTree+suite :: Text -> Pkgbuild -> TestTree suite conf pb = testGroup "Unit Tests" [ testGroup "Aura.Core" [ testCase "parseDep - python2" $ parseDep "python2" @?= Just (Dep "python2" Anything)@@ -72,7 +69,7 @@ assertEqual ("Language name map for " ++ show lang ++ " has incorrect number of items") (length languages - 1) (M.size names) ] , testGroup "Aura.Pkgbuild.Security"- [ testCase "Parsing - aura.PKGBUILD" $ do+ [ testCase "Parsing - aura.PKGBUILD" $ -- pPrintNoColor $ map (first prettyText) . bannedTerms <$> ppb -- pPrintNoColor ppb assertBool "Failed to parse" $ isJust ppb@@ -81,7 +78,7 @@ ] where ppb = parsedPB pb -firefox :: T.Text+firefox :: Text firefox = "Repository : extra\n\ \Name : firefox\n\ \Version : 60.0.2-1\n\