diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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! diff --git a/aura.cabal b/aura.cabal --- a/aura.cabal +++ b/aura.cabal @@ -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 diff --git a/doc/aura.8 b/doc/aura.8 --- a/doc/aura.8 +++ b/doc/aura.8 @@ -1,7 +1,7 @@ .\" Man page for `aura` .\" Written by Colin Woodbury -.TH aura 8 "June 2018" "Aura" "Aura Manual" +.TH aura 8 "January 2020" "Aura" "Aura Manual" .\" Disable hyphenation. .nh diff --git a/exec/Flags.hs b/exec/Flags.hs --- a/exec/Flags.hs +++ b/exec/Flags.hs @@ -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 diff --git a/exec/Settings.hs b/exec/Settings.hs --- a/exec/Settings.hs +++ b/exec/Settings.hs @@ -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) --- diff --git a/exec/aura.hs b/exec/aura.hs --- a/exec/aura.hs +++ b/exec/aura.hs @@ -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] diff --git a/lib/Aura/Build.hs b/lib/Aura/Build.hs --- a/lib/Aura/Build.hs +++ b/lib/Aura/Build.hs @@ -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 diff --git a/lib/Aura/Cache.hs b/lib/Aura/Cache.hs --- a/lib/Aura/Cache.hs +++ b/lib/Aura/Cache.hs @@ -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 diff --git a/lib/Aura/Colour.hs b/lib/Aura/Colour.hs --- a/lib/Aura/Colour.hs +++ b/lib/Aura/Colour.hs @@ -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 --- diff --git a/lib/Aura/Commands/A.hs b/lib/Aura/Commands/A.hs --- a/lib/Aura/Commands/A.hs +++ b/lib/Aura/Commands/A.hs @@ -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 diff --git a/lib/Aura/Commands/B.hs b/lib/Aura/Commands/B.hs --- a/lib/Aura/Commands/B.hs +++ b/lib/Aura/Commands/B.hs @@ -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) diff --git a/lib/Aura/Commands/C.hs b/lib/Aura/Commands/C.hs --- a/lib/Aura/Commands/C.hs +++ b/lib/Aura/Commands/C.hs @@ -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]] diff --git a/lib/Aura/Commands/L.hs b/lib/Aura/Commands/L.hs --- a/lib/Aura/Commands/L.hs +++ b/lib/Aura/Commands/L.hs @@ -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 diff --git a/lib/Aura/Commands/O.hs b/lib/Aura/Commands/O.hs --- a/lib/Aura/Commands/O.hs +++ b/lib/Aura/Commands/O.hs @@ -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 diff --git a/lib/Aura/Core.hs b/lib/Aura/Core.hs --- a/lib/Aura/Core.hs +++ b/lib/Aura/Core.hs @@ -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 diff --git a/lib/Aura/Dependencies.hs b/lib/Aura/Dependencies.hs --- a/lib/Aura/Dependencies.hs +++ b/lib/Aura/Dependencies.hs @@ -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 _) = [] diff --git a/lib/Aura/Diff.hs b/lib/Aura/Diff.hs --- a/lib/Aura/Diff.hs +++ b/lib/Aura/Diff.hs @@ -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) diff --git a/lib/Aura/Install.hs b/lib/Aura/Install.hs --- a/lib/Aura/Install.hs +++ b/lib/Aura/Install.hs @@ -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 diff --git a/lib/Aura/Languages.hs b/lib/Aura/Languages.hs --- a/lib/Aura/Languages.hs +++ b/lib/Aura/Languages.hs @@ -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." diff --git a/lib/Aura/Languages/Fields.hs b/lib/Aura/Languages/Fields.hs --- a/lib/Aura/Languages/Fields.hs +++ b/lib/Aura/Languages/Fields.hs @@ -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" diff --git a/lib/Aura/Logo.hs b/lib/Aura/Logo.hs --- a/lib/Aura/Logo.hs +++ b/lib/Aura/Logo.hs @@ -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 diff --git a/lib/Aura/MakePkg.hs b/lib/Aura/MakePkg.hs --- a/lib/Aura/MakePkg.hs +++ b/lib/Aura/MakePkg.hs @@ -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) diff --git a/lib/Aura/Packages/AUR.hs b/lib/Aura/Packages/AUR.hs --- a/lib/Aura/Packages/AUR.hs +++ b/lib/Aura/Packages/AUR.hs @@ -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 diff --git a/lib/Aura/Packages/Repository.hs b/lib/Aura/Packages/Repository.hs --- a/lib/Aura/Packages/Repository.hs +++ b/lib/Aura/Packages/Repository.hs @@ -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 diff --git a/lib/Aura/Pacman.hs b/lib/Aura/Pacman.hs --- a/lib/Aura/Pacman.hs +++ b/lib/Aura/Pacman.hs @@ -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` diff --git a/lib/Aura/Pkgbuild/Base.hs b/lib/Aura/Pkgbuild/Base.hs --- a/lib/Aura/Pkgbuild/Base.hs +++ b/lib/Aura/Pkgbuild/Base.hs @@ -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, - (<.>), ()) --- diff --git a/lib/Aura/Pkgbuild/Editing.hs b/lib/Aura/Pkgbuild/Editing.hs --- a/lib/Aura/Pkgbuild/Editing.hs +++ b/lib/Aura/Pkgbuild/Editing.hs @@ -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" diff --git a/lib/Aura/Pkgbuild/Fetch.hs b/lib/Aura/Pkgbuild/Fetch.hs --- a/lib/Aura/Pkgbuild/Fetch.hs +++ b/lib/Aura/Pkgbuild/Fetch.hs @@ -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) diff --git a/lib/Aura/Pkgbuild/Records.hs b/lib/Aura/Pkgbuild/Records.hs --- a/lib/Aura/Pkgbuild/Records.hs +++ b/lib/Aura/Pkgbuild/Records.hs @@ -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 diff --git a/lib/Aura/Pkgbuild/Security.hs b/lib/Aura/Pkgbuild/Security.hs --- a/lib/Aura/Pkgbuild/Security.hs +++ b/lib/Aura/Pkgbuild/Security.hs @@ -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. diff --git a/lib/Aura/Settings.hs b/lib/Aura/Settings.hs --- a/lib/Aura/Settings.hs +++ b/lib/Aura/Settings.hs @@ -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 } diff --git a/lib/Aura/State.hs b/lib/Aura/State.hs --- a/lib/Aura/State.hs +++ b/lib/Aura/State.hs @@ -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 diff --git a/lib/Aura/Types.hs b/lib/Aura/Types.hs --- a/lib/Aura/Types.hs +++ b/lib/Aura/Types.hs @@ -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) diff --git a/lib/Aura/Utils.hs b/lib/Aura/Utils.hs --- a/lib/Aura/Utils.hs +++ b/lib/Aura/Utils.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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\