diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,40 +1,95 @@ # Aura Changelog +## 2.3.0 (2020-04-22) + +#### Added + +- Allow `--asdeps` to be passed to `-A` commands. +- `-y` can be passed to `-A` commands again, like `-Ayu`. +- Dutch translations. Thank you, Joris Blanken! + +#### Changed + +- ~15% reduction in binary size and much faster compiles due to removal of + unnecessary dependencies. +- `-Cc` now reports how much storage space was cleared. +- A few more messages when using `--log-level=debug`. + +#### Removed + +- `makepkgConfFile` wasn't being used anywhere. + +#### Fixed + +- A bug involving multiple prompts appearing at the same time when more than one + package needs a custom provider selection. + [#541](https://github.com/fosskers/aura/issues/541) +- A bug involving the `+` character appearing in package names, like `crypto++`. + [#520](https://github.com/fosskers/aura/issues/520) +- A regression where the name of a parent package wouldn't be displayed when a + dependency couldn't be found. + [#513](https://github.com/fosskers/aura/issues/513) + ## 2.2.1 (2020-03-01) -- Pass the Pacman flag `--overwrite` through properly. +#### Changed + - Further improved Italian translations. +#### Fixed + +- Pass the Pacman flag `--overwrite` through properly. + ## 2.2.0 (2020-02-25) -- **New Feature:**: `--log-level` flag. Setting this to `debug` will give you - some verbose logging output. This is different from the usual `-x` behaviour. -- **Bug Fix:** Users with many AUR packages installed will no longer see - mysterious AUR connection failures. - ([#528](https://github.com/fosskers/aura/issues/528)) +#### Added + +- `--log-level` flag. Setting this to `debug` will give you some verbose logging + output. This is different from the usual `-x` behaviour. + +#### Changed + - Updated Italian translations. Grazie, Cristian Tentella! - Support for GHC 8.8.2. +#### Fixed + +- Users with many AUR packages installed will no longer see mysterious AUR + connection failures. ([#528](https://github.com/fosskers/aura/issues/528)) + ## 2.1.0 (2020-02-17) +#### Added + - Reinstated `-Aw`, which downloads a snapshot tarball of an AUR package. ## 2.0.6 (2020-02-16) +#### Fixed + - Fixed the broken `-S`. ## 2.0.5 (2020-02-16) +#### Fixed + - Fixed a bug that prevented `-Syuu` and `-Scc`. ## 2.0.4 (2020-02-08) +#### Changed + - Removed `fused-effects` dependency in favour of `rio` to simplify code. ## 2.0.3 +#### Changed + - Updated Spanish translations. Thanks to Max Ferrer! -- Fixed bug #543. Thanks to Alexey Kotlyarov! + +#### Fixed + +- Bug #543 involving locales. Thanks to Alexey Kotlyarov! ## 2.0.2 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.2.1 +version: 2.3.0 synopsis: A secure package manager for Arch Linux and the AUR. description: Aura is a package manager for Arch Linux. It connects to both the @@ -27,11 +27,7 @@ default-language: Haskell2010 default-extensions: NoImplicitPrelude - BangPatterns - LambdaCase OverloadedStrings - TupleSections - TypeApplications ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns @@ -43,16 +39,13 @@ , 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 , http-client >=0.5 && <0.7 - , nonempty-containers ^>=0.3 , prettyprinter >=1.2 && <1.7 , prettyprinter-ansi-terminal ^>=1.1 , transformers ^>=0.5 @@ -74,6 +67,7 @@ Aura.Dependencies Aura.Diff Aura.Install + Aura.IO Aura.Languages Aura.Languages.Fields Aura.Logo @@ -87,31 +81,25 @@ Aura.Pkgbuild.Records Aura.Pkgbuild.Security Aura.Settings + Aura.Shell Aura.State Aura.Types Aura.Utils build-depends: , aeson >=1.2 && <1.5 - , aeson-pretty ^>=0.8 , algebraic-graphs >=0.1 && <0.6 - , aur ^>=6.3 + , aur ^>=7.0 , filepath ^>=1.4 - , generic-lens >=1.1 && <1.3 + , hashable ^>= 1.3 , http-types >=0.9 && <0.13 , language-bash >=0.8 && <0.10 , megaparsec >=7 && <9 - , microlens-ghc ^>=0.4 - , mwc-random ^>=0.14 , network-uri ^>=2.6 , scheduler >=1.1 && <1.5 - , semigroupoids >=5.2 && <5.4 - , servant-client-core >= 0.16 && < 0.18 , stm ^>=2.5 - , these ^>=1.0 , time >=1.8 && <1.10 , unliftio ^>=0.2 - , witherable-class ^>=0 executable aura import: commons, libexec @@ -126,7 +114,6 @@ , aura , http-client-tls ^>=0.3 , optparse-applicative >=0.14 && <0.16 - , pretty-simple >=2.1 && <3.3 test-suite aura-test import: commons diff --git a/doc/aura.8 b/doc/aura.8 --- a/doc/aura.8 +++ b/doc/aura.8 @@ -423,3 +423,5 @@ ( Japanese ) Onoue Takuro .P ( Esperanto ) Zachary "Ghosy" Matthews +.P +( Dutch ) Joris Blanken diff --git a/exec/Flags.hs b/exec/Flags.hs --- a/exec/Flags.hs +++ b/exec/Flags.hs @@ -1,7 +1,7 @@ module Flags ( Program(..), opts - , PacmanOp( Sync ), SyncOp( SyncUpgrade ), MiscOp - , AuraOp(..), _AurSync, _AurIgnore, _AurIgnoreGroup + , PacmanOp( Sync ), SyncOp( SyncUpgrade ), SyncSwitch(..), MiscOp + , AuraOp(..), AurSwitch(..), _AurSync, _AurIgnore, _AurIgnoreGroup , AurOp(..), BackupOp(..), CacheOp(..), LogOp(..), OrphanOp(..) ) where @@ -9,16 +9,15 @@ import Aura.Pacman (defaultLogFile, pacmanConfFile) import Aura.Settings import Aura.Types -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES import Lens.Micro (Traversal') import Options.Applicative import RIO hiding (exp, log) +import RIO.FilePath import RIO.List.Partial (foldr1) -import qualified RIO.NonEmpty.Partial as NEL +import qualified RIO.NonEmpty as NEL +import qualified RIO.NonEmpty.Partial as NELP import qualified RIO.Set as S import qualified RIO.Text as T -import System.Path (Absolute, Path, fromAbsoluteFilePath, toFilePath) --- @@ -37,13 +36,13 @@ } deriving (Show) -- | Inherited operations that are fed down to Pacman. -data PacmanOp = Database (Either DatabaseOp (NESet PkgName)) +data PacmanOp = Database (Either DatabaseOp (NonEmpty PkgName)) | Files (Set FilesOp) | Query (Either QueryOp (Set QueryFilter, Set PkgName)) - | Remove (Set RemoveOp) (NESet PkgName) + | Remove (Set RemoveOp) (NonEmpty PkgName) | Sync (Either (NonEmpty SyncOp) (Set PkgName)) (Set SyncSwitch) - | TestDeps (NESet Text) - | Upgrade (Set UpgradeSwitch) (NESet PkgName) + | TestDeps (NonEmpty Text) + | Upgrade (Set UpgradeSwitch) (NonEmpty PkgName) deriving (Show) instance Flagable PacmanOp where @@ -59,8 +58,8 @@ asFlag (Upgrade s ps) = "-U" : asFlag s ++ asFlag ps data DatabaseOp = DBCheck - | DBAsDeps (NESet Text) - | DBAsExplicit (NESet Text) + | DBAsDeps (NonEmpty Text) + | DBAsExplicit (NonEmpty Text) deriving (Show) instance Flagable DatabaseOp where @@ -68,7 +67,7 @@ asFlag (DBAsDeps ps) = "--asdeps" : asFlag ps asFlag (DBAsExplicit ps) = "--asexplicit" : asFlag ps -data FilesOp = FilesList (NESet Text) +data FilesOp = FilesList (NonEmpty Text) | FilesOwns Text | FilesSearch Text | FilesRegex @@ -84,13 +83,13 @@ asFlag FilesRefresh = ["--refresh"] asFlag FilesMachineReadable = ["--machinereadable"] -data QueryOp = QueryChangelog (NESet Text) - | QueryGroups (NESet Text) - | QueryInfo (NESet Text) - | QueryCheck (NESet Text) - | QueryList (NESet Text) - | QueryOwns (NESet Text) - | QueryFile (NESet Text) +data QueryOp = QueryChangelog (NonEmpty Text) + | QueryGroups (NonEmpty Text) + | QueryInfo (NonEmpty Text) + | QueryCheck (NonEmpty Text) + | QueryList (NonEmpty Text) + | QueryOwns (NonEmpty Text) + | QueryFile (NonEmpty Text) | QuerySearch Text deriving (Show) @@ -133,12 +132,12 @@ asFlag RemoveUnneeded = ["--unneeded"] data SyncOp = SyncClean - | SyncGroups (NESet Text) - | SyncInfo (NESet Text) + | SyncGroups (NonEmpty Text) + | SyncInfo (NonEmpty Text) | SyncList Text | SyncSearch Text | SyncUpgrade (Set Text) - | SyncDownload (NESet Text) + | SyncDownload (NonEmpty Text) deriving (Eq, Ord, Show) instance Flagable SyncOp where @@ -177,32 +176,32 @@ asFlag (UpgradeOverwrite glob) = "--overwrite" : asFlag glob -- | Flags common to several Pacman operations. -data MiscOp = MiscArch (Path Absolute) +data MiscOp = MiscArch FilePath | MiscAssumeInstalled Text | MiscColor Text | MiscConfirm | MiscDBOnly - | MiscDBPath (Path Absolute) - | MiscGpgDir (Path Absolute) - | MiscHookDir (Path Absolute) + | MiscDBPath FilePath + | MiscGpgDir FilePath + | MiscHookDir FilePath | MiscNoDeps | MiscNoProgress | MiscNoScriptlet | MiscPrint | MiscPrintFormat Text - | MiscRoot (Path Absolute) + | MiscRoot FilePath | MiscVerbose deriving (Eq, Ord, Show) instance Flagable MiscOp where - asFlag (MiscArch p) = ["--arch", T.pack $ toFilePath p] + asFlag (MiscArch p) = ["--arch", T.pack p] asFlag (MiscAssumeInstalled p) = ["--assume-installed", p] asFlag (MiscColor c) = ["--color", c] - asFlag (MiscDBPath p) = ["--dbpath", T.pack $ toFilePath p] - asFlag (MiscGpgDir p) = ["--gpgdir", T.pack $ toFilePath p] - asFlag (MiscHookDir p) = ["--hookdir", T.pack $ toFilePath p] + asFlag (MiscDBPath p) = ["--dbpath", T.pack p] + asFlag (MiscGpgDir p) = ["--gpgdir", T.pack p] + asFlag (MiscHookDir p) = ["--hookdir", T.pack p] asFlag (MiscPrintFormat s) = ["--print-format", s] - asFlag (MiscRoot p) = ["--root", T.pack $ toFilePath p] + asFlag (MiscRoot p) = ["--root", T.pack p] asFlag MiscConfirm = ["--confirm"] asFlag MiscDBOnly = ["--dbonly"] asFlag MiscNoDeps = ["--nodeps"] @@ -212,9 +211,9 @@ asFlag MiscVerbose = ["--verbose"] -- | Operations unique to Aura. -data AuraOp = AurSync (Either AurOp (NESet PkgName)) (Set AurSwitch) +data AuraOp = AurSync (Either AurOp (NonEmpty PkgName)) (Set AurSwitch) | Backup (Maybe BackupOp) - | Cache (Either CacheOp (NESet PkgName)) + | Cache (Either CacheOp (NonEmpty PkgName)) | Log (Maybe LogOp) | Orphans (Maybe OrphanOp) | Version @@ -226,17 +225,18 @@ _AurSync f (AurSync o s) = AurSync o <$> f s _AurSync _ x = pure x -data AurOp = AurDeps (NESet PkgName) - | AurInfo (NESet PkgName) - | AurPkgbuild (NESet PkgName) +data AurOp = AurDeps (NonEmpty PkgName) + | AurInfo (NonEmpty PkgName) + | AurPkgbuild (NonEmpty PkgName) | AurSearch Text | AurUpgrade (Set PkgName) - | AurJson (NESet PkgName) - | AurTarball (NESet PkgName) + | AurJson (NonEmpty PkgName) + | AurTarball (NonEmpty PkgName) deriving (Show) data AurSwitch = AurIgnore (Set PkgName) | AurIgnoreGroup (Set PkgGroup) + | AurRepoSync deriving (Eq, Ord, Show) _AurIgnore :: Traversal' AurSwitch (Set PkgName) @@ -249,14 +249,15 @@ data BackupOp = BackupClean Word | BackupRestore | BackupList deriving (Show) -data CacheOp = CacheBackup (Path Absolute) | CacheClean Word | CacheCleanNotSaved | CacheSearch Text deriving (Show) +data CacheOp = CacheBackup FilePath | CacheClean Word | CacheCleanNotSaved | CacheSearch Text deriving (Show) -data LogOp = LogInfo (NESet PkgName) | LogSearch Text deriving (Show) +data LogOp = LogInfo (NonEmpty PkgName) | LogSearch Text deriving (Show) -data OrphanOp = OrphanAbandon | OrphanAdopt (NESet PkgName) deriving (Show) +data OrphanOp = OrphanAbandon | OrphanAdopt (NonEmpty PkgName) deriving (Show) opts :: ParserInfo Program -opts = info (program <**> helper) (fullDesc <> header "Aura - Package manager for Arch Linux and the AUR.") +opts = info (program <**> helper) + (fullDesc <> header "Aura - Package manager for Arch Linux and the AUR.") program :: Parser Program program = Program @@ -272,7 +273,7 @@ aursync :: Parser AuraOp aursync = bigA *> (AurSync - <$> (fmap (Right . NES.fromList . fmap (PkgName . T.toLower) . NES.toList) someArgs <|> fmap Left mods) + <$> (fmap (Right . NEL.map (PkgName . T.toLower)) someArgs <|> fmap Left mods) <*> (S.fromList <$> many switches) ) where bigA = flag' () (long "aursync" <> short 'A' <> help "Install packages from the AUR.") @@ -284,11 +285,12 @@ upgrade = AurUpgrade <$> (flag' () (long "sysupgrade" <> short 'u' <> hidden <> help "Upgrade all installed AUR packages.") *> fmap (S.map PkgName) manyArgs') aur = AurJson <$> (flag' () (long "json" <> hidden <> help "Retrieve package JSON straight from the AUR.") *> somePkgs') tarball = AurTarball <$> (flag' () (long "downloadonly" <> short 'w' <> hidden <> help "Download a package tarball.") *> somePkgs') - switches = ign <|> igg - ign = AurIgnore . S.fromList . map PkgName . T.split (== ',') <$> - strOption (long "ignore" <> metavar "PKG(,PKG,...)" <> hidden <> help "Ignore given packages.") - igg = AurIgnoreGroup . S.fromList . map PkgGroup . T.split (== ',') <$> - strOption (long "ignoregroup" <> metavar "PKG(,PKG,...)" <> hidden <> help "Ignore packages from the given groups.") + switches = ign <|> igg <|> y + ign = AurIgnore . S.fromList . map PkgName . T.split (== ',') + <$> strOption (long "ignore" <> metavar "PKG(,PKG,...)" <> hidden <> help "Ignore given packages.") + igg = AurIgnoreGroup . S.fromList . map PkgGroup . T.split (== ',') + <$> strOption (long "ignoregroup" <> metavar "PKG(,PKG,...)" <> hidden <> help "Ignore packages from the given groups.") + y = flag' AurRepoSync (short 'y' <> hidden <> help "Do an -Sy before continuing.") backups :: Parser AuraOp backups = bigB *> (Backup <$> optional mods) @@ -302,7 +304,7 @@ cache = bigC *> (Cache <$> (fmap Left mods <|> fmap Right somePkgs)) where bigC = flag' () (long "downgrade" <> short 'C' <> help "Interact with the package cache.") mods = backup <|> clean <|> clean' <|> search - backup = CacheBackup . fromAbsoluteFilePath <$> strOption (long "backup" <> short 'b' <> metavar "PATH" <> help "Backup the package cache to a given directory." <> hidden) + backup = CacheBackup <$> option (eitherReader absFilePath) (long "backup" <> short 'b' <> metavar "PATH" <> help "Backup the package cache to a given directory." <> hidden) clean = CacheClean <$> option auto (long "clean" <> short 'c' <> metavar "N" <> help "Save the most recent N versions of a package in the cache, deleting the rest." <> hidden) clean' = flag' CacheCleanNotSaved (long "notsaved" <> help "Clean out any cached package files which doesn't appear in any saved state." <> hidden) search = CacheSearch <$> strOption (long "search" <> short 's' <> metavar "STRING" <> help "Search the package cache via a search string." <> hidden) @@ -336,7 +338,7 @@ ia = flag' IgnoreArch (long "ignorearch" <> hidden <> help "Exposed makepkg flag.") as = flag' AllSource (long "allsource" <> hidden <> help "Exposed makepkg flag.") si = flag' SkipInteg (long "skipinteg" <> hidden <> help "Skip all makepkg integrity checks.") - bp = fmap fromAbsoluteFilePath (strOption (long "build" <> metavar "PATH" <> hidden <> help "Directory in which to build packages.")) + bp = option (eitherReader absFilePath) (long "build" <> metavar "PATH" <> hidden <> help "Directory in which to build packages.") <|> pure defaultBuildDir bu = User <$> strOption (long "builduser" <> metavar "USER" <> hidden <> help "User account to build as.") trunc = fmap Head (option auto (long "head" <> metavar "N" <> hidden <> help "Only show top N search results.")) @@ -344,7 +346,7 @@ <|> pure None buildSwitches :: Parser (Set BuildSwitch) -buildSwitches = S.fromList <$> many (lv <|> dmd <|> dsm <|> dpb <|> rbd <|> he <|> ucp <|> dr <|> sa <|> fo <|> npc) +buildSwitches = S.fromList <$> many (lv <|> dmd <|> dsm <|> dpb <|> rbd <|> he <|> ucp <|> dr <|> sa <|> fo <|> npc <|> asd) 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.") dpb = flag' DiffPkgbuilds (long "diff" <> short 'k' <> hidden <> help "Show PKGBUILD diffs.") @@ -356,17 +358,18 @@ lv = flag' LowVerbosity (long "quiet" <> short 'q' <> hidden <> help "Display less information.") fo = flag' ForceBuilding (long "force" <> hidden <> help "Always (re)build specified packages.") npc = flag' NoPkgbuildCheck (long "noanalysis" <> hidden <> help "Do not analyse PKGBUILDs for security flaws.") + asd = flag' AsDeps (long "asdeps" <> hidden <> help "All installed packages will be marked as dependencies.") commonConfig :: Parser CommonConfig commonConfig = CommonConfig <$> cap <*> cop <*> lfp <*> commonSwitches - where cap = fmap (Right . fromAbsoluteFilePath) - (strOption (long "cachedir" <> hidden <> help "Use an alternate package cache location.")) + where cap = fmap Right + (option (eitherReader absFilePath) (long "cachedir" <> hidden <> help "Use an alternate package cache location.")) <|> pure (Left defaultPackageCache) - cop = fmap (Right . fromAbsoluteFilePath) - (strOption (long "config" <> hidden <> help "Use an alternate Pacman config file.")) + cop = fmap Right + (option (eitherReader absFilePath) (long "config" <> hidden <> help "Use an alternate Pacman config file.")) <|> pure (Left pacmanConfFile) - lfp = fmap (Right . fromAbsoluteFilePath) - (strOption (long "logfile" <> hidden <> help "Use an alternate Pacman log.")) + lfp = fmap Right + (option (eitherReader absFilePath) (long "logfile" <> hidden <> help "Use an alternate Pacman log.")) <|> pure (Left defaultLogFile) commonSwitches :: Parser (Set CommonSwitch) @@ -436,7 +439,7 @@ sync = bigS *> (Sync <$> (fmap (Right . S.map PkgName) manyArgs <|> fmap Left mods) <*> (S.fromList <$> many (ref <|> ign <|> igg))) where bigS = flag' () (long "sync" <> short 'S' <> help "Install official packages.") ref = flag' SyncRefresh (long "refresh" <> short 'y' <> hidden <> help "Update the package database.") - mods = NEL.fromList <$> some (cln <|> gps <|> inf <|> lst <|> sch <|> upg <|> dnl) + mods = NELP.fromList <$> some (cln <|> gps <|> inf <|> lst <|> sch <|> upg <|> dnl) cln = flag' SyncClean (long "clean" <> short 'c' <> hidden <> help "Remove old packages from the cache.") gps = SyncGroups <$> (flag' () (long "groups" <> short 'g' <> hidden <> help "View members of a package group.") *> someArgs') inf = SyncInfo <$> (flag' () (long "info" <> short 'i' <> hidden <> help "View package information.") *> someArgs') @@ -451,17 +454,17 @@ 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.") - dbp = MiscDBPath . fromAbsoluteFilePath - <$> strOption (long "dbpath" <> short 'b' <> metavar "PATH" <> hidden <> help "Use an alternate database location.") - roo = MiscRoot . fromAbsoluteFilePath - <$> strOption (long "root" <> short 'r' <> metavar "PATH" <> hidden <> help "Use an alternate installation root.") + where ar = MiscArch + <$> option (eitherReader absFilePath) (long "arch" <> metavar "ARCH" <> hidden <> help "Use an alternate architecture.") + dbp = MiscDBPath + <$> option (eitherReader absFilePath) (long "dbpath" <> short 'b' <> metavar "PATH" <> hidden <> help "Use an alternate database location.") + roo = MiscRoot + <$> option (eitherReader absFilePath) (long "root" <> short 'r' <> metavar "PATH" <> hidden <> help "Use an alternate installation root.") ver = flag' MiscVerbose (long "verbose" <> short 'v' <> hidden <> help "Be more verbose.") - gpg = MiscGpgDir . fromAbsoluteFilePath - <$> strOption (long "gpgdir" <> metavar "PATH" <> hidden <> help "Use an alternate GnuGPG directory.") - hd = MiscHookDir . fromAbsoluteFilePath - <$> strOption (long "hookdir" <> metavar "PATH" <> hidden <> help "Use an alternate hook directory.") + gpg = MiscGpgDir + <$> option (eitherReader absFilePath) (long "gpgdir" <> metavar "PATH" <> hidden <> help "Use an alternate GnuGPG directory.") + hd = MiscHookDir + <$> option (eitherReader absFilePath) (long "hookdir" <> metavar "PATH" <> hidden <> help "Use an alternate hook directory.") con = flag' MiscConfirm (long "confirm" <> hidden <> help "Always ask for confirmation.") dbo = flag' MiscDBOnly (long "dbonly" <> hidden <> help "Only modify database entries, not package files.") nop = flag' MiscNoProgress (long "noprogressbar" <> hidden <> help "Don't show a progress bar when downloading.") @@ -486,20 +489,20 @@ igg = UpgradeIgnoreGroup . S.fromList . map PkgGroup . T.split (== ',') <$> strOption (long "ignoregroup" <> metavar "PKG(,PKG,...)" <> hidden <> help "Ignore packages from the given groups.") -somePkgs :: Parser (NESet PkgName) -somePkgs = NES.fromList . NEL.fromList . map PkgName <$> some (argument str (metavar "PACKAGES")) +somePkgs :: Parser (NonEmpty PkgName) +somePkgs = NELP.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 . NEL.fromList . map PkgName <$> some (argument str (metavar "PACKAGES" <> hidden)) +somePkgs' :: Parser (NonEmpty PkgName) +somePkgs' = NELP.fromList . map PkgName <$> some (argument str (metavar "PACKAGES" <> hidden)) -- | One or more arguments. -someArgs :: Parser (NESet Text) -someArgs = NES.fromList . NEL.fromList <$> some (argument str (metavar "PACKAGES")) +someArgs :: Parser (NonEmpty Text) +someArgs = NEL.nub . NELP.fromList <$> some (argument str (metavar "PACKAGES")) -- | Same as `someArgs`, but the help message "brief display" won't show PACKAGES. -someArgs' :: Parser (NESet Text) -someArgs' = NES.fromList . NEL.fromList <$> some (argument str (metavar "PACKAGES" <> hidden)) +someArgs' :: Parser (NonEmpty Text) +someArgs' = NEL.nub . NELP.fromList <$> some (argument str (metavar "PACKAGES" <> hidden)) -- | Zero or more arguments. manyArgs :: Parser (Set Text) @@ -511,21 +514,22 @@ language :: Parser Language language = foldr1 (<|>) $ map (\(f, v) -> flag' v (long f <> hidden)) langs - where langs = [ ( "japanese", Japanese ), ( "日本語", Japanese ) - , ( "polish", Polish ), ( "polski", Polish ) - , ( "croatian", Croatian ), ( "hrvatski", Croatian ) - , ( "swedish", Swedish ), ( "svenska", Swedish ) - , ( "german", German ), ( "deutsch", German ) - , ( "spanish", Spanish ), ( "español", Spanish ) - , ( "portuguese", Portuguese ), ( "português", Portuguese ) - , ( "french", French), ( "français", French ) - , ( "russian", Russian ), ( "русский", Russian ) - , ( "italian", Italian ), ( "italiano", Italian ) - , ( "serbian", Serbian ), ( "српски", Serbian ) - , ( "norwegian", Norwegian ), ( "norsk", Norwegian ) + where langs = [ ( "japanese", Japanese ), ( "日本語", Japanese ) + , ( "polish", Polish ), ( "polski", Polish ) + , ( "croatian", Croatian ), ( "hrvatski", Croatian ) + , ( "swedish", Swedish ), ( "svenska", Swedish ) + , ( "german", German ), ( "deutsch", German ) + , ( "spanish", Spanish ), ( "español", Spanish ) + , ( "portuguese", Portuguese ), ( "português", Portuguese ) + , ( "french", French), ( "français", French ) + , ( "russian", Russian ), ( "русский", Russian ) + , ( "italian", Italian ), ( "italiano", Italian ) + , ( "serbian", Serbian ), ( "српски", Serbian ) + , ( "norwegian", Norwegian ), ( "norsk", Norwegian ) , ( "indonesian", Indonesia ) - , ( "chinese", Chinese ), ( "中文", Chinese ) - , ( "esperanto", Esperanto ) ] + , ( "chinese", Chinese ), ( "中文", Chinese ) + , ( "esperanto", Esperanto ) + , ( "dutch", Dutch ), ( "nederlands", Dutch ) ] logLevel :: Parser LogLevel logLevel = option (eitherReader l) @@ -538,3 +542,6 @@ l "warn" = Right LevelWarn l "error" = Right LevelError l _ = Left "Must be one of debug|info|warn|error" + +absFilePath :: String -> Either String FilePath +absFilePath fp = bool (Left $ "Not absolute: " <> fp) (Right fp) $ isAbsolute fp diff --git a/exec/Settings.hs b/exec/Settings.hs --- a/exec/Settings.hs +++ b/exec/Settings.hs @@ -29,10 +29,10 @@ import Aura.Packages.Repository (pacmanRepo) import Aura.Pacman import Aura.Settings +import Aura.Shell import Aura.Types -import Aura.Utils +import Aura.Utils (nes) import Data.Bifunctor (Bifunctor(..)) -import qualified Data.Set.NonEmpty as NES import Flags import Lens.Micro (folded, (^..), _Right) import Network.HTTP.Client (newManager) @@ -57,7 +57,7 @@ environment <- M.fromList . map (bimap T.pack T.pack) <$> getEnvironment manager <- newManager tlsManagerSettings isTerm <- hIsTerminalDevice stdout - fromGroups <- maybe (pure S.empty) groupPackages . NES.nonEmptySet + fromGroups <- maybe (pure S.empty) groupPackages . nes $ getIgnoredGroups confFile <> igg let language = checkLang lng environment bu <- maybe (throwM $ Failure whoIsBuildUser_1) pure @@ -79,6 +79,7 @@ , logPathOf = first (\x -> fromMaybe x $ getLogFilePath confFile) $ logPathOf co } , buildConfigOf = bc { buildUserOf = Just bu} + , logLevelOf = ll , logFuncOf = logFunc } f (Env repos ss) diff --git a/exec/aura.hs b/exec/aura.hs --- a/exec/aura.hs +++ b/exec/aura.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} {- @@ -42,23 +40,22 @@ import Aura.Commands.L as L import Aura.Commands.O as O import Aura.Core +import Aura.IO import Aura.Languages import Aura.Logo import Aura.Pacman import Aura.Settings import Aura.Types -import Aura.Utils (putTextLn) +import Aura.Utils (nes) import Data.Bifunctor (first) -import qualified Data.Set.NonEmpty as NES import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal import Flags import Options.Applicative (execParser) import RIO hiding (first) +import qualified RIO.Set as S import Settings -import System.Path (toFilePath) import System.Process.Typed (proc, runProcess) -import Text.Pretty.Simple (pPrintNoColor) --- @@ -85,27 +82,32 @@ f (Failure fl) = fl $ langOf (settings env) exit :: Settings -> Either (Doc AnsiStyle) () -> IO a -exit ss (Left e) = scold ss e *> exitFailure +exit ss (Left e) = scold ss (const e) *> exitFailure exit _ (Right _) = exitSuccess execOpts :: Either (PacmanOp, Set MiscOp) AuraOp -> RIO Env () execOpts ops = do logDebug "Interpreting CLI options." ss <- asks settings - when (shared ss Debug) $ do - liftIO . pPrintNoColor $ ops - liftIO . pPrintNoColor $ buildConfigOf ss - liftIO . pPrintNoColor $ commonConfigOf ss - let p (ps, ms) = liftIO . pacman $ + when (logLevelOf ss == LevelDebug) $ do + logDebug $ displayShow ops + logDebug . displayShow $ buildConfigOf ss + logDebug . displayShow $ commonConfigOf ss + + let p :: (PacmanOp, Set MiscOp) -> RIO Env () + 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 sops) _, _) - | any isUpgrade sops -> sudo (liftIO $ B.saveState ss) *> p o + | any isUpgrade sops -> sudo (liftIO $ B.saveState ss) >> p o Left o -> logDebug "Performing a pacman operation." >> p o - Right (AurSync o _) -> + Right (AurSync o sws) -> do + when (any isYWithA sws) + $ sudo $ p (Sync (Right mempty) (S.singleton SyncRefresh), mempty) case o of Right ps -> bool (trueRoot . sudo) id (switch ss DryRun) $ A.install ps Left (AurDeps ps) -> A.displayPkgDeps ps @@ -136,7 +138,7 @@ Right (Orphans o) -> case o of Nothing -> liftIO O.displayOrphans - Just OrphanAbandon -> sudo $ liftIO orphans >>= traverse_ removePkgs . NES.nonEmptySet + Just OrphanAbandon -> sudo $ liftIO orphans >>= traverse_ removePkgs . nes Just (OrphanAdopt ps) -> O.adoptPkg ps Right Version -> liftIO $ versionInfo >>= animateVersionMsg ss auraVersion Right Languages -> displayOutputLanguages @@ -146,13 +148,18 @@ isUpgrade (SyncUpgrade _) = True isUpgrade _ = False +-- | Did the user supply a `-y` alongside an `-A` command? +isYWithA :: AurSwitch -> Bool +isYWithA AurRepoSync = True +isYWithA _ = False + displayOutputLanguages :: RIO Env () displayOutputLanguages = do ss <- asks settings - liftIO . notify ss . displayOutputLanguages_1 $ langOf ss - liftIO $ traverse_ (putTextLn . tshow) [English ..] + notify ss displayOutputLanguages_1 + traverse_ (putTextLn . tshow) [English ..] viewConfFile :: RIO Env () viewConfFile = do pth <- asks (either id id . configPathOf . commonConfigOf . settings) - void . runProcess $ proc "less" [toFilePath pth] + void . runProcess $ proc "less" [pth] diff --git a/lib/Aura/Build.hs b/lib/Aura/Build.hs --- a/lib/Aura/Build.hs +++ b/lib/Aura/Build.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} - -- | -- Module : Aura.Build -- Copyright : (c) Colin Woodbury, 2012 - 2020 @@ -15,120 +12,124 @@ ) where import Aura.Core +import Aura.IO import Aura.Languages import Aura.MakePkg import Aura.Packages.AUR (clone) import Aura.Pacman (pacman) import Aura.Settings +import Aura.Shell (chown) import Aura.Types import Aura.Utils import Control.Monad.Trans.Except -import Data.Generics.Product (field) -import Data.Semigroup.Foldable (fold1) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES -import Data.Witherable.Class (wither) +import Data.Hashable (hash) import RIO -import RIO.Directory (setCurrentDirectory) +import RIO.Directory +import RIO.FilePath import qualified RIO.NonEmpty as NEL +import RIO.Partial (fromJust) import qualified RIO.Set as S import qualified RIO.Text as T -import System.Path -import System.Path.IO +import RIO.Time import System.Process.Typed -import System.Random.MWC (GenIO, createSystemRandom, uniform) --- -srcPkgStore :: Path Absolute -srcPkgStore = fromAbsoluteFilePath "/var/cache/aura/src" +srcPkgStore :: FilePath +srcPkgStore = "/var/cache/aura/src" -- | Expects files like: \/var\/cache\/pacman\/pkg\/*.pkg.tar.xz -installPkgFiles :: NESet PackagePath -> RIO Env () +installPkgFiles :: NonEmpty PackagePath -> RIO Env () installPkgFiles files = do ss <- asks settings liftIO $ checkDBLock ss - liftIO . pacman $ ["-U"] <> map (T.pack . toFilePath . path) (toList files) <> asFlag (commonConfigOf ss) + liftIO . pacman $ ["-U"] <> map (T.pack . ppPath) (toList files) <> asFlag (commonConfigOf ss) -- | All building occurs within temp directories, -- or in a location specified by the user with flags. -buildPackages :: NESet Buildable -> RIO Env (NESet PackagePath) -buildPackages bs = do - g <- liftIO createSystemRandom - wither (build g) (toList bs) >>= maybe bad (pure . fold1) . NEL.nonEmpty - where bad = throwM $ Failure buildFail_10 +buildPackages :: NonEmpty Buildable -> RIO Env (NonEmpty PackagePath) +buildPackages bs = mapMaybeA build (NEL.toList bs) >>= maybe bad (pure . fold1) . NEL.nonEmpty + where + bad :: RIO Env a + bad = throwM $ Failure buildFail_10 -- | Handles the building of Packages. Fails nicely. -- Assumed: All dependencies are already installed. -build :: GenIO -> Buildable -> RIO Env (Maybe (NESet PackagePath)) -build g p = do - ss <- asks settings - liftIO $ notify ss (buildPackages_1 (p ^. field @"name") (langOf ss)) *> hFlush stdout - result <- liftIO $ build' ss g p +build :: Buildable -> RIO Env (Maybe (NonEmpty PackagePath)) +build p = do + logDebug $ "Building: " <> display (pnName $ bName p) + ss <- asks settings + notify ss (buildPackages_1 $ bName p) *> hFlush stdout + result <- build' ss p either buildFail (pure . Just) result -- | Should never throw an IO Exception. In theory all errors -- will come back via the @Language -> String@ function. -build' :: Settings -> GenIO -> Buildable -> IO (Either Failure (NESet PackagePath)) -build' ss g b = do +build' :: Settings -> Buildable -> RIO Env (Either Failure (NonEmpty PackagePath)) +build' ss b = do let pth = buildPathOf $ buildConfigOf ss - createDirectoryIfMissing True pth - setCurrentDirectory $ toFilePath pth - buildDir <- randomDirName g b - createDirectoryIfMissing True buildDir - setCurrentDirectory $ toFilePath buildDir + liftIO $ createDirectoryIfMissing True pth + setCurrentDirectory pth + buildDir <- liftIO $ randomDirName b + liftIO $ createDirectoryIfMissing True buildDir + setCurrentDirectory buildDir runExceptT $ do bs <- ExceptT $ cloneRepo b usr - lift . setCurrentDirectory $ toFilePath bs - lift $ overwritePkgbuild ss b - pNames <- ExceptT $ makepkg ss usr - paths <- lift . fmap NES.fromList . traverse (moveToCachePath ss) $ NES.toList pNames - lift . when (S.member AllSource . makepkgFlagsOf $ buildConfigOf ss) $ + liftIO $ setCurrentDirectory bs + liftIO $ overwritePkgbuild ss b + pNames <- ExceptT . liftIO $ makepkg ss usr + paths <- liftIO $ traverse (moveToCachePath ss) pNames + liftIO . when (S.member AllSource . makepkgFlagsOf $ buildConfigOf ss) $ makepkgSource usr >>= traverse_ moveToSourcePath pure paths - where usr = fromMaybe (User "桜木花道") . buildUserOf $ buildConfigOf ss + where + usr :: User + usr = fromMaybe (User "桜木花道") . buildUserOf $ buildConfigOf ss -- | Create a temporary directory with a semi-random name based on -- the `Buildable` we're working with. -randomDirName :: GenIO -> Buildable -> IO (Path Absolute) -randomDirName g b = do +randomDirName :: Buildable -> IO FilePath +randomDirName b = do pwd <- getCurrentDirectory - v <- uniform g :: IO Word - let dir = T.unpack (b ^. field @"name" . field @"name") <> "-" <> show v - pure $ pwd fromUnrootedFilePath dir + UTCTime _ dt <- getCurrentTime + let nh = hash . pnName $ bName b + vh = hash $ bVersion b + v = abs $ nh + vh + floor dt + dir = T.unpack (pnName $ bName b) <> "-" <> show v + pure $ pwd dir -cloneRepo :: Buildable -> User -> IO (Either Failure (Path Absolute)) +cloneRepo :: Buildable -> User -> RIO Env (Either Failure FilePath) cloneRepo pkg usr = do - currDir <- getCurrentDirectory - scriptsDir <- chown usr currDir [] *> clone pkg + currDir <- liftIO getCurrentDirectory + logDebug $ "Currently in: " <> displayShow currDir + scriptsDir <- liftIO $ chown usr currDir [] *> clone pkg case scriptsDir of - Nothing -> pure . Left . Failure . buildFail_7 $ pkg ^. field @"name" + Nothing -> pure . Left . Failure . buildFail_7 $ bName pkg Just sd -> chown usr sd ["-R"] $> Right sd -- | The user may have edited the original PKGBUILD. If they have, we need to -- overwrite what's been downloaded before calling `makepkg`. overwritePkgbuild :: Settings -> Buildable -> IO () overwritePkgbuild ss p = when (switch ss HotEdit || switch ss UseCustomizepkg) $ - writeFileBinary "PKGBUILD" $ p ^. field @"pkgbuild" . field @"pkgbuild" + writeFileBinary "PKGBUILD" . pkgbuild $ bPkgbuild p -- | Inform the user that building failed. Ask them if they want to -- continue installing previous packages that built successfully. buildFail :: Failure -> RIO Env (Maybe a) buildFail (Failure err) = do ss <- asks settings - liftIO . scold ss . err $ langOf ss - response <- liftIO $ optionalPrompt ss buildFail_6 - bool (throwM $ Failure buildFail_5) (pure Nothing) response + scold ss err + withOkay ss buildFail_6 buildFail_5 $ pure Nothing -- | Moves a file to the pacman package cache and returns its location. -moveToCachePath :: Settings -> Path Absolute -> IO PackagePath -moveToCachePath ss p = copy $> PackagePath newName +moveToCachePath :: Settings -> FilePath -> IO PackagePath +moveToCachePath ss p = copy $> fromJust (packagePath newName) where newName = pth takeFileName p pth = either id id . cachePathOf $ commonConfigOf ss copy = runProcess . setStderr closed . setStdout closed - $ proc "cp" ["--reflink=auto", toFilePath p, toFilePath newName ] + $ proc "cp" ["--reflink=auto", p, newName] -- | Moves a file to the aura src package cache and returns its location. -moveToSourcePath :: Path Absolute -> IO (Path Absolute) +moveToSourcePath :: FilePath -> IO FilePath moveToSourcePath p = renameFile p newName $> newName where newName = srcPkgStore takeFileName p diff --git a/lib/Aura/Cache.hs b/lib/Aura/Cache.hs --- a/lib/Aura/Cache.hs +++ b/lib/Aura/Cache.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TupleSections #-} -- | -- Module : Aura.Cache @@ -20,16 +20,12 @@ import Aura.Settings import Aura.Types -import Data.Generics.Product (field) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES import RIO +import RIO.Directory +import RIO.FilePath 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) --- @@ -37,8 +33,8 @@ newtype Cache = Cache { _cache :: Map SimplePkg PackagePath } -- | The default location of the package cache: \/var\/cache\/pacman\/pkg\/ -defaultPackageCache :: Path Absolute -defaultPackageCache = fromAbsoluteFilePath "/var/cache/pacman/pkg/" +defaultPackageCache :: FilePath +defaultPackageCache = "/var/cache/pacman/pkg/" -- SILENT DROPS PATHS THAT DON'T PARSE -- Maybe that's okay, since we don't know what non-package garbage files @@ -49,17 +45,17 @@ cache = Cache . M.fromList . mapMaybe (\p -> (,p) <$> simplepkg p) -- | Given a path to the package cache, yields its contents in a usable form. -cacheContents :: Path Absolute -> IO Cache -cacheContents pth = cache . map (PackagePath . (pth )) <$> getDirectoryContents pth +cacheContents :: FilePath -> IO Cache +cacheContents pth = cache . mapMaybe (packagePath . (pth )) <$> getDirectoryContents pth -- | All packages from a given `Set` who have a copy in the cache. -pkgsInCache :: Settings -> NESet PkgName -> IO (Set PkgName) +pkgsInCache :: Settings -> Set 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 + pure . S.filter (`S.member` ps) . S.map spName . M.keysSet $ _cache c -- | 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 + pure . filter (T.isInfixOf input . T.pack . ppPath) . M.elems $ _cache c 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 @@ -1,7 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} -- | -- Module : Aura.Commands.A @@ -26,6 +24,7 @@ import Aura.Colour import Aura.Core import qualified Aura.Install as I +import Aura.IO import Aura.Languages import Aura.Packages.AUR import Aura.Pkgbuild.Fetch @@ -33,15 +32,10 @@ import Aura.State (saveState) import Aura.Types import Aura.Utils -import Control.Error.Util (hush) -import Data.Aeson.Encode.Pretty (encodePretty) -import Data.Generics.Product (field) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES +import Data.Aeson import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal import Data.Versions (Versioning, prettyV, versioning) -import Lens.Micro (each, (^..)) import Linux.Arch.Aur import Network.HTTP.Client (Manager) import RIO @@ -61,19 +55,19 @@ upgradeAURPkgs :: Set PkgName -> RIO Env () upgradeAURPkgs pkgs = do ss <- asks settings - liftIO . notify ss . upgradeAURPkgs_1 $ langOf ss + notify ss upgradeAURPkgs_1 fs <- liftIO (foreigns ss) - traverse_ (upgrade pkgs) $ NES.nonEmptySet fs + traverse_ (upgrade pkgs) $ nes fs -- | Foreign packages to consider for upgrading, after "ignored packages" have -- been taken into consideration. foreigns :: Settings -> IO (Set SimplePkg) -foreigns ss = S.filter (notIgnored . view (field @"name")) <$> foreignPackages +foreigns ss = S.filter (notIgnored . spName) <$> foreignPackages where notIgnored p = not . S.member p $ ignoresOf ss -upgrade :: Set PkgName -> NESet SimplePkg -> RIO Env () +upgrade :: Set PkgName -> NonEmpty SimplePkg -> RIO Env () upgrade pkgs fs = do - logDebug $ "Considering " <> display (NES.size fs) <> " 'foreign' packages for upgrade." + logDebug $ "Considering " <> display (NEL.length fs) <> " 'foreign' packages for upgrade." unless (null pkgs) $ logDebug $ "Also installing " <> display (S.size pkgs) <> " other packages." ss <- asks settings @@ -86,44 +80,49 @@ Just a -> auraUpgrade a Nothing -> do devel <- develPkgCheck - 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) - liftIO . unless (switch ss DryRun) $ saveState ss - traverse_ I.install . NES.nonEmptySet $ S.fromList names <> pkgs <> devel + notify ss upgradeAURPkgs_2 + if null toUpgrade && null devel + then warn ss upgradeAURPkgs_3 + else do + reportPkgsToUpgrade toUpgrade (toList devel) + liftIO . unless (switch ss DryRun) $ saveState ss + traverse_ I.install . nes $ S.fromList names <> pkgs <> devel -possibleUpdates :: NESet SimplePkg -> RIO Env [(AurInfo, Versioning)] -possibleUpdates (NES.toList -> pkgs) = do - aurInfos <- aurInfo $ fmap (^. field @"name") pkgs +possibleUpdates :: NonEmpty SimplePkg -> RIO Env [(AurInfo, Versioning)] +possibleUpdates pkgs = do + aurInfos <- aurInfo $ fmap spName pkgs let !names = map aurNameOf aurInfos aurPkgs = NEL.filter (\(SimplePkg (PkgName n) _) -> n `elem` names) pkgs logDebug "Package lookup successful." - pure . filter isntMostRecent . zip aurInfos $ aurPkgs ^.. each . field @"version" + pure . filter isntMostRecent . zip aurInfos $ map spVersion aurPkgs -- | Is there an update for Aura that we could apply first? auraCheck :: [PkgName] -> RIO Env (Maybe PkgName) auraCheck ps = join <$> traverse f auraPkg - where f a = do - ss <- asks settings - bool Nothing (Just a) <$> liftIO (optionalPrompt ss auraCheck_1) - auraPkg | "aura" `elem` ps = Just "aura" - | "aura-bin" `elem` ps = Just "aura-bin" - | otherwise = Nothing + where + f :: a -> RIO Env (Maybe a) + f a = do + ss <- asks settings + bool Nothing (Just a) <$> liftIO (optionalPrompt ss auraCheck_1) + auraPkg :: Maybe PkgName + auraPkg | "aura" `elem` ps = Just "aura" + | "aura-bin" `elem` ps = Just "aura-bin" + | otherwise = Nothing + auraUpgrade :: PkgName -> RIO Env () -auraUpgrade = I.install . NES.singleton +auraUpgrade = I.install . pure develPkgCheck :: RIO Env (Set PkgName) develPkgCheck = asks settings >>= \ss -> if switch ss RebuildDevel then liftIO develPkgs else pure S.empty -- | The result of @-Ai@. -aurPkgInfo :: NESet PkgName -> RIO Env () -aurPkgInfo = aurInfo . NES.toList >=> traverse_ displayAurPkgInfo +aurPkgInfo :: NonEmpty PkgName -> RIO Env () +aurPkgInfo = aurInfo >=> traverse_ displayAurPkgInfo displayAurPkgInfo :: AurInfo -> RIO Env () -displayAurPkgInfo ai = asks settings >>= \ss -> liftIO . putTextLn $ renderAurPkgInfo ss ai <> "\n" +displayAurPkgInfo ai = asks settings >>= \ss -> putTextLn $ renderAurPkgInfo ss ai <> "\n" renderAurPkgInfo :: Settings -> AurInfo -> Text renderAurPkgInfo ss ai = dtot . colourCheck ss $ entrify ss fields entries @@ -146,14 +145,14 @@ aurPkgSearch :: Text -> RIO Env () aurPkgSearch regex = do ss <- asks settings - db <- S.map (^. field @"name" . field @"name") <$> liftIO foreignPackages + db <- S.map (pnName . spName) <$> 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 - liftIO $ traverse_ (putTextLn . renderSearch ss regex) results + traverse_ (putTextLn . renderSearch ss regex) results renderSearch :: Settings -> Text -> (AurInfo, Bool) -> Text renderSearch ss r (i, e) = searchResult @@ -171,28 +170,28 @@ Nothing -> green . pretty $ aurVersionOf i -- | The result of @-Ap@. -displayPkgbuild :: NESet PkgName -> RIO Env () +displayPkgbuild :: NonEmpty PkgName -> RIO Env () displayPkgbuild ps = do man <- asks (managerOf . settings) pbs <- catMaybes <$> traverse (liftIO . getPkgbuild man) (toList ps) - traverse_ (\p -> B.putStr p >> B.putStr "\n") $ pbs ^.. each . field @"pkgbuild" + traverse_ ((\p -> B.putStr p >> B.putStr "\n") . pkgbuild) pbs 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 :: NESet PkgName -> RIO Env () +aurJson :: NonEmpty PkgName -> RIO Env () aurJson ps = do m <- asks (managerOf . settings) - infos <- liftMaybeM (Failure connectionFailure_1) . fmap hush . liftIO $ f m ps - traverse_ (BL.putStrLn . encodePretty) infos + infos <- liftMaybeM (Failure connectFailure_1) . fmap hush . liftIO $ f m ps + traverse_ (BL.putStrLn . encode) infos where - f :: Manager -> NESet PkgName -> IO (Either ClientError [AurInfo]) - f m = info m . (^.. each . field @"name") . toList + f :: Manager -> NonEmpty PkgName -> IO (Either AurError [AurInfo]) + f m = info m . map pnName . NEL.toList -- | @https://aur.archlinux.org/cgit/aur.git/snapshot/aura-bin.tar.gz@ -fetchTarball :: NESet PkgName -> RIO Env () +fetchTarball :: NonEmpty PkgName -> RIO Env () fetchTarball ps = do ss <- asks settings traverse_ (liftIO . g ss) ps @@ -203,7 +202,7 @@ g :: Settings -> PkgName -> IO () g ss p@(PkgName pn) = urlContents (managerOf ss) (f p) >>= \case - Nothing -> warn ss . missingPkg_5 p $ langOf ss + Nothing -> warn ss $ missingPkg_5 p Just bs -> writeFileBinary (T.unpack pn <> ".tar.gz") bs ------------ @@ -212,9 +211,9 @@ reportPkgsToUpgrade :: [(AurInfo, Versioning)] -> [PkgName] -> RIO Env () reportPkgsToUpgrade ups pns = do ss <- asks settings - liftIO . notify ss . reportPkgsToUpgrade_1 $ langOf ss + notify ss reportPkgsToUpgrade_1 liftIO $ putDoc (colourCheck ss . vcat $ map f ups' <> map g devels) >> putTextLn "\n" - where devels = pns ^.. each . field @"name" + where devels = map pnName pns ups' = map (second prettyV) ups nLen = maximum $ map (T.length . aurNameOf . fst) ups <> map T.length devels vLen = maximum $ map (T.length . snd) ups' 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -- | @@ -17,16 +17,16 @@ ) where import Aura.Core (warn) +import Aura.IO import Aura.Languages import Aura.Settings import Aura.State -import Aura.Utils (optionalPrompt, putTextLn) import RIO +import RIO.Directory +import RIO.FilePath import qualified RIO.List as L import qualified RIO.NonEmpty as NEL import qualified RIO.Text as T -import System.Path (takeFileName, toFilePath, toUnrootedFilePath) -import System.Path.IO (removeFile) --- @@ -35,18 +35,19 @@ cleanStates ss (fromIntegral -> n) = do stfs <- reverse <$> getStateFiles (pinned, others) <- L.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 + warn ss $ cleanStates_4 (length stfs) + unless (null pinned) . warn ss $ cleanStates_6 (length pinned) forM_ (NEL.nonEmpty stfs) $ \stfs' -> do - let mostRecent = T.pack . toUnrootedFilePath . takeFileName $ NEL.head stfs' - warn ss . cleanStates_5 mostRecent $ langOf ss + let mostRecent = T.pack . takeFileName $ NEL.head stfs' + warn ss $ cleanStates_5 mostRecent okay <- optionalPrompt ss $ cleanStates_2 n - if | not okay -> warn ss . cleanStates_3 $ langOf ss - | otherwise -> traverse_ (removeFile . fst) . drop n $ others + if not okay + then warn ss cleanStates_3 + else traverse_ (removeFile . fst) . drop n $ others where p :: (a, Maybe PkgState) -> Bool p = maybe False pinnedOf . snd -- | The result of @-Bl@. listStates :: IO () -listStates = getStateFiles >>= traverse_ (putTextLn . T.pack . toFilePath) +listStates = getStateFiles >>= traverse_ (putTextLn . T.pack) 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 @@ -1,6 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Aura.Commands.C @@ -21,39 +21,39 @@ import Aura.Cache import Aura.Colour (red) import Aura.Core +import Aura.IO import Aura.Languages import Aura.Pacman (pacman) import Aura.Settings +import Aura.Shell import Aura.State import Aura.Types -import Aura.Utils -import Data.Generics.Product (field) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES -import Lens.Micro ((^?), _Just) +import Aura.Utils (nes) import RIO +import RIO.Directory import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.NonEmpty as NEL import qualified RIO.Set as S import qualified RIO.Text as T -import System.Path -import System.Path.IO (copyFile, doesDirectoryExist, removeFile) --- -- | Interactive. Gives the user a choice as to exactly what versions -- they want to downgrade to. -downgradePackages :: NESet PkgName -> RIO Env () +downgradePackages :: NonEmpty PkgName -> RIO Env () downgradePackages pkgs = do - ss <- asks settings + ss <- asks settings let cachePath = either id id . cachePathOf $ commonConfigOf ss - reals <- liftIO $ pkgsInCache ss pkgs - traverse_ (report red reportBadDowngradePkgs_1) . NEL.nonEmpty . toList $ NES.toSet pkgs S.\\ reals + reals <- liftIO $ pkgsInCache ss pkgsSet + traverse_ (report red reportBadDowngradePkgs_1) . nes $ pkgsSet S.\\ reals unless (null reals) $ do cache <- liftIO $ cacheContents cachePath choices <- traverse (getDowngradeChoice cache) $ toList reals - liftIO . pacman $ "-U" : asFlag (commonConfigOf ss) <> map (T.pack . toFilePath . path) choices + liftIO . pacman $ "-U" : asFlag (commonConfigOf ss) <> map (T.pack . ppPath) choices + where + pkgsSet :: Set PkgName + pkgsSet = S.fromList $ NEL.toList pkgs -- | For a given package, get a choice from the user about which version of it to -- downgrade to. @@ -63,8 +63,8 @@ Nothing -> throwM . Failure $ reportBadDowngradePkgs_2 pkg Just choices -> do ss <- asks settings - liftIO . notify ss . getDowngradeChoice_1 pkg $ langOf ss - liftIO $ getSelection (T.pack . toFilePath . path) choices + notify ss $ getDowngradeChoice_1 pkg + liftIO $ getSelection (T.pack . ppPath) choices getChoicesFromCache :: Cache -> PkgName -> [PackagePath] getChoicesFromCache (Cache cache) p = L.sort . M.elems $ M.filterWithKey (\(SimplePkg pn _) _ -> p == pn) cache @@ -74,39 +74,39 @@ searchCache ps = do ss <- asks settings matches <- liftIO $ cacheMatches ss ps - liftIO . traverse_ (putTextLn . T.pack . toFilePath . path) $ L.sort matches + traverse_ (putTextLn . T.pack . ppPath) $ L.sort matches -- | The destination folder must already exist for the back-up to begin. -backupCache :: Path Absolute -> RIO Env () +backupCache :: FilePath -> RIO Env () backupCache dir = do exists <- liftIO $ doesDirectoryExist dir - if | not exists -> throwM $ Failure backupCache_3 - | otherwise -> confirmBackup dir >>= backup dir + if not exists + then throwM $ Failure backupCache_3 + else confirmBackup dir >>= backup dir -confirmBackup :: Path Absolute -> RIO Env Cache +confirmBackup :: FilePath -> RIO Env Cache confirmBackup dir = do ss <- asks settings 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 + notify ss $ backupCache_4 dir + notify ss $ backupCache_5 (M.size $ _cache cache) + withOkay ss backupCache_6 backupCache_7 $ pure cache -backup :: Path Absolute -> Cache -> RIO Env () +backup :: FilePath -> Cache -> RIO Env () backup dir (Cache cache) = do ss <- asks settings - liftIO . notify ss . backupCache_8 $ langOf ss - liftIO $ putTextLn "" -- So that the cursor can rise at first. + notify ss backupCache_8 + 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 :: Path Absolute -> [PackagePath] -> Int -> RIO Env () +copyAndNotify :: FilePath -> [PackagePath] -> Int -> RIO Env () copyAndNotify _ [] _ = pure () -copyAndNotify dir (PackagePath p : ps) n = do +copyAndNotify dir (p : ps) n = do ss <- asks settings liftIO $ raiseCursorBy 1 - liftIO . warn ss . copyAndNotify_1 n $ langOf ss - liftIO $ copyFile p dir + warn ss $ copyAndNotify_1 n + liftIO $ copyFile (ppPath p) dir copyAndNotify dir ps $ n + 1 -- | Keeps a certain number of package files in the cache according to @@ -115,41 +115,54 @@ cleanCache toSave | toSave == 0 = do ss <- asks settings - liftIO . warn ss . cleanCache_2 $ langOf ss + warn ss cleanCache_2 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 + let cachePath = either id id . cachePathOf $ commonConfigOf ss + -- Measuring the cache size before removal -- + beforeCache@(Cache c) <- liftIO $ cacheContents cachePath + beforeBytes <- liftIO $ cacheSize beforeCache + notify ss $ cleanCache_7 (fromIntegral $ M.size c) beforeBytes + -- Proceed with user confirmation -- + warn ss $ cleanCache_3 toSave + withOkay ss cleanCache_4 cleanCache_5 $ do + clean toSave beforeCache + afterCache <- liftIO $ cacheContents cachePath + afterBytes <- liftIO $ cacheSize afterCache + notify ss $ cleanCache_8 (beforeBytes - afterBytes) -clean :: Int -> RIO Env () -clean toSave = do +-- | How big, in megabytes, are all the files in the cache? +cacheSize :: Cache -> IO Word +cacheSize (Cache cache) = do + bytes <- foldl' (+) 0 <$> traverse (getFileSize . ppPath) (M.elems cache) + pure . floor @Double $ fromIntegral bytes / 1_048_576 -- 1024 * 1024 + +clean :: Word -> Cache -> RIO Env () +clean toSave (Cache cache) = do ss <- asks settings - liftIO . notify ss . cleanCache_6 $ langOf ss - let cachePath = either id id . cachePathOf $ commonConfigOf ss - (Cache cache) <- liftIO $ cacheContents cachePath + notify ss cleanCache_6 let !files = M.elems cache - grouped = take toSave . reverse <$> groupByName files + grouped = take (fromIntegral toSave) . reverse <$> groupByName files toRemove = files L.\\ fold grouped - liftIO $ traverse_ (removeFile . path) toRemove + liftIO $ traverse_ (removeFile . ppPath) toRemove -- | Only package files with a version not in any PkgState will be -- removed. cleanNotSaved :: RIO Env () cleanNotSaved = do ss <- asks settings - liftIO . notify ss . cleanNotSaved_1 $ langOf ss + notify ss cleanNotSaved_1 sfs <- liftIO getStateFiles states <- fmap catMaybes . liftIO $ traverse readState sfs let cachePath = either id id . cachePathOf $ commonConfigOf ss (Cache cache) <- liftIO $ cacheContents cachePath let duds = M.filterWithKey (\p _ -> any (inState p) states) cache prop <- liftIO . optionalPrompt ss $ cleanNotSaved_2 $ M.size duds - when prop . liftIO . traverse_ (removeFile . path) $ M.elems duds + when prop . liftIO . traverse_ (removeFile . ppPath) $ M.elems duds -- | Typically takes the contents of the package cache as an argument. groupByName :: [PackagePath] -> [[PackagePath]] groupByName pkgs = L.groupBy sameBaseName $ L.sort pkgs where sameBaseName a b = baseName a == baseName b - baseName p = simplepkg p ^? _Just . field @"name" + baseName p = spName <$> simplepkg p 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 @@ -1,7 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} - -- | -- Module : Aura.Commands.L -- Copyright : (c) Colin Woodbury, 2012 - 2020 @@ -18,18 +14,16 @@ import Aura.Colour (dtot, red) import Aura.Core (Env(..), report) +import Aura.IO import Aura.Languages import Aura.Settings import Aura.Types (PkgName(..)) import Aura.Utils -import Data.Generics.Product (field) -import Data.Set.NonEmpty (NESet) import Data.Text.Prettyprint.Doc import RIO hiding (FilePath) import qualified RIO.NonEmpty as NEL import qualified RIO.Text as T import qualified RIO.Text.Partial as T -import System.Path (toFilePath) import System.Process.Typed (proc, runProcess) --- @@ -46,25 +40,25 @@ -- | Pipes the pacman log file through a @less@ session. viewLogFile :: RIO Env () viewLogFile = do - pth <- asks (toFilePath . either id id . logPathOf . commonConfigOf . settings) + pth <- asks (either id id . logPathOf . commonConfigOf . settings) void . runProcess $ proc "less" [pth] -- | 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 + let pth = either id id . logPathOf $ commonConfigOf ss logFile <- T.lines . decodeUtf8Lenient <$> readFileBinary pth traverse_ putTextLn $ searchLines input logFile -- | The result of @-Li@. -logInfoOnPkg :: NESet PkgName -> RIO Env () +logInfoOnPkg :: NonEmpty PkgName -> RIO Env () logInfoOnPkg pkgs = do ss <- asks settings - let pth = toFilePath . either id id . logPathOf $ commonConfigOf ss + let pth = either id id . logPathOf $ commonConfigOf ss logFile <- Log . T.lines . decodeUtf8Lenient <$> readFileBinary pth let (bads, goods) = fmapEither (logLookup logFile) $ toList pkgs traverse_ (report red reportNotInLog_1) $ NEL.nonEmpty bads - liftIO . traverse_ putTextLn $ map (renderEntry ss) goods + traverse_ (putTextLn . renderEntry ss) goods logLookup :: Log -> PkgName -> Either PkgName LogEntry logLookup (Log lns) p = case matches of @@ -74,7 +68,7 @@ , firstInstall = T.take 16 $ T.tail h , upgrades = fromIntegral . length $ filter (T.isInfixOf " upgraded ") t , recent = reverse . take 5 $ reverse t } - where matches = filter (T.isInfixOf (" " <> (p ^. field @"name") <> " (")) lns + where matches = filter (T.isInfixOf (" " <> pnName p <> " (")) lns renderEntry :: Settings -> LogEntry -> Text renderEntry ss (LogEntry (PkgName pn) fi us rs) = 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE DataKinds #-} - -- | -- Module : Aura.Commands.O -- Copyright : (c) Colin Woodbury, 2012 - 2020 @@ -11,19 +9,17 @@ module Aura.Commands.O ( displayOrphans, adoptPkg ) where import Aura.Core (Env(..), orphans, sudo) +import Aura.IO (putTextLn) 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_ (putTextLn . view (field @"name")) +displayOrphans = orphans >>= traverse_ (putTextLn . pnName) -- | Identical to @-D --asexplicit@. -adoptPkg :: NESet PkgName -> RIO Env () +adoptPkg :: NonEmpty 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 @@ -1,7 +1,5 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE MultiWayIf #-} -- | -- Module : Aura.Core @@ -30,27 +28,25 @@ ) where import Aura.Colour +import Aura.IO import Aura.Languages import Aura.Pacman import Aura.Pkgbuild.Editing (hotEdit) import Aura.Settings +import Aura.Shell import Aura.Types import Aura.Utils import Control.Monad.Trans.Maybe import Data.Bifunctor (bimap) -import Data.Generics.Product (field, typed) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal -import Data.These (These(..)) import RIO hiding ((<>)) import qualified RIO.ByteString as B +import RIO.Directory (doesFileExist) import qualified RIO.List as L import qualified RIO.NonEmpty as NEL import qualified RIO.Set as S import qualified RIO.Text as T -import System.Path.IO (doesFileExist) --- @@ -64,15 +60,18 @@ data Env = Env { repository :: !Repository, settings :: !Settings } deriving stock (Generic) +settingsL :: Lens' Env Settings +settingsL f e = (\ss -> e { settings = ss }) <$> f (settings e) + instance HasLogFunc Env where - logFuncL = typed @Settings . typed @LogFunc + logFuncL = settingsL . logFuncOfL -- | A `Repository` is a place where packages may be fetched from. Multiple -- repositories can be combined with the `Semigroup` instance. Checks packages -- in batches for efficiency. data Repository = Repository { repoCache :: !(TVar (Map PkgName Package)) - , repoLookup :: Settings -> NESet PkgName -> IO (Maybe (Set PkgName, Set Package)) } + , repoLookup :: Settings -> NonEmpty PkgName -> IO (Maybe (Set PkgName, Set Package)) } -- NOTE The `repoCache` value passed to the combined `Repository` constructor is -- irrelevant, and only sits there for typechecking purposes. Each `Repository` @@ -80,7 +79,7 @@ instance Semigroup Repository where a <> b = Repository (repoCache a) $ \ss ps -> runMaybeT $ do items@(bads, goods) <- MaybeT $ repoLookup a ss ps - case NES.nonEmptySet bads of + case nes bads of Nothing -> pure items Just bads' -> second (goods <>) <$> MaybeT (repoLookup b ss bads') @@ -89,15 +88,21 @@ --------------------------------- -- | Partition a list of packages into pacman and buildable groups. Yes, this is -- the correct signature. As far as this function (in isolation) is concerned, --- there is no way to guarantee that the list of `NESet`s will itself be +-- there is no way to guarantee that the list of `NonEmpty`s will itself be -- non-empty. -partitionPkgs :: NonEmpty (NESet Package) -> ([Prebuilt], [NESet Buildable]) -partitionPkgs = bimap fold f . L.unzip . map g . toList - where g = fmapEither toEither . toList - f = mapMaybe (fmap NES.fromList . NEL.nonEmpty) - toEither (FromAUR b) = Right b - toEither (FromRepo b) = Left b +partitionPkgs :: NonEmpty (NonEmpty Package) -> ([Prebuilt], [NonEmpty Buildable]) +partitionPkgs = bimap fold f . L.unzip . map g . NEL.toList + where + g :: NonEmpty Package -> ([Prebuilt], [Buildable]) + g = fmapEither toEither . NEL.toList + f :: [[a]] -> [NonEmpty a] + f = mapMaybe NEL.nonEmpty + + toEither :: Package -> Either Prebuilt Buildable + toEither (FromAUR b) = Right b + toEither (FromRepo b) = Left b + -- | Package a Buildable, running the customization handler first. packageBuildable :: Settings -> Buildable -> IO Package packageBuildable ss b = FromAUR <$> hotEdit ss b @@ -130,64 +135,68 @@ -- | Any package whose name is suffixed by git, hg, svn, darcs, cvs, or bzr. develPkgs :: IO (Set PkgName) -develPkgs = S.filter isDevelPkg . S.map (^. field @"name") <$> foreignPackages +develPkgs = S.filter isDevelPkg . S.map spName <$> foreignPackages where isDevelPkg (PkgName pkg) = any (`T.isSuffixOf` pkg) suffixes suffixes = ["-git", "-hg", "-svn", "-darcs", "-cvs", "-bzr"] -- | Returns what it was given if the package is already installed. -- Reasoning: Using raw bools can be less expressive. isInstalled :: PkgName -> IO (Maybe PkgName) -isInstalled pkg = bool Nothing (Just pkg) <$> pacmanSuccess ["-Qq", pkg ^. field @"name"] +isInstalled pkg = bool Nothing (Just pkg) <$> pacmanSuccess ["-Qq", pnName pkg] -- | An @-Rsu@ call. -removePkgs :: NESet PkgName -> RIO Env () +removePkgs :: NonEmpty PkgName -> RIO Env () removePkgs pkgs = do pacOpts <- asks (commonConfigOf . settings) liftIO . pacman $ ["-Rsu"] <> asFlag pkgs <> asFlag pacOpts -- | Depedencies which are not installed, or otherwise provided by some -- installed package. -newtype Unsatisfied = Unsatisfied (NESet Dep) +newtype Unsatisfied = Unsatisfied (NonEmpty Dep) -- | The opposite of `Unsatisfied`. -newtype Satisfied = Satisfied (NESet Dep) +newtype Satisfied = Satisfied (NonEmpty Dep) -- | Similar to `isSatisfied`, but dependencies are checked in a batch, since -- @-T@ can accept multiple inputs. -areSatisfied :: NESet Dep -> IO (These Unsatisfied Satisfied) +areSatisfied :: NonEmpty Dep -> IO (These Unsatisfied Satisfied) areSatisfied ds = do unsats <- S.fromList . mapMaybe parseDep <$> unsat - pure . bimap Unsatisfied Satisfied $ NES.partition (`S.member` unsats) ds + pure . bimap Unsatisfied Satisfied $ partNonEmpty (f unsats) ds where unsat :: IO [Text] unsat = pacmanLines $ "-T" : map renderedDep (toList ds) + f :: Set Dep -> Dep -> These Dep Dep + f unsats d | S.member d unsats = This d + | otherwise = That d + -- | 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) *> B.getLine *> checkDBLock ss + when locked $ warn ss checkDBLock_1 *> B.getLine *> checkDBLock ss ------- -- MISC -- Too specific for `Utilities.hs` or `Aura.Utils` ------- -- | Print some message in green with Aura flair. -notify :: Settings -> Doc AnsiStyle -> IO () -notify ss = putStrLnA ss . green +notify :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m () +notify ss msg = putStrLnA ss $ green (msg $ langOf ss) -- | Print some message in yellow with Aura flair. -warn :: Settings -> Doc AnsiStyle -> IO () -warn ss = putStrLnA ss . yellow +warn :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m () +warn ss msg = putStrLnA ss $ yellow (msg $ langOf ss) -- | Print some message in red with Aura flair. -scold :: Settings -> Doc AnsiStyle -> IO () -scold ss = putStrLnA ss . red +scold :: MonadIO m => Settings -> (Language -> Doc AnsiStyle) -> m () +scold ss msg = putStrLnA ss $ red (msg $ langOf ss) -- | Report a message with multiple associated items. Usually a list of -- naughty packages. report :: (Doc AnsiStyle -> Doc AnsiStyle) -> (Language -> Doc AnsiStyle) -> NonEmpty PkgName -> RIO Env () report c msg pkgs = do ss <- asks settings - liftIO . putStrLnA ss . c . msg $ langOf ss - liftIO . putTextLn . dtot . colourCheck ss . vsep . map (cyan . pretty . view (field @"name")) $ toList pkgs + putStrLnA ss . c . msg $ langOf ss + putTextLn . dtot . colourCheck ss . vsep . map (cyan . pretty . pnName) $ 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,7 +1,7 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} -- | -- Module : Aura.Dependencies @@ -18,17 +18,12 @@ import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM import Algebra.Graph.ToGraph (isAcyclic) import Aura.Core +import Aura.IO import Aura.Languages import Aura.Settings import Aura.Types -import Aura.Utils (maybe', putText) -import Control.Error.Util (note) -import Data.Generics.Product (field) -import Data.Semigroup.Foldable (foldMap1) -import Data.Set.NonEmpty (pattern IsEmpty, pattern IsNonEmpty, NESet) -import qualified Data.Set.NonEmpty as NES -import Data.These (these) -import Data.Versions +import Aura.Utils +import Data.Versions hiding (Lens') import Lens.Micro import RIO import qualified RIO.Map as M @@ -44,97 +39,109 @@ , satisfied :: Set PkgName } deriving (Generic) +toInstallL :: Lens' Resolution (Map PkgName Package) +toInstallL f r = (\m -> r { toInstall = m }) <$> f (toInstall r) + +satisfiedL :: Lens' Resolution (Set PkgName) +satisfiedL f r = (\s -> r { satisfied = s }) <$> f (satisfied r) + -- | Given some `Package`s, determine its full dependency graph. -- The graph is collapsed into layers of packages which are not -- interdependent, and thus can be built and installed as a group. -- -- Deeper layers of the result list (generally) depend on the previous layers. -resolveDeps :: Repository -> NESet Package -> RIO Env (NonEmpty (NESet Package)) +resolveDeps :: Repository -> NonEmpty Package -> RIO Env (NonEmpty (NonEmpty Package)) resolveDeps repo ps = do ss <- asks settings 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") + Resolution m s <- maybe (throwM $ Failure connectFailure_1) pure res + unless (length ps == length m) $ putText "\n" let de = conflicts ss m s 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. -resolveDeps' :: Settings -> Repository -> NESet Package -> IO Resolution +resolveDeps' :: Settings -> Repository -> NonEmpty Package -> IO Resolution resolveDeps' ss repo ps = resolve (Resolution mempty mempty) ps where -- | Only searches for packages that we haven't checked yet. - resolve :: Resolution -> NESet Package -> IO Resolution - resolve r@(Resolution m _) xs = maybe' (pure r) (NES.nonEmptySet goods) $ \goods' -> do - let m' = M.fromList (map (pname &&& id) $ toList goods') - r' = r & field @"toInstall" %~ (<> m') + resolve :: Resolution -> NonEmpty Package -> IO Resolution + resolve r@(Resolution m _) xs = maybe' (pure r) (NEL.nonEmpty goods) $ \goods' -> do + let m' = M.fromList . map (pname &&& id) $ toList goods' + r' = r & toInstallL %~ (<> m') these (const $ pure r') (satisfy r') (const $ satisfy r') $ dividePkgs goods' where - goods :: Set Package - goods = NES.filter (\p -> not $ pname p `M.member` m) xs + goods :: [Package] + goods = NEL.filter (\p -> not $ pname p `M.member` m) xs -- | All dependencies from all potential `Buildable`s. - allDeps :: NESet Buildable -> Set Dep - allDeps = foldMap1 (S.fromList . (^.. field @"deps" . each)) + allDeps :: NonEmpty Buildable -> Set Dep + allDeps = foldMap1 (S.fromList . (^.. to bDeps . each)) -- | Deps which are not yet queued for install. freshDeps :: Resolution -> Set Dep -> Set Dep freshDeps (Resolution m s) = S.filter f where f :: Dep -> Bool - f d = let n = d ^. field @"name" in not $ M.member n m || S.member n s + f d = let n = dName d in not $ M.member n m || S.member n s -- | Consider only "unsatisfied" deps. - satisfy :: Resolution -> NESet Buildable -> IO Resolution - satisfy r bs = maybe' (pure r) (NES.nonEmptySet . freshDeps r $ allDeps bs) $ + satisfy :: Resolution -> NonEmpty Buildable -> IO Resolution + satisfy r bs = maybe' (pure r) (nes . freshDeps r $ allDeps bs) $ areSatisfied >=> these (lookups r) (pure . r') (\uns sat -> lookups (r' sat) uns) where r' :: Satisfied -> Resolution - r' (Satisfied sat) = r & field @"satisfied" %~ (<> f sat) + r' (Satisfied sat) = r & satisfiedL %~ (<> f sat) - f :: NESet Dep -> Set PkgName - f = S.map (^. field @"name") . NES.toSet + -- | Unique names of some dependencies. + f :: NonEmpty Dep -> Set PkgName + f = S.fromList . NEL.toList . NEL.map dName -- TODO What about if `repoLookup` reports deps that don't exist? -- i.e. the left-hand side of the tuple. -- | Lookup unsatisfied deps and recurse the entire lookup process. lookups :: Resolution -> Unsatisfied -> IO Resolution lookups r (Unsatisfied ds) = do - let names = NES.map (^. field @"name") ds + let names = NEL.map dName ds repoLookup repo ss names >>= \case Nothing -> throwString "AUR Connection Error" - Just (_, IsEmpty) -> throwString "Non-existant deps" - Just (_, IsNonEmpty goods) -> resolve r goods + Just (_, could) -> case nes could of + Nothing -> throwString "Non-existant deps" + Just goods -> resolve r goods conflicts :: Settings -> Map PkgName Package -> Set PkgName -> [DepError] conflicts ss m s = foldMap f m where pm :: Map PkgName Package - pm = M.fromList $ map (\p -> (pprov p ^. field @"provides", p)) $ toList m + pm = M.fromList $ map (\p -> (provides $ pprov p, p)) $ toList m f :: Package -> [DepError] f (FromRepo _) = [] - f (FromAUR b) = flip mapMaybe (b ^. field @"deps") $ \d -> - let dn = d ^. field @"name" + f (FromAUR b) = flip mapMaybe (bDeps b) $ \d -> + let dn = dName d -- Don't do conflict checks for deps which are known to be satisfied on -- the system. - in if | S.member dn s -> Nothing - | otherwise -> case M.lookup dn m <|> M.lookup dn pm of - Nothing -> Just $ NonExistant dn - Just p -> realPkgConflicts ss (b ^. field @"name") p d + in if S.member dn s then Nothing + else case M.lookup dn m <|> M.lookup dn pm of + Nothing -> Just . NonExistant dn $ bName b + Just p -> realPkgConflicts ss (bName b) p d -sortInstall :: Map PkgName Package -> Either Failure (NonEmpty (NESet Package)) +sortInstall :: Map PkgName Package -> Either Failure (NonEmpty (NonEmpty Package)) sortInstall m = case cycles depGraph of - [] -> note (Failure missingPkg_3) . NEL.nonEmpty . mapMaybe NES.nonEmptySet $ batch depGraph + [] -> note (Failure missingPkg_3) . NEL.nonEmpty . mapMaybe nes $ batch depGraph cs -> Left . Failure . missingPkg_4 $ map (NEL.map pname . NAM.vertexList1) cs - where f (FromRepo _) = [] - f p@(FromAUR b) = mapMaybe (\d -> fmap (p,) $ (d ^. field @"name") `M.lookup` m) $ b ^. field @"deps" -- TODO handle "provides"? - depGraph = overlay connected singles - elems = M.elems m - connected = edges $ foldMap f elems - singles = overlays $ map vertex elems + where + f :: Package -> [(Package, Package)] + f (FromRepo _) = [] + f p@(FromAUR b) = mapMaybe (\d -> fmap (p,) $ dName d `M.lookup` m) + $ bDeps b -- TODO handle "provides"? + depGraph = overlay connected singles + elems = M.elems m + connected = edges $ foldMap f elems + singles = overlays $ map vertex elems + cycles :: Ord a => AdjacencyMap a -> [NAM.AdjacencyMap a] cycles = filter (not . isAcyclic) . vertexList . scc @@ -161,7 +168,7 @@ | otherwise = Nothing where pn = pname pkg curVer = pver pkg & release .~ [] - reqVer = (dep ^. field @"demand") & _VersionDemand . release .~ [] + reqVer = dDemand dep & _VersionDemand . release .~ [] lang = langOf ss toIgnore = ignoresOf ss failMsg1 = getRealPkgConflicts_2 pn lang diff --git a/lib/Aura/Diff.hs b/lib/Aura/Diff.hs --- a/lib/Aura/Diff.hs +++ b/lib/Aura/Diff.hs @@ -10,7 +10,6 @@ import Aura.Settings import RIO -import System.Path (Absolute, Path, toFilePath) import System.Process.Typed (proc, runProcess) --- @@ -19,6 +18,8 @@ -- Output will be coloured unless colour is deactivated by -- `--color never` or by detection of a non-terminal output -- target. -diff :: MonadIO m => Settings -> Path Absolute -> Path Absolute -> m () -diff ss f1 f2 = void . runProcess . proc "diff" $ c <> ["-u", toFilePath f1, toFilePath f2] - where c = bool ["--color"] [] $ shared ss (Colour Never) +diff :: MonadIO m => Settings -> FilePath -> FilePath -> m () +diff ss f1 f2 = void . runProcess . proc "diff" $ c <> ["-u", f1, f2] + where + c :: [FilePath] + c = bool ["--color"] [] $ shared ss (Colour Never) diff --git a/lib/Aura/IO.hs b/lib/Aura/IO.hs new file mode 100644 --- /dev/null +++ b/lib/Aura/IO.hs @@ -0,0 +1,105 @@ +-- | +-- Module : Aura.IO +-- Copyright : (c) Colin Woodbury, 2012 - 2020 +-- License : GPL3 +-- Maintainer: Colin Woodbury +-- +-- User-facing input and output utilities. + +module Aura.IO where + +import Aura.Colour +import Aura.Languages (whitespace, yesNoMessage, yesPattern) +import Aura.Settings +import Aura.Types (Failure(..), Language) +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal +import RIO +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import RIO.List.Partial (maximum) +import qualified RIO.Text as T +import Text.Printf (printf) + +--- + +---------------- +-- CUSTOM OUTPUT +---------------- +-- | Print a `Doc` with Aura flair after performing a `colourCheck`. +putStrLnA :: MonadIO m => Settings -> Doc AnsiStyle -> m () +putStrLnA ss d = putStrA ss $ d <> hardline + +-- | Will remove all colour annotations if the user specified @--color=never@. +putStrA :: MonadIO m => Settings -> Doc AnsiStyle -> m () +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. +colourCheck :: Settings -> Doc ann -> Doc ann +colourCheck ss | shared ss (Colour Never) = unAnnotate + | shared ss (Colour Always) = id + | isTerminal ss = id + | otherwise = unAnnotate + +putText :: MonadIO m => Text -> m () +putText = B.putStr . encodeUtf8 + +putTextLn :: MonadIO m => Text -> m () +putTextLn = BL.putStrLn . BL.fromStrict . encodeUtf8 + +-- | Format two lists into two nice rows a la `-Qi` or `-Si`. +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 + +-- | Right-pads strings according to the longest string in the group. +padding :: Settings -> [Text] -> [Text] +padding ss fs = map (T.justifyLeft longest ws) fs + where ws = whitespace $ langOf ss + longest = maximum $ map T.length fs + +---------- +-- PROMPTS +---------- +yesNoPrompt :: Settings -> Doc AnsiStyle -> IO Bool +yesNoPrompt ss msg = do + putStrA ss . yellow $ msg <+> yesNoMessage (langOf ss) <> " " + hFlush stdout + response <- decodeUtf8Lenient <$> B.getLine + pure $ isAffirmative (langOf ss) response + +-- | An empty response emplies "yes". +isAffirmative :: Language -> Text -> Bool +isAffirmative l t = T.null t || elem (T.toCaseFold t) (yesPattern l) + +-- | Doesn't prompt when `--noconfirm` is used. +optionalPrompt :: Settings -> (Language -> Doc AnsiStyle) -> IO Bool +optionalPrompt ss msg | shared ss NoConfirm = pure True + | otherwise = yesNoPrompt ss (msg $ langOf ss) + +withOkay + :: Settings + -> (Language -> Doc AnsiStyle) + -> (Language -> Doc AnsiStyle) + -> RIO e a + -> RIO e a +withOkay ss asking failed f = do + okay <- liftIO $ optionalPrompt ss asking + bool (throwM $ Failure failed) f okay + +-- | Given a number of selections, allows the user to choose one. +getSelection :: Foldable f => (a -> Text) -> f a -> IO a +getSelection f choiceLabels = do + let quantity = length choiceLabels + 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 + BL.putStr ">> " + hFlush stdout + userChoice <- decodeUtf8Lenient <$> B.getLine + case userChoice `lookup` choices of + Just valid -> pure valid + Nothing -> getSelection f choiceLabels -- Ask again. diff --git a/lib/Aura/Install.hs b/lib/Aura/Install.hs --- a/lib/Aura/Install.hs +++ b/lib/Aura/Install.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Aura.Install @@ -24,6 +21,7 @@ import Aura.Core import Aura.Dependencies (resolveDeps) import Aura.Diff (diff) +import Aura.IO import Aura.Languages import Aura.Packages.AUR (aurLookup) import Aura.Pacman (pacman, pacmanSuccess) @@ -32,15 +30,12 @@ import Aura.Pkgbuild.Security import Aura.Settings import Aura.Types -import Aura.Utils (fmapEither, optionalPrompt, putTextLn) +import Aura.Utils import Control.Scheduler (Comp(..), traverseConcurrently) -import Data.Generics.Product (HasField'(..), field, super) -import Data.Semigroup.Foldable (fold1) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal import Language.Bash.Pretty (prettyText) import Language.Bash.Syntax (ShellCommand) -import Lens.Micro (each, (^..)) import RIO hiding (FilePath) import RIO.Directory (setCurrentDirectory) import qualified RIO.List as L @@ -48,24 +43,23 @@ import qualified RIO.NonEmpty as NEL import qualified RIO.Set as S import qualified RIO.Text as T -import System.Path (fromAbsoluteFilePath) --- --- | High level 'install' command. Handles installing --- dependencies. -install :: NESet PkgName -> RIO Env () +-- | High level 'install' command. Handles installing dependencies. +install :: NonEmpty PkgName -> RIO Env () install pkgs = do ss <- asks settings - if | not $ switch ss DeleteMakeDeps -> install' pkgs - | otherwise -> do -- `-a` was used. - orphansBefore <- liftIO orphans - install' pkgs - orphansAfter <- liftIO orphans - let makeDeps = NES.nonEmptySet (orphansAfter S.\\ orphansBefore) - traverse_ (\mds -> liftIO (notify ss . removeMakeDepsAfter_1 $ langOf ss) *> removePkgs mds) makeDeps + if not $ switch ss DeleteMakeDeps + then install' pkgs + else do -- `-a` was used. + orphansBefore <- liftIO orphans + install' pkgs + orphansAfter <- liftIO orphans + let makeDeps = nes $ orphansAfter S.\\ orphansBefore + traverse_ (\mds -> liftIO (notify ss removeMakeDepsAfter_1) *> removePkgs mds) makeDeps -install' :: NESet PkgName -> RIO Env () +install' :: NonEmpty PkgName -> RIO Env () install' pkgs = do rpstry <- asks repository ss <- asks settings @@ -73,34 +67,37 @@ (pure S.empty) (S.fromList . catMaybes <$> liftIO (traverseConcurrently Par' isInstalled $ toList pkgs)) $ shared ss NeededOnly - let !pkgs' = NES.toSet pkgs - 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 -> 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) . 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 -> throwM $ Failure install_2 - Just toBuild' -> do - 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 <- 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_ (liftIO . storePkgbuilds . fold1) mbuildPkgs - traverse_ buildAndInstall mbuildPkgs + let !pkgs' = S.fromList $ NEL.toList pkgs + if shared ss NeededOnly && unneeded == pkgs' + then warn ss install_2 + else do + let (ignored, notIgnored) = S.partition (`S.member` ignoresOf ss) pkgs' + installAnyway <- confirmIgnored ignored + case nes $ (notIgnored <> installAnyway) S.\\ unneeded of + Nothing -> warn ss install_2 + Just toInstall -> do + traverse_ (report yellow reportUnneededPackages_1) . NEL.nonEmpty + $ toList unneeded + (nons, toBuild) <- liftMaybeM (Failure connectFailure_1) . liftIO + $ aurLookup (managerOf ss) toInstall + pkgbuildDiffs toBuild + traverse_ (report red reportNonPackages_1) . NEL.nonEmpty $ toList nons + let !explicits = bool (S.map (\b -> b { bIsExplicit = True }) toBuild) toBuild + $ switch ss AsDeps + case nes explicits of + Nothing -> throwM $ Failure install_2 + Just toBuild' -> do + notify ss install_5 *> 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) . withOkay ss install_3 install_4 $ do + traverse_ repoInstall $ NEL.nonEmpty repoPkgs + let !mbuildPkgs = NEL.nonEmpty buildPkgs + traverse_ (liftIO . storePkgbuilds . fold1) mbuildPkgs + traverse_ buildAndInstall mbuildPkgs -- | Determine if a package's PKGBUILD might contain malicious bash code. analysePkgbuild :: Buildable -> RIO Env () @@ -109,96 +106,122 @@ let f = do yes <- liftIO $ optionalPrompt ss security_6 when yes . throwM $ Failure security_7 - case parsedPB $ b ^. field @"pkgbuild" of - Nothing -> liftIO (warn ss (security_1 (b ^. field @"name") $ langOf ss)) *> f + case parsedPB $ bPkgbuild b of + Nothing -> warn ss (security_1 $ bName b) *> f Just l -> case bannedTerms l of [] -> pure () bts -> do - liftIO $ scold ss (security_5 (b ^. field @"name") $ langOf ss) + scold ss . security_5 $ bName b liftIO $ traverse_ (displayBannedTerms ss) bts f displayBannedTerms :: Settings -> (ShellCommand, BannedTerm) -> IO () displayBannedTerms ss (stmt, b) = do putTextLn . T.pack $ "\n " <> prettyText stmt <> "\n" - warn ss $ reportExploit b lang - where lang = langOf ss + warn ss $ reportExploit b -- | Give anything that was installed as a dependency the /Install Reason/ of -- "Installed as a dependency for another package". -annotateDeps :: NESet Buildable -> IO () -annotateDeps bs = unless (null bs') . void . pacmanSuccess $ ["-D", "--asdeps"] <> asFlag (bs' ^.. each . field @"name") - where bs' = filter (not . isExplicit) $ toList bs +annotateDeps :: NonEmpty Buildable -> IO () +annotateDeps bs = unless (null bs') . void . pacmanSuccess + $ ["-D", "--asdeps"] <> asFlag (map bName bs') + where + bs' :: [Buildable] + bs' = NEL.filter (not . bIsExplicit) bs -- | Reduce a list of candidate packages to build, such that there is only one -- instance of each "Package Base". This will ensure that split packages will -- only be built once each. Precedence is given to packages that actually -- match the base name (e.g. llvm50 vs llvm50-libs). -uniquePkgBase :: [NESet Buildable] -> [NESet Buildable] -uniquePkgBase bs = mapMaybe (NES.nonEmptySet . S.filter (\b -> (b ^. field @"name") `S.member` goods) . NES.toSet) bs - where f a b | (a ^. field @"name") == (a ^. field @"base") = a - | (b ^. field @"name") == (b ^. field @"base") = b - | otherwise = a - goods = S.fromList . (^.. each . field @"name") . M.elems . M.fromListWith f $ map (view (field @"base") &&& id) bs' - bs' = foldMap toList bs +uniquePkgBase :: [NonEmpty Buildable] -> [NonEmpty Buildable] +uniquePkgBase bs = mapMaybe g bs + where + bs' :: [Buildable] + bs' = foldMap NEL.toList bs + g :: NonEmpty Buildable -> Maybe (NonEmpty Buildable) + g = NEL.nonEmpty . L.nub . NEL.filter (\b -> bName b `S.member` goods) + + f :: Buildable -> Buildable -> Buildable + f a b | bName a == bBase a = a + | bName b == bBase b = b + | otherwise = a + + goods :: Set PkgName + goods = S.fromList . map bName . M.elems . M.fromListWith f $ map (bBase &&& id) bs' + confirmIgnored :: Set PkgName -> RIO Env (Set PkgName) confirmIgnored (toList -> ps) = do ss <- asks settings S.fromList <$> filterM (liftIO . optionalPrompt ss . confirmIgnored_1) ps -depsToInstall :: Repository -> NESet Buildable -> RIO Env (NonEmpty (NESet Package)) +-- | The nested `NonEmpty`s represent the package "hierarchy", namely, what can +-- be built/installed before what. +depsToInstall :: Repository -> NonEmpty Buildable -> RIO Env (NonEmpty (NonEmpty Package)) depsToInstall repo bs = do ss <- asks settings - traverse (liftIO . packageBuildable ss) (NES.toList bs) >>= resolveDeps repo . NES.fromList + traverse (liftIO . packageBuildable ss) bs >>= resolveDeps repo repoInstall :: NonEmpty Prebuilt -> RIO Env () repoInstall ps = do pacOpts <- asks (asFlag . commonConfigOf . settings) - liftIO . pacman $ ["-S", "--asdeps"] <> pacOpts <> asFlag (ps ^.. each . field @"name") + liftIO . pacman $ ["-S", "--asdeps"] <> pacOpts <> asFlag (NEL.map pName ps) -buildAndInstall :: NonEmpty (NESet Buildable) -> RIO Env () +buildAndInstall :: NonEmpty (NonEmpty Buildable) -> RIO Env () buildAndInstall bss = do pth <- asks (either id id . cachePathOf . commonConfigOf . settings) cache <- liftIO $ cacheContents pth traverse_ (f cache) bss - where f (Cache cache) bs = do - ss <- asks settings - let (ps, cached) = fmapEither g $ toList bs - g b = case (b ^. super @SimplePkg) `M.lookup` cache of - Just pp | not (switch ss ForceBuilding) -> Right pp - _ -> Left b - built <- traverse (buildPackages . NES.fromList) $ NEL.nonEmpty ps - traverse_ installPkgFiles $ built <> (NES.fromList <$> NEL.nonEmpty cached) - liftIO $ annotateDeps bs + where + -- TODO There is a weird edge case (which might be impossible anyway) where + -- `built` and the `traverse_` line below don't run, but `annotateDeps` is + -- called anyway. There is definitely a better way to manage the `NonEmpty`s + -- here. + f :: Cache -> NonEmpty Buildable -> RIO Env () + f (Cache cache) bs = do + ss <- asks settings + let (ps, cached) = fmapEither g $ NEL.toList bs + g b = case bToSP b `M.lookup` cache of + Just pp | not (switch ss ForceBuilding) -> Right pp + _ -> Left b + built <- traverse buildPackages $ NEL.nonEmpty ps + traverse_ installPkgFiles $ built <> NEL.nonEmpty cached + liftIO $ annotateDeps bs ------------ -- REPORTING ------------ -- | Display dependencies. The result of @-Ad@. -displayPkgDeps :: NESet PkgName -> RIO Env () +displayPkgDeps :: NonEmpty 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) . liftIO $ aurLookup (managerOf ss) ps - traverse_ f $ NES.nonEmptySet goods - where reportDeps True = liftIO . uncurry reportListOfDeps - reportDeps False = uncurry reportPkgsToInstall -reportPkgsToInstall :: [Prebuilt] -> [NESet Buildable] -> RIO Env () + let f :: NonEmpty Buildable -> RIO Env () + f = depsToInstall rpstry >=> reportDeps (switch ss LowVerbosity) . partitionPkgs + + (_, goods) <- liftMaybeM (Failure connectFailure_1) . liftIO $ aurLookup (managerOf ss) ps + traverse_ f $ nes goods + where + reportDeps :: Bool -> ([Prebuilt], [NonEmpty Buildable]) -> RIO Env () + reportDeps True = liftIO . uncurry reportListOfDeps + reportDeps False = uncurry reportPkgsToInstall + +reportPkgsToInstall :: [Prebuilt] -> [NonEmpty Buildable] -> RIO Env () reportPkgsToInstall rps bps = do - let (explicits, ds) = L.partition isExplicit $ foldMap toList bps - f reportPkgsToInstall_1 rps - f reportPkgsToInstall_3 ds - f reportPkgsToInstall_2 explicits + let (explicits, ds) = L.partition bIsExplicit $ foldMap NEL.toList bps + f reportPkgsToInstall_1 $ map pName rps + f reportPkgsToInstall_3 $ map bName ds + f reportPkgsToInstall_2 $ map bName explicits where - f m xs = traverse_ (report green m) . NEL.nonEmpty . L.sort $ xs ^.. each . field @"name" + f :: (Language -> Doc AnsiStyle) -> [PkgName] -> RIO Env () + f m xs = traverse_ (report green m) . NEL.nonEmpty $ L.sort xs -reportListOfDeps :: [Prebuilt] -> [NESet Buildable] -> IO () -reportListOfDeps rps bps = f rps *> f (foldMap toList bps) - where f :: HasField' "name" s PkgName => [s] -> IO () - f = traverse_ putTextLn . L.sort . (^.. each . field' @"name" . field' @"name") +reportListOfDeps :: [Prebuilt] -> [NonEmpty Buildable] -> IO () +reportListOfDeps rps bps = f (map pName rps) *> f (map bName $ foldMap NEL.toList bps) + where + f :: [PkgName] -> IO () + f = traverse_ putTextLn . L.sort . map pnName pkgbuildDiffs :: Set Buildable -> RIO Env () pkgbuildDiffs ps = asks settings >>= check @@ -210,14 +233,13 @@ displayDiff :: Buildable -> RIO Env () displayDiff p = do ss <- asks settings - let pn = p ^. field @"name" - lang = langOf ss + let pn = bName p isStored <- liftIO $ hasPkgbuildStored pn if not isStored - then liftIO . warn ss $ reportPkgbuildDiffs_1 pn lang + then warn ss $ reportPkgbuildDiffs_1 pn else liftIO $ do setCurrentDirectory "/tmp" let new = "/tmp/new.pb" - writeFileBinary new $ p ^. field @"pkgbuild" . field @"pkgbuild" - liftIO . warn ss $ reportPkgbuildDiffs_3 pn lang - diff ss (pkgbuildPath pn) $ fromAbsoluteFilePath new + writeFileBinary new . pkgbuild $ bPkgbuild p + warn ss $ reportPkgbuildDiffs_3 pn + diff ss (pkgbuildPath pn) new diff --git a/lib/Aura/Languages.hs b/lib/Aura/Languages.hs --- a/lib/Aura/Languages.hs +++ b/lib/Aura/Languages.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK prune #-} {-# OPTIONS_GHC -fno-warn-missing-export-lists #-} @@ -29,6 +29,7 @@ Kai Zhang | Chinese Onoue Takuro | Japanese Zachary "Ghosy" Matthews | Esperanto +Joris Blanken | Dutch -} module Aura.Languages where @@ -36,7 +37,6 @@ import Aura.Colour import qualified Aura.Languages.Fields as Fields import Aura.Types -import Data.Generics.Product (field) import Data.Ratio ((%)) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal @@ -65,27 +65,29 @@ , (Chinese, "Kai Zhang") , (Japanese, "Onoue Takuro") , (Esperanto, "Zachary Matthews") + , (Dutch, "Joris Blanken") ] -- These need updating! Or removing... 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" ] - Swedish -> [ "Japanese", "Polska", "Kroatiska", "Svenska", "Tyska", "Spanska", "Portugisiska", "Franska", "Ryska", "Italienska", "Serbiska", "Norska", "Indonesian", "Chinese", "Esperanto" ] - German -> [ "Japanisch", "Polnisch", "Kroatisch", "Schwedisch", "Deutsch", "Spanisch", "Portugiesisch", "Französisch", "Russisch", "Italienisch", "Serbisch", "Norwegisch", "Indonesisch", "Chinese", "Esperanto" ] - Spanish -> [ "Japanese", "Polaco", "Croata", "Sueco", "Alemán", "Español", "Portugués", "Francés", "Ruso", "Italiano", "Serbio", "Noruego", "Indonesio", "Chinese", "Esperanto" ] - Portuguese -> [ "Japonês", "Polonês", "Croata", "Sueco", "Alemão", "Espanhol", "Português", "Francês", "Russo", "Italiano", "Sérvio", "Norueguês", "Indonésio", "Chinês", "Esperanto" ] - French -> [ "Japanese", "Polonais", "Croate", "Suédois", "Allemand", "Espagnol", "Portugais", "Français", "Russe", "Italien", "Serbe", "Norvégien", "Indonesian", "Chinese", "Esperanto" ] - Russian -> [ "Японский", "Польский", "Хорватский", "Шведский", "Немецкий", "Испанский", "Португальский", "Французский", "Русский", "Итальянский", "Сербский", "Норвежский", "Индонезийский", "Китайский", "Эсперанто" ] - Italian -> [ "Giapponese", "Polacco", "Croato", "Svedese", "Tedesco", "Spagnolo", "Portoghese", "Francese", "Russo", "Italiano", "Serbo", "Norvegese", "Indonesiano", "Cinese", "Esperanto" ] - Serbian -> [ "Japanese", "Пољски", "Хрватски", "Шведски", "Немачки", "Шпански", "Португалски", "Француски", "Руски", "Италијански", "Српски", "", "Indonesian", "Chinese", "Esperanto" ] - Norwegian -> [ "Japanese", "Polsk", "Kroatisk", "Svensk", "Tysk", "Spansk", "Portugisisk", "Fransk", "Russisk", "Italiensk", "Serbisk", "Norsk", "Indonesian", "Chinese", "Esperanto" ] - Indonesia -> [ "Japanese", "Polandia", "Kroasia", "Swedia", "Jerman", "Spanyol", "Portugis", "Prancis", "Rusia", "Italia", "Serbia", "Norwegia", "Indonesian", "Chinese", "Esperanto" ] - Chinese -> [ "日语", "波兰语", "克罗地亚语", "瑞典语", "德语", "西班牙语", "葡萄牙语", "法语", "俄语", "意大利语", "塞尔维亚语", "挪威语", "印度尼西亚语", "中文", "世界语" ] - 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" ] +languageNames = M.fromList . zip [ Japanese, Polish, Croatian, Swedish, German, Spanish, Portuguese, French, Russian, Italian, Serbian, Norwegian, Indonesia, Chinese, Esperanto, Dutch ] . \case + Japanese -> [ "日本語", "ポーランド語", "クロアチア語", "スウェーデン語", "ドイツ語", "スペイン語", "ポルトガル語", "フランス語", "ロシア語", "イタリア語", "セルビア語", "ノルウェー語", "インドネシア語", "中国語", "エスペラント", "オランダ語" ] + Polish -> [ "Japanese", "polski", "chorwacki", "szwedzki", "niemiecki", "hiszpański", "portugalski", "francuski", "rosyjski", "", "", "", "Indonesian", "Chinese", "Esperanto", "Dutch" ] + Croatian -> [ "Japanese", "poljski", "hrvatski", "švedski", "njemački", "španjolski", "portugalski", "francuski", "ruski", "talijanski", "srpski", "norveški", "Indonesian", "Chinese", "Esperanto", "Dutch" ] + Swedish -> [ "Japanese", "Polska", "Kroatiska", "Svenska", "Tyska", "Spanska", "Portugisiska", "Franska", "Ryska", "Italienska", "Serbiska", "Norska", "Indonesian", "Chinese", "Esperanto", "Dutch" ] + German -> [ "Japanisch", "Polnisch", "Kroatisch", "Schwedisch", "Deutsch", "Spanisch", "Portugiesisch", "Französisch", "Russisch", "Italienisch", "Serbisch", "Norwegisch", "Indonesisch", "Chinese", "Esperanto", "Dutch" ] + Spanish -> [ "Japanese", "Polaco", "Croata", "Sueco", "Alemán", "Español", "Portugués", "Francés", "Ruso", "Italiano", "Serbio", "Noruego", "Indonesio", "Chinese", "Esperanto", "Dutch" ] + Portuguese -> [ "Japonês", "Polonês", "Croata", "Sueco", "Alemão", "Espanhol", "Português", "Francês", "Russo", "Italiano", "Sérvio", "Norueguês", "Indonésio", "Chinês", "Esperanto", "Dutch" ] + French -> [ "Japanese", "Polonais", "Croate", "Suédois", "Allemand", "Espagnol", "Portugais", "Français", "Russe", "Italien", "Serbe", "Norvégien", "Indonesian", "Chinese", "Esperanto", "Dutch" ] + Russian -> [ "Японский", "Польский", "Хорватский", "Шведский", "Немецкий", "Испанский", "Португальский", "Французский", "Русский", "Итальянский", "Сербский", "Норвежский", "Индонезийский", "Китайский", "Эсперанто", "Dutch" ] + Italian -> [ "Giapponese", "Polacco", "Croato", "Svedese", "Tedesco", "Spagnolo", "Portoghese", "Francese", "Russo", "Italiano", "Serbo", "Norvegese", "Indonesiano", "Cinese", "Esperanto", "Dutch" ] + Serbian -> [ "Japanese", "Пољски", "Хрватски", "Шведски", "Немачки", "Шпански", "Португалски", "Француски", "Руски", "Италијански", "Српски", "", "Indonesian", "Chinese", "Esperanto", "Dutch" ] + Norwegian -> [ "Japanese", "Polsk", "Kroatisk", "Svensk", "Tysk", "Spansk", "Portugisisk", "Fransk", "Russisk", "Italiensk", "Serbisk", "Norsk", "Indonesian", "Chinese", "Esperanto", "Dutch" ] + Indonesia -> [ "Japanese", "Polandia", "Kroasia", "Swedia", "Jerman", "Spanyol", "Portugis", "Prancis", "Rusia", "Italia", "Serbia", "Norwegia", "Indonesian", "Chinese", "Esperanto", "Dutch" ] + Chinese -> [ "日语", "波兰语", "克罗地亚语", "瑞典语", "德语", "西班牙语", "葡萄牙语", "法语", "俄语", "意大利语", "塞尔维亚语", "挪威语", "印度尼西亚语", "中文", "世界语", "Dutch" ] + 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", "La nederlanda" ] + Dutch -> [ "Japans", "Pools", "Kroatisch", "Zweeds", "Duits", "Spaans", "Portugees", "Frans", "Russisch", "Italiaans", "Servisch", "Noors", "Indonesisch", "Chinees", "Esperanto", "Nederlands" ] + _ -> [ "Japanese", "Polish", "Croatian", "Swedish", "German", "Spanish", "Portuguese", "French", "Russian", "Italian", "Serbian", "Norwegian", "Indonesian", "Chinese", "Esperanto", "Dutch" ] translatorMsgTitle :: Language -> Text translatorMsgTitle = \case @@ -104,6 +106,7 @@ Indonesia -> "Penerjemah Aura:" Chinese -> "Aura 的翻译者：" Esperanto -> "Tradukistoj de Aura:" + Dutch -> "Aura Vertalers:" _ -> "Aura Translators:" translatorMsg :: Language -> [Text] @@ -115,9 +118,9 @@ formatLang (translator, lang') = " (" <> lang' <> ") " <> translator langNames = languageNames lang --- Wrap a String in backticks +-- | Make some `Text` cyan. Previous wrapped things in backticks. bt :: Text -> Doc AnsiStyle -bt cs = "`" <> pretty cs <> "`" +bt cs = cyan $ pretty cs whitespace :: Language -> Char whitespace Japanese = '　' -- \12288 @@ -140,6 +143,7 @@ "id" -> Indonesia "zh" -> Chinese "eo" -> Esperanto + "nl" -> Dutch _ -> English ---------------------- @@ -161,6 +165,7 @@ Chinese -> "包数据库已锁定。请在解锁后按下回车以继续。" Swedish -> "Paketdatabasen är låst. Klicka på enter när den är upplåst." Esperanto -> "La datumbazo de pakaĵoj estas ŝlosita. Premu enen-klavo kiam la datumbazo estas malŝlosita por daŭrigi" + Dutch -> "De pakket databank is vergrendelt. Druk op enter wanneer het ontgrendelt is." _ -> "The package database is locked. Press enter when it's unlocked to continue." trueRoot_3 :: Language -> Doc AnsiStyle @@ -174,6 +179,7 @@ Chinese -> "自从 makepkg v4.2 以后，就不能以根用户身份构建软件了。" Swedish -> "I makepkg v4.2 och uppåt är det inte tillåtet att bygga som root." Esperanto -> "Depost makepkg v4.2, konstruanto ĉefuzante ne eblas." + Dutch -> "Vanaf makepkg v4.2 is het niet langer mogelijk om als root te bouwen." _ -> "As of makepkg v4.2, building as root is no longer possible." mustBeRoot_1 :: Language -> Doc AnsiStyle @@ -193,13 +199,14 @@ Indonesia -> "Anda harus menggunakan " <> sudo <> " untuk melakukannya." Chinese -> "除非是根用户，否则不能执行此操作。" Esperanto -> "Vi ne povas fari ĉi tiun operacion, sen " <> sudo <> "." + Dutch -> "U kunt deze operatie niet uitvoeren zonder " <> sudo <> " te gebruiken." _ -> "You cannot perform this operation without using sudo." ----------------------- -- Aura/Build functions ----------------------- buildPackages_1 :: PkgName -> Language -> Doc AnsiStyle -buildPackages_1 (bt . view (field @"name") -> p) = \case +buildPackages_1 (bt . pnName -> p) = \case Japanese -> p <> "を作成中・・・" Polish -> "Budowanie " <> p <> "..." Croatian -> "Gradim " <> p <> "..." @@ -214,7 +221,8 @@ Norwegian -> "Bygger " <> p <> "..." Indonesia -> "Membangun " <> p <> "..." Chinese -> p <> " 正在构建中..." - Esperanto -> "Muntanta" <> p <> "..." + Esperanto -> "Muntanta " <> p <> "..." + Dutch -> "Pakket " <> p <> " aan het bouwen..." _ -> "Building " <> p <> "..." buildFail_5 :: Language -> Doc AnsiStyle @@ -234,6 +242,7 @@ Indonesia -> "Proses gagal." Chinese -> "构建失败。" Esperanto -> "Muntado paneis" + Dutch -> "Bouwen is mislukt." _ -> "Building failed." -- NEEDS TRANSLATION @@ -253,11 +262,12 @@ Chinese -> "你仍然希望继续吗？" Swedish -> "Vill du fortsätta ändå?" Esperanto -> "Ĉu vi volas daŭrigi?" + Dutch -> "Wilt U toch doorgaan?" _ -> "Would you like to continue anyway?" -- NEEDS TRANSLATION buildFail_7 :: PkgName -> Language -> Doc AnsiStyle -buildFail_7 (bt . view (field @"name") -> p) = \case +buildFail_7 (bt . pnName -> p) = \case Japanese -> p <> "のビルドスクリプトを収得できませんでした。" Polish -> "Nie udało się pozyskać skryptów budowania dla " <> p <> "." German -> "Herunterladen der Build-Skripte für " <> p <> " fehlgeschlagen." @@ -269,6 +279,7 @@ Chinese -> "无法获得 " <> p <> " 的构建脚本。" Swedish -> "Kunde inte hämta byggskript för " <> p <> "." Esperanto -> "Paneis akiri muntaj skriptoj de " <> p <> "." + Dutch -> "Verkrijgen van bouw scripten mislukt voor " <> p <> "." _ -> "Failed to obtain build scripts for " <> p <> "." buildFail_8 :: Language -> Doc AnsiStyle @@ -279,6 +290,7 @@ Russian -> "Произошла ошибка makepkg." Italian -> "C'è stato un errore nell'esecuzione di makepkg." Esperanto -> "Paneo de makepkg okazis." + Dutch -> "Er is een fout opgetreden in makepkg." _ -> "There was a makepkg failure." buildFail_9 :: Language -> Doc AnsiStyle @@ -286,6 +298,7 @@ Spanish -> "Error al detectar todos los archivo de paquete (*.pkg.tar.xz)." Italian -> "Non è stato possibile trovare nessun archivio risultante dalla compilazione del pacchetto (*.pkg.tar.xz)." Esperanto -> "Paneis detekti ĉiujn dosierojn de pakaĵoj (*.pkg.tar.xz)." + Dutch -> "Detecteren van built package files mislukt (*.pkg.tar.xz)." _ -> "Failed to detect any built package files (*.pkg.tar.xz)." buildFail_10 :: Language -> Doc AnsiStyle @@ -293,6 +306,7 @@ Spanish -> "Los paquetes no se pudieron construir." Italian -> "Non è stato possibile compilare i pacchetti." Esperanto -> "Ĉiuj pakaĵoj paneis munti." + Dutch -> "Het bouwen van alle pakketten is mislukt." _ -> "Every package failed to build." buildFail_11 :: Language -> Doc AnsiStyle @@ -301,6 +315,7 @@ Spanish -> "Construcción fallida. ¿Te gustaría ver el error?" Italian -> "La compilazione è fallita. Visionare l'errore?" Esperanto -> "Muntado paneis. Ĉu vi volas vidi la eraron?" + Dutch -> "Bouwen mislukt. Wilt U de fouten zien?" _ -> "Building failed. Would you like to see the error?" ------------------------------ @@ -308,7 +323,7 @@ ------------------------------ -- NEEDS UPDATE TO MATCH NEW ENGLISH 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 +getRealPkgConflicts_1 (bt . pnName -> prnt) (bt . pnName -> p) (bt -> r) (bt -> d) = \case Japanese -> "パッケージ" <> p <> "はバージョン" <> d <> "を要するが" <> "一番最新のバージョンは" <> r <> "。" Polish -> "Zależność " <> p <> " powinna być w wersji " <> d <> ", ale najnowsza wersja to " <> r <> "." Croatian -> "Zavisnost " <> p <> " zahtjeva verziju " <> d <> ", a najnovija dostupna verzija je " <> r <> "." @@ -324,10 +339,11 @@ Indonesia -> "Dependensi " <> p <> " meminta versi " <> d <> " namun versi paling baru adalah " <> r <> "." Chinese -> "依赖 " <> p <> " 需要版本 " <> d <> "，但是最新的版本是 " <> r <> "。" Esperanto -> "La pakaĵo, " <> prnt <> ", dependas de versio " <> d <> " de " <> p <> ", sed la plej nova versio estas " <> r <> "." + Dutch -> "Het pakket " <> prnt <> ", hangt af van versie " <> d <> " van " <> p <> ", maar de meest recente versie is " <> r <> "." _ -> "The package " <> prnt <> " depends on version " <> d <> " of " <> p <> ", but the most recent version is " <> r <> "." getRealPkgConflicts_2 :: PkgName -> Language -> Doc AnsiStyle -getRealPkgConflicts_2 (bt . view (field @"name") -> p) = \case +getRealPkgConflicts_2 (bt . pnName -> p) = \case Japanese -> p <> "は無視されるパッケージ！`pacman.conf`を参考に。" Polish -> p <> " jest ignorowany! Sprawdź plik `pacman.conf`." Croatian -> p <> " je ignoriran paket! Provjerite svoj `pacman.conf`." @@ -343,6 +359,7 @@ Indonesia -> p <> " merupakan paket yang diabaikan! Lihat `pacman.conf` anda." Chinese -> p <> " 是一个被忽略的包！请查看你的 `pacman.conf` 文件。" Esperanto -> p <> " estas malatenta pakaĵo! Vidu vian `pacman.conf` dosieron." + Dutch -> p <> " is een genegeerd pakket! Bekijk uw `pacman.conf` file." _ -> p <> " is an ignored package! See your `pacman.conf` file." missingPkg_2 :: [DepError] -> Language -> Doc AnsiStyle @@ -351,18 +368,20 @@ depError :: Language -> DepError -> Doc AnsiStyle depError _ (VerConflict s) = s depError _ (Ignored s) = s -depError l (NonExistant (PkgName s)) = case l of +depError l (NonExistant (PkgName s) (PkgName par)) = case l of Spanish -> "La dependencia " <> bt s <> " no pudo ser encontrada." Portuguese -> "A dependência " <> bt s <> " não foi encontrada." Russian -> "Зависимость " <> bt s <> " не найдена." Italian -> "Non è stato possibile trovare la dipendenza " <> bt s <> "." - Esperanto -> "La dependeco " <> bt s <> " ne povis troviĝi." - _ -> "The dependency " <> bt s <> " couldn't be found." + Esperanto -> "La dependeco " <> bt s <> " de " <> bt par <> " ne povis troviĝi." + Dutch -> "Het afhankelijkheid " <> bt s <> "kan niet worden gevonden." + _ -> "The dependency " <> bt s <> " of " <> bt par <> " couldn't be found." depError l (BrokenProvides (PkgName pkg) (Provides (PkgName pro)) (PkgName n)) = case l of Spanish -> "El paquete " <> bt pkg <> " necesita " <> bt n <> " que proporciona " <> bt pro <> "." Russian -> "Пакету " <> bt pkg <> " требуется " <> bt n <> ", предоставляющий " <> bt pro <> "." Esperanto -> "La pakaĵo, " <> bt pkg <> " bezonas " <> bt n <> ", kiu donas " <> bt pro <> "." Italian -> "Il pacchetto " <> bt pkg <> " ha bisogno di " <> bt n <> ", che rende disponibile " <> bt pro <> "." + Dutch -> "Het pakket" <> bt pkg <> " heeft " <> bt n <> " nodig, die " <> bt pro <> " biedt." _ -> "The package " <> bt pkg <> " needs " <> bt n <> ", which provides " <> bt pro <> "." missingPkg_3 :: Language -> Doc AnsiStyle @@ -370,18 +389,23 @@ Spanish -> "Se produjo un error al reorganizar el gráfico de dependencia. Si ves esto, algo está muy mal." Esperanto -> "Eraro okazis kiam reorganizi la grafeo de dependeco. Io estas erarega." Italian -> "C'è stato un errore nella riorganizzazione della gerarchia delle dipendenze. Se vedi questo messaggio, qualcosa è andato davvero storto." + Dutch -> "Er is een fout opgetreden bij het reorganizeren van de afhankelijkheidsgrafiek. Als U dit ziet, is er iets heel erg mis." _ -> "There was an error reorganizing the dependency graph. If you see this, something is very wrong." missingPkg_4 :: [NonEmpty PkgName] -> Language -> Doc AnsiStyle missingPkg_4 pns = \case Spanish -> vsep $ "Se detectaron los siguientes ciclos de dependencia:" : pns' Italian -> vsep $ "Sono stati individuati i seguenti cicli di dipendenza:" : pns' + Dutch -> vsep $ "The volgende afhankelijkheidscycli zijn gedetecteerd:" : pns' _ -> vsep $ "The following dependency cycles were detected:" : pns' - where pns' = map (hsep . map pretty . L.intersperse "=>" . map (view (field @"name")) . toList) pns + where + pns' :: [Doc ann] + pns' = map (hsep . map pretty . L.intersperse "=>" . map pnName . toList) pns missingPkg_5 :: PkgName -> Language -> Doc AnsiStyle missingPkg_5 (PkgName p) = \case Italian -> bt p <> " non esiste." + Dutch -> bt p <> " bestaat niet." _ -> bt p <> " does not exist." ----------------- @@ -404,6 +428,7 @@ Indonesia -> "Berikut ini adalah bahasa yang tersedia:" Chinese -> "以下语言是可用的：" Esperanto -> "La sekvaj lingvo estas disponebla:" + Dutch -> "De volgende talen zijn beschikbaar:" _ -> "The following languages are available:" ---------------------------- @@ -426,6 +451,7 @@ Chinese -> "Aura 可以升级。先升级 aura？" Swedish -> "Det finns en uppdatering tillgänglig till Aura. Vill du uppdatera Aura först?" Esperanto -> "Ĝisdatigo de Aura estas disponebla. Ĉu ĝisdatigas ĝin?" + Dutch -> "Aura update beschikbaar. Eerst updaten?" _ -> "Aura update available. Update it first?" install_2 :: Language -> Doc AnsiStyle @@ -445,6 +471,7 @@ Indonesia -> "Tidak ada paket valid yang dispesifikkan." Chinese -> "没有指定有效的包。" Esperanto -> "Ne validajn pakaĵojn specifis" + Dutch -> "Geen geldige pakketen gespecificeerd." _ -> "No valid packages specified." install_3 :: Language -> Doc AnsiStyle @@ -464,6 +491,7 @@ Indonesia -> "Lanjut?" Chinese -> "继续？" Esperanto -> "Ĉu daŭrigi?" + Dutch -> "Doorgaan?" _ -> "Continue?" install_4 :: Language -> Doc AnsiStyle @@ -483,6 +511,7 @@ Indonesia -> "Instalasi dibatalkan secara paksa." Chinese -> "手动安装已中止。" Esperanto -> "Instalon ĉesigi permane" + Dutch -> "Installatie handmatig afgebroken." _ -> "Installation manually aborted." install_5 :: Language -> Doc AnsiStyle @@ -502,11 +531,12 @@ Indonesia -> "Menentukan dependensi..." Chinese -> "确定依赖中..." Esperanto -> "Difinas dependecojn..." + Dutch -> "Afhankelijkheden aan het bepalen..." _ -> "Determining dependencies..." -- 2014 December 7 @ 14:45 - NEEDS TRANSLATIONS confirmIgnored_1 :: PkgName -> Language -> Doc AnsiStyle -confirmIgnored_1 (bt . view (field @"name") -> p) = \case +confirmIgnored_1 (bt . pnName -> p) = \case Japanese -> p <> "は無視されるはずのパッケージです。それでも続行しますか？" Polish -> p <> " jest oznaczony jako ignorowany. Zainstalować mimo tego?" Spanish -> p <> " está marcado como ignorado. ¿Deseas instalarlo de todas formas?" @@ -516,6 +546,7 @@ Chinese -> p <> " 已被标记为忽略。仍然安装？" Swedish -> p <> " är markerad som ignorerad. Vill du installera ändå?" Esperanto -> p <> " estas markita kiel malatenta. Ĉu instali?" + Dutch -> p <> " is gemarkeerd als genegeerd. Toch installeren?" _ -> p <> " is marked as Ignored. Install anyway?" -- NEEDS UPDATE TO REFLECT CHANGED ENGLISH @@ -536,6 +567,7 @@ Indonesia -> "Paket berikut ini bukan merupakan paket AUR:" Chinese -> "以下软件不是 AUR 包：" Esperanto -> "La sekvaj ne estas pakaĵoj de la AUR:" + Dutch -> "De volgende pakketten zijn geen AUR pakketten:" _ -> "The following are not AUR packages:" -- NEEDS TRANSLATION @@ -551,6 +583,7 @@ Chinese -> "以下包已被安装：" Swedish -> "Följande paket är redan installerade:" Esperanto -> "La sekvaj pakaĵoj jam instaliĝas:" + Dutch -> "The volgende pakketten zijn al geinstalleerd:" _ -> "The following packages are already installed:" reportPkgsToInstall_1 :: Language -> Doc AnsiStyle @@ -570,6 +603,7 @@ Indonesia -> "Dependensi dari repositori:" Chinese -> "仓库依赖：" Esperanto -> "Dependecoj de deponejo:" + Dutch -> "Repository afhankelijkheden:" _ -> "Repository dependencies:" -- NEEDS AN UPDATE @@ -589,6 +623,7 @@ Chinese -> "AUR 包：" Swedish -> "AUR Paket:" Esperanto -> "Pakaĵoj de AUR:" + Dutch -> "AUR Pakketten:" _ -> "AUR Packages:" reportPkgsToInstall_3 :: Language -> Doc AnsiStyle @@ -606,11 +641,12 @@ Serbian -> "Зависности из AUR-а:" Norwegian -> "Avhengigheter fra AUR:" Esperanto -> "Dependencoj de AUR:" + Dutch -> "AUR-afhankelijkheden:" _ -> "AUR dependencies:" -- NEEDS TRANSLATION reportPkgbuildDiffs_1 :: PkgName -> Language -> Doc AnsiStyle -reportPkgbuildDiffs_1 (bt . view (field @"name") -> p) = \case +reportPkgbuildDiffs_1 (bt . pnName -> p) = \case Japanese -> p <> "のPKGBUILDはまだ保存されていません。" Polish -> p <> " nie ma jeszcze przechowywanego pliku PKGBUILD." Croatian -> p <> " još nema pohranjen PKGBUILD." @@ -626,31 +662,12 @@ Chinese -> p <> " 还没有保存的 PKGBUILD。" Swedish -> p <> " har ännu ingen PKGBUILD." Esperanto -> p <> " ne havas PKGBUILD jam." + Dutch -> p <> " heeft nog geen opgeslagen PKGBUILD." _ -> p <> " has no stored PKGBUILD yet." -- NEEDS TRANSLATION -reportPkgbuildDiffs_2 :: Text -> Language -> Doc AnsiStyle -reportPkgbuildDiffs_2 (bt -> p) = \case - Japanese -> p <> "のPKGBUILDは最新です。" - Polish -> "PKGBUILD pakietu " <> p <> " jest aktualny." - Croatian -> "PKGBUILD paketa " <> p <> " je na najnovijoj verziji." - German -> "PKGBUILD von " <> p <> " ist aktuell." - Spanish -> "El PKGBUILD de " <> p <> " está actualizado." - Portuguese -> "O PKGBUILD de " <> p <> "está atualizado." - Russian -> "PKGBUILD " <> p <> " является новейшим." - French -> "Le PKGBUILD de " <> p <> " est à jour." - Italian -> "Il PKGBUILD di " <> p <> " è aggiornato all'ultima versione." - Serbian -> "PKGBUILD пакета " <> p <> " је ажуран." - Norwegian -> p <> "'s PKGBUILD er oppdatert." - Indonesia -> "PKGBUILD dari paket " <> p <> " sudah mutakhir." - Chinese -> p <> " 的 PKGBUILD 已经最新。" - Swedish -> "PKGBUILD för " <> p <> " är aktuell." - Esperanto -> p <> " PKGBUILD estas ĝisdata." - _ -> p <> " PKGBUILD is up to date." - --- NEEDS TRANSLATION reportPkgbuildDiffs_3 :: PkgName -> Language -> Doc AnsiStyle -reportPkgbuildDiffs_3 (bt . view (field @"name") -> p) = \case +reportPkgbuildDiffs_3 (bt . pnName -> p) = \case Japanese -> p <> "のPKGBUILD変更報告：" Polish -> "Zmiany w PKGBUILD dla " <> p <> ":" Croatian -> "Promjene u PKGBUILD-u za " <> p <> ":" @@ -666,6 +683,7 @@ Chinese -> p <> " 的 PKGBUILD 变化：" Swedish -> "Förändringar i PKGBUILD för " <> p <> ":" Esperanto -> p <> " PKGBUILD ŝanĝoj:" + Dutch -> p <> " PKGBUILD aanpassingen:" _ -> p <> " PKGBUILD changes:" -- NEEDS TRANSLATION @@ -686,6 +704,7 @@ Indonesia -> "Paket AUR yang akan ditingkatkan:" Chinese -> "要升级的 AUR 包：" Esperanto -> "Pakaĵoj de AUR ĝisdatigi:" + Dutch -> "AUR-Pakketten om te upgraden:" _ -> "AUR Packages to upgrade:" -- NEEDS UPDATING @@ -706,12 +725,14 @@ Indonesia -> "Berikut ini tidak mempunyai versi pada cache, sehingga tidak akan diturunkan:" Chinese -> "以下包在缓存中没有版本，所以无法被降级：" Esperanto -> "La sekvaj pakaĵoj havas ne kaŝmemorigitajn versiojn, do ĝi ne povas malpromociigi:" + Dutch -> "De volgende pakketten hebben geen versie in de cache, en kunnen dus niet gedowngrade worden." _ -> "The following have no versions in the cache, and thus can’t be downgraded:" reportBadDowngradePkgs_2 :: PkgName -> Language -> Doc AnsiStyle reportBadDowngradePkgs_2 (PkgName p) = \case Spanish -> pretty p <+> "no tiene una versión en la caché." Italian -> pretty p <+> "non ha alcuna versione nella cache." + Dutch -> pretty p <+> "heeft geen versie in de cache." _ -> pretty p <+> "has no version in the cache." upgradeAURPkgs_1 :: Language -> Doc AnsiStyle @@ -731,6 +752,7 @@ Indonesia -> "Mengambil informasi paket..." Chinese -> "正在获取包信息..." Esperanto -> "Venigas informacion de pakaĵoj..." + Dutch -> "Pakket informatie aan het ophalen..." _ -> "Fetching package information..." upgradeAURPkgs_2 :: Language -> Doc AnsiStyle @@ -750,6 +772,7 @@ Indonesia -> "Membandingkan versi paket..." Chinese -> "正在比较包的版本..." Esperanto -> "Komparas versiojn de pakaĵoj..." + Dutch -> "Pakket versies aan het vergelijken..." _ -> "Comparing package versions..." upgradeAURPkgs_3 :: Language -> Doc AnsiStyle @@ -769,6 +792,7 @@ Indonesia -> "Tidak ada peningkatan AUR yang dibutuhkan." Chinese -> "没有需要升级的 AUR 包。" Esperanto -> "Ne ĝisdatigoj de pakaĵoj de AUR necesas." + Dutch -> "Geen AUR-pakket upgrades vereist." _ -> "No AUR package upgrades necessary." removeMakeDepsAfter_1 :: Language -> Doc AnsiStyle @@ -788,6 +812,7 @@ Indonesia -> "Menghapus dependensi `make` yang tidak dibutuhkan..." Chinese -> "移除不需要的 make 依赖..." Esperanto -> "Forigas nenecesajn dependecojn de make..." + Dutch -> "Onnodige make afhankelijkheden aan het verwijderen..." _ -> "Removing unneeded make dependencies..." ---------------------------- @@ -811,6 +836,7 @@ Chinese -> s <> " 个包的状态将会保留。删除其它的？" Swedish -> s <> " paket kommer att bevaras. Ta bort resten?" Esperanto -> s <> " statoj de pakaĵoj teniĝas. Ĉu forigi la ceteron?" + Dutch -> s <> " pakketstatussen worden behouden. De rest verwijderen?" _ -> s <> " package states will be kept. Remove the rest?" -- NEEDS TRANSLATION @@ -831,6 +857,7 @@ Chinese -> "没有删除任何包。" Swedish -> "Inga paket togs bort." Esperanto -> "Ne statojn de pakaĵoj forigis." + Dutch -> "Geen pakketstatussen verwijderd." _ -> "No package states were removed." cleanStates_4 :: Int -> Language -> Doc AnsiStyle @@ -840,6 +867,7 @@ Russian -> "У вас сейчас " <+> pretty n <+> pluralRussian " сохраненное состояние пакета" " сохраненных состояний пакета" " сохраненных состояний пакетов." n Italian -> "Al momento ci sono" <+> pretty n <+> "stati di pacchetti salvati." Esperanto -> "Vi havas " <+> pretty n <+> " konservajn statojn de pakaĵoj." + Dutch -> "U heeft momenteel" <+> pretty n <+> "opgeslagen pakketstatussen." _ -> "You currently have" <+> pretty n <+> "saved package states." cleanStates_5 :: Text -> Language -> Doc AnsiStyle @@ -849,12 +877,14 @@ Russian -> "Последнее сохраненное:" <+> pretty t Italian -> "Salvato più recentemente:" <+> pretty t Esperanto -> "Lastaj konservaj:" <+> pretty t + Dutch -> "Meest recent opgeslagen:" <+> pretty t _ -> "Most recently saved:" <+> pretty t cleanStates_6 :: Int -> Language -> Doc AnsiStyle cleanStates_6 n = \case Spanish -> pretty n <+> "de estos están anclados y no se eliminarán." Italian -> pretty n <+> "di questi sono stati fissati, perciò non saranno rimossi." + Dutch -> pretty n <+> "hiervan zijn vastgezet, en worden niet verwijderd." _ -> pretty n <+> "of these are pinned, and won't be removed." readState_1 :: Language -> Doc AnsiStyle @@ -864,13 +894,14 @@ Russian -> "Это состояние не распознано. Это корректный JSON?" Italian -> "Non è stato possibile analizzare il file di stato. E' correttamente formattato in JSON?" Esperanto -> "Tiu statdosiero paneis sintake analizi. Ĉu ĝi estas valida JSON?" + Dutch -> "Dat statusbestand kon niet worden geparseerd. Is het legale JSON?" _ -> "That state file failed to parse. Is it legal JSON?" ---------------------------- -- Aura/Commands/C functions ---------------------------- getDowngradeChoice_1 :: PkgName -> Language -> Doc AnsiStyle -getDowngradeChoice_1 (bt . view (field @"name") -> p) = \case +getDowngradeChoice_1 (bt . pnName -> p) = \case Japanese -> p <> "はどのバージョンにしますか？" Polish -> "Którą wersję pakietu " <> p <> " zainstalować?" Croatian -> "Koju verziju paketa " <> p <> " želite?" @@ -886,6 +917,7 @@ Indonesia -> "Versi dari paket " <> p <> " mana yang anda inginkan?" Chinese -> "你希望安装 " <> p <> " 的哪个版本？" Esperanto -> "Kiu versio de " <> p <> " vi volas?" + Dutch -> "Welke versie van " <> p <> " wil je?" _ -> "What version of " <> p <> " do you want?" backupCache_3 :: Language -> Doc AnsiStyle @@ -905,6 +937,7 @@ Indonesia -> "Lokasi `backup` tidak ada." Chinese -> "备份位置不存在。" Esperanto -> "La savkopia loko ne ekzistas." + Dutch -> "De back-up lokatie bestaat niet." _ -> "The backup location does not exist." backupCache_4 :: FilePath -> Language -> Doc AnsiStyle @@ -924,6 +957,7 @@ Indonesia -> "Melakukan `backup` pada direktori " <> dir Chinese -> "正在将缓存备份到 " <> dir Esperanto -> "Enarkivigas la kaŝdosieron al " <> dir + Dutch -> "Back-up van cache aan het maken naar " <> dir _ -> "Backing up cache to " <> dir backupCache_5 :: Int -> Language -> Doc AnsiStyle @@ -943,6 +977,7 @@ Indonesia -> "Jumlah paket yang di-`backup`: " <> n Chinese -> "将要备份的包文件：" <> n Esperanto -> "La dosierojn de la pakaĵoj enarkivigi: " <> n + Dutch -> "Pakketbestanden om te back-uppen: " <> n _ -> "Package files to backup: " <> n backupCache_6 :: Language -> Doc AnsiStyle @@ -962,6 +997,7 @@ Indonesia -> "Lanjutkan dengan `backup`?" Chinese -> "开始备份？" Esperanto -> "Ĉu daŭrigu enarkivigi?" + Dutch -> "Doorgaan met back-up?" _ -> "Proceed with backup?" backupCache_7 :: Language -> Doc AnsiStyle @@ -981,6 +1017,7 @@ Indonesia -> "Proses `backup` dibatalkan secara paksa." Chinese -> "手动备份已中止。" Esperanto -> "Enarkivigadon ĉesigis permane." + Dutch -> "Back-up handmatig afgebroken." _ -> "Backup manually aborted." backupCache_8 :: Language -> Doc AnsiStyle @@ -1000,6 +1037,7 @@ Indonesia -> "Melakukan `backup`. Proses ini akan berjalan untuk beberapa menit..." Chinese -> "正在备份中。可能需要几分钟的时间..." Esperanto -> "Enarkiviganta. Ĉi tiu eble daŭros dum kelkaj tagoj..." + Dutch -> "Aan het back-uppen. Dit kan een aantal minuten duren..." _ -> "Backing up. This may take a few minutes..." copyAndNotify_1 :: Int -> Language -> Doc AnsiStyle @@ -1019,6 +1057,7 @@ Indonesia -> "Menyalin #[" <> n <> "]" Chinese -> "正在复制 #[" <> n <> "]" Esperanto -> "Kopianta #[" <> n <> "]" + Dutch -> "Kopiëren #[" <> n <> "]" _ -> "Copying #[" <> n <> "]" cleanCache_2 :: Language -> Doc AnsiStyle @@ -1038,6 +1077,7 @@ Indonesia -> "Akan menghapus SEMUA `cache` paket" Chinese -> "这将会删除全部的包缓存。" Esperanto -> "Ĉi tiu forigos la TUTAN kaŝmemoron de pakaĵoj." + Dutch -> "Hiermee wordt de GEHELE pakketcache verwijderd." _ -> "This will delete the ENTIRE package cache." cleanCache_3 :: Word -> Language -> Doc AnsiStyle @@ -1057,6 +1097,7 @@ Indonesia -> s <> " berkas dari tiap paket akan disimpan." Chinese -> "每个包文件将会保存 " <> s <> " 个版本。" Esperanto -> s <> " de ĉiu dosiero de pakaĵo teniĝos." + Dutch -> s <> " van elk pakketbestand wordt bewaard." _ -> s <> " of each package file will be kept." cleanCache_4 :: Language -> Doc AnsiStyle @@ -1076,6 +1117,7 @@ Indonesia -> "Selainnya akan dihapus. Ikhlas kan?" Chinese -> "其余的将会被删除。确定？" Esperanto -> "La cetero foriĝos. Ĉu bone?" + Dutch -> "De rest wordt verwijderd. OK?" _ -> "The rest will be deleted. Okay?" cleanCache_5 :: Language -> Doc AnsiStyle @@ -1095,6 +1137,7 @@ Indonesia -> "Pembersihan `cache` dibatalkan secara paksa." Chinese -> "手动清理缓存已中止。" Esperanto -> "Puriganta Kaŝmemoro ĉesis permane." + Dutch -> "Cachereiniging handmatig afgebroken." _ -> "Cache cleaning manually aborted." cleanCache_6 :: Language -> Doc AnsiStyle @@ -1114,8 +1157,17 @@ Indonesia -> "Membersihkan `cache` paket..." Chinese -> "正在清理包缓存..." Esperanto -> "Purigas Kaŝmemoron de pakaĵoj..." + Dutch -> "Pakketcache aan het reinigen..." _ -> "Cleaning package cache..." +cleanCache_7 :: Word -> Word -> Language -> Doc AnsiStyle +cleanCache_7 (bt . tshow -> ps) (bt . tshow -> bytes) = \case + _ -> "The cache contains " <> ps <> " packages, consuming " <> bytes <> " megabytes." + +cleanCache_8 :: Word -> Language -> Doc AnsiStyle +cleanCache_8 (bt . tshow -> bytes) = \case + _ -> bytes <> " megabytes freed." + -- NEEDS TRANSLATION cleanNotSaved_1 :: Language -> Doc AnsiStyle cleanNotSaved_1 = \case @@ -1133,6 +1185,7 @@ Chinese -> "正在确定不需要的包文件..." Swedish -> "Beräknar onödiga paketfiler..." Esperanto -> "Decidas nebezonajn dosierojn de pakaĵoj..." + Dutch -> "Overbodige pakketbestanden aan het vaststellen..." _ -> "Determining unneeded package files..." -- NEEDS TRANSLATION @@ -1152,6 +1205,7 @@ Chinese -> "发现了 " <> s <> " 个不需要的包文件。是否删除？" Swedish -> s <> " oanvända paket hittades. Ta bort?" Esperanto -> s <> " nebezonajn dosierojn de pakaĵoj trovis. Ĉu forigi" + Dutch -> s <> " overbodige pakketbestanden gevonden. Verwijderen?" _ -> s <> " unneeded package files found. Delete?" ---------------------------- @@ -1180,6 +1234,7 @@ Indonesia -> "Tidak terlihat pada berkas log:" Chinese -> "这些没有在日志文件中出现：" Esperanto -> "Ĉi tiuj ne enestis la protokolajn dosierojn:" + Dutch -> "Deze zijn niet verschenen in het logbestand:" _ -> "These have not appeared in the log file:" ------------------------------- @@ -1187,21 +1242,22 @@ ------------------------------- -- https://github.com/fosskers/aura/issues/498 -connectionFailure_1 :: Language -> Doc AnsiStyle -connectionFailure_1 = \case +connectFailure_1 :: Language -> Doc AnsiStyle +connectFailure_1 = \case Spanish -> "No se pudo contactar con el AUR. ¿Tienes conexión a internet?" Italian -> "Non è stato possibile contattare l'AUR. Il computer è connesso ad internet?" + Dutch -> "Contact opnemen met de AUR mislukt. Heeft U een internet connectie?" _ -> "Failed to contact the AUR. Do you have an internet connection?" miscAURFailure_1 :: Language -> Doc AnsiStyle miscAURFailure_1 = \case Italian -> "C'è stato un errore sconosciuto nel contattare l'AUR." + Dutch -> "Contact opnemen met de AUR is op een onbekende manier mislukt." _ -> "Contacting the AUR failed in some unknown way." -miscAURFailure_2 :: Language -> Doc AnsiStyle -miscAURFailure_2 = \case - Italian -> "Il server dell'AUR ha rifiutato la richiesta." - _ -> "The AUR server rejected the request." +miscAURFailure_3 :: Language -> Doc AnsiStyle +miscAURFailure_3 = \case + _ -> "The JSON returned from the AUR server could not be decoded." infoFields :: Language -> [Text] infoFields = sequence [ Fields.repository @@ -1236,6 +1292,7 @@ Indonesia -> "Ketinggalan Zaman!" Chinese -> "过期！" Esperanto -> "Neĝisdata!" + Dutch -> "Verouderd!" _ -> "Out of Date!" outOfDateMsg Nothing = green . \case Japanese -> "最新" @@ -1253,6 +1310,7 @@ Indonesia -> "Mutakhir" Chinese -> "最新" Esperanto -> "Ĝisdata" + Dutch -> "Up-to-date" _ -> "Up to Date" -- NEEDS TRANSLATION @@ -1273,6 +1331,7 @@ Chinese -> "孤包！" Swedish -> "Föräldralös!" Esperanto -> "Orfita!" + Dutch -> "Verweest!" _ -> "Orphaned!" ----------------------- @@ -1296,6 +1355,7 @@ Chinese -> "已保存包状态。" Swedish -> "Det lokala pakettillståndet har sparats." Esperanto -> "Konservita stato de pakaĵo." + Dutch -> "Pakketstatus opgeslagen." _ -> "Saved package state." -- NEEDS TRANSLATION @@ -1316,6 +1376,7 @@ Chinese -> "请求的降级版本对以下包不可用：" Swedish -> "Den begärda nedgraderingen finns inte tillgänglig för:" Esperanto -> "Petitajn malpromociajn versiojn ne estas disponebla de:" + Dutch -> "Verzochtte downgrade versies niet beschikbaar voor:" _ -> "Requested downgrade versions not available for:" restoreState_2 :: Language -> Doc AnsiStyle @@ -1328,6 +1389,7 @@ Chinese -> "没有要恢复的已保存状态。（使用 -B 保存当前状态）" Swedish -> "Inga sparade tillstånd att återhämta. (Använd -B för att spara det nuvarande tillståndet)" Esperanto -> "Ne konservitaj statoj restaŭros. (Uzu -B konservi la aktualan staton)" + Dutch -> "Er zijn geen opgeslagen statussen om te herstellen. (Gebruik -B om de huidige staat op te slaan)" _ -> "No saved states to be restored. (Use -B to save the current state)" -- NEEDS TRANSLATION @@ -1348,6 +1410,7 @@ Chinese -> "没有包需要改变。" Swedish -> "Inga paket behöver ändras." Esperanto -> "Ne pakaĵoj devas ŝanĝiĝi." + Dutch -> "Er zijn geen pakketten die wijzigingen nodig hebben." _ -> "No packages need changing." -------------------------------------- @@ -1360,6 +1423,7 @@ Russian -> "Не удается определить, от имени какого пользователя производить сборку." Italian -> "Non è stato possibile determinare l'utente che eseguirà la compilazione." Esperanto -> "Ne povas decidi, per kiu konto de uzanto munti." + Dutch -> "Kan niet bepalen met welk gebruikers account te bouwen." _ -> "Can't determine which user account to build with." ------------------------ @@ -1383,6 +1447,7 @@ Chinese -> "请检查你的输入。" Swedish -> "Var god dubbelkolla indata." Esperanto -> "Bonvolu kontroli vian enigon." + Dutch -> "Controleer alstublieft uw input." _ -> "Please check your input." confParsing_1 :: Language -> Doc AnsiStyle @@ -1392,19 +1457,21 @@ Russian -> "Не удается распознать формат вашего файла pacman.conf." Italian -> "Non è stato possibile analizzare il file pacman.conf." Esperanto -> "Ne kapablas sintaske analizi vian dosieron, pacman.conf." + Dutch -> "Niet in staat om uw pacman.conf bestand te parseren." _ -> "Unable to parse your pacman.conf file." provides_1 :: PkgName -> Language -> Doc AnsiStyle -provides_1 (bt . view (field @"name") -> pro) = \case +provides_1 (bt . pnName -> pro) = \case Spanish -> pro <+> "se requiere como una dependencia, que es proporcionada por múltiples paquetes. Por favor, seleccione uno:" Italian -> pro <+> "è richiesto come dipendenza; si trova in molteplici pacchetti. Selezionarne uno:" + Dutch -> pro <+> "is vereist als afhankelijkheid, die wordt geleverd door meerdere pakketten. Selecteer er alstublieft een:" _ -> pro <+> "is required as a dependency, which is provided by multiple packages. Please select one:" ---------------------------------- -- Aura/Pkgbuild/Editing functions ---------------------------------- hotEdit_1 :: PkgName -> Language -> Doc AnsiStyle -hotEdit_1 (bt . view (field @"name") -> p) = \case +hotEdit_1 (bt . pnName -> p) = \case Japanese -> p <> "のPKGBUILDを編成しますか？" Polish -> "Czy chcesz edytować PKGBUILD " <> p <> "?" Croatian -> "Želite li izmjeniti PKGBUILD " <> p <> "?" @@ -1420,26 +1487,9 @@ Indonesia -> "Apakah anda ingin menyunting PKGBUILD untuk paket " <> p <> "?" Chinese -> "你希望编辑 " <> p <> " 的 PKGBUILD 文件吗？" Esperanto -> "Ĉu vi volas redakti la PKGBUILD de " <> p <> "?" + Dutch -> "Wilt u het PKGBUILD-bestand van " <> p <> " bewerken?" _ -> "Would you like to edit the PKGBUILD of " <> p <> "?" -customizepkg_1 :: Language -> Doc AnsiStyle -customizepkg_1 = let customizepkg = bt "customizepkg" in \case - Japanese -> customizepkg <+> "はインストールされていません。" - Polish -> customizepkg <+> "nie zainstalowany." - Croatian -> customizepkg <+> "nije instaliran." - German -> customizepkg <+> "ist nicht installiert." - Spanish -> customizepkg <+> "no está instalado." - Norwegian -> customizepkg <+> "er ikke installert." - Italian -> customizepkg <+> "non è installato." - Portuguese -> customizepkg <+> "não está instalado." - French -> customizepkg <+> "n'est pas installé." - Russian -> customizepkg <+> "не установлен." - Indonesia -> customizepkg <+> "tidak terinstal." - Chinese -> customizepkg <+> " 没有被安装。" - Swedish -> customizepkg <+> "är inte installerad" - Esperanto -> customizepkg <+> "ne estas instalita." - _ -> customizepkg <+> "isn't installed." - ------------------------------ -- Pkgbuild Security functions ------------------------------ @@ -1447,60 +1497,70 @@ security_1 (PkgName p) = \case Spanish -> "El PKGBUILD de" <+> bt p <+> "era demasiado complejo de analizar - puede estar ofuscando código malicioso." Italian -> "Il PKGBUILD di" <+> bt p <+> "è troppo complesso per essere analizzato - è possibile che stia offuscando codice malevolo." + Dutch -> "Het PKGBUILD-bestand van" <+> bt p <+> " was te complex om te parseren - het kan schadelijke code versluieren." _ -> "The PKGBUILD of" <+> bt p <+> "was too complex to parse - it may be obfuscating malicious code." 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." Italian -> t <+> "può essere usato per scaricare script arbitrari non tracciati da questo PKGBUILD." + Dutch -> t <+> "kan gebruikt worden om willekeurige scripten te downloaden die niet worden bijgehouden door dit PKGBUILD-bestand." _ -> t <+> "can be used to download arbitrary scripts that aren't tracked by this PKGBUILD." 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." Italian -> t <+> "può essere usato per eseguire codice arbitrario non tracciato da questo PKGBUILD." + Dutch -> t <+> "kan gebruikt worden om willekeurige code uit te voeren die niet worden bijgehouden door dit PKGBUILD-bestand." _ -> t <+> "can be used to execute arbitrary code not tracked by this PKGBUILD." 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." Italian -> t <+> "indica che forse qualcuno sta cercando di ottenere accesso alla tua macchina come root." + Dutch -> t <+> "geeft aan dat iemand mogelijk root-toegang to uw machine probeert te krijgen." _ -> t <+> "indicates that someone may be trying to gain root access to your machine." security_5 :: PkgName -> Language -> Doc AnsiStyle security_5 (PkgName p) = \case Spanish -> "ADVERTENCIA: El PKGBUILD de" <+> bt p <+> "contiene expresiones bash en la lista negra." Italian -> "ATTENZIONE: Il PKGBUILD di" <+> bt p <+> "contiene espressioni bash presenti nella lista nera." + Dutch -> "WAARSCHUWING: De PKGBUILD van" <+> bt p <+> "bevat bash uitdrukkingen die op de zwarte lijst staan." _ -> "WARNING: The PKGBUILD of" <+> bt p <+> "contains blacklisted bash expressions." security_6 :: Language -> Doc AnsiStyle security_6 = \case Spanish -> "¿Desea salir del proceso de compilación?" Italian -> "Terminare la compilazione?" + Dutch -> "Wilt u het bouw process stoppen?" _ -> "Do you wish to quit the build process?" security_7 :: Language -> Doc AnsiStyle security_7 = \case Spanish -> "Se canceló el procesamiento posterior para evitar el código bash potencialmente malicioso." Italian -> "Non saranno eseguite altre operazioni al fine di evitare l'esecuzione di codice bash potenzialmente malevolo." + Dutch -> "Verdere verwerking geannuleerd om het uitvoeren van potentieel schadelijke bash-code te voorkomen." _ -> "Cancelled further processing to avoid potentially malicious bash code." 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." Italian -> t <+> "è un comando bash presente all'interno degli array del tuo PKGBUILD." + Dutch -> t <+> "is een bash-opdracht die is opgenomen in uw PKGBUILD-arrayvelden." _ -> t <+> "is a bash command inlined in your PKGBUILD array fields." 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?" Italian -> t <+> "è una cosa strana da trovare all'interno degli array. E' sicura?" + Dutch -> t <+> "is een vreemd ding om in uw arrayvelden te hebben. Is het veilig?" _ -> t <+> "is a strange thing to have in your array fields. Is it safe?" 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." Italian -> t <+> "implica che qualcuno stava trafficando con le variabili per nascondere comandi malevoli." + Dutch -> t <+> "impliceert dat iemand slim probeerde om te gaan met variabelen om schadelijke opdrachten te verbergen." _ -> t <+> "implies that someone was trying to be clever with variables to hide malicious commands." ----------------------- @@ -1518,6 +1578,7 @@ French -> "[O/n]" Russian -> "[Д/н]" Esperanto -> "[J/n]" + Dutch -> "[J/n]" _ -> "[Y/n]" yesPattern :: Language -> [T.Text] @@ -1532,6 +1593,7 @@ French -> ["o", "oui"] Russian -> ["д", "да"] Esperanto -> ["j", "jes"] + Dutch -> ["j", "ja"] _ -> ["y", "yes"] ---------------------- 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + {-# OPTIONS_HADDOCK prune #-} -- | @@ -31,6 +33,7 @@ Norwegian -> "Pakke" Indonesia -> "Paket" Esperanto -> "Pakaĵo" + Dutch -> "Pakket" _ -> "Package" firstInstall :: Language -> Text @@ -49,6 +52,7 @@ Norwegian -> "Første installasjon" Indonesia -> "Versi sistem" Esperanto -> "Unua Instalo" + Dutch -> "Eerste installatie" _ -> "First Install" upgrades :: Language -> Text @@ -67,6 +71,7 @@ Norwegian -> "Oppgraderinger" Indonesia -> "Tingkatkan" Esperanto -> "Noveldonoj" + Dutch -> "Upgrades" _ -> "Upgrades" recentActions :: Language -> Text @@ -85,6 +90,7 @@ Norwegian -> "Nylige hendelser" Indonesia -> "Aksi sekarang" Esperanto -> "Ĵusaj Agoj" + Dutch -> "Recente Acties" _ -> "Recent Actions" repository :: Language -> Text @@ -103,6 +109,7 @@ Norwegian -> "Depot" Indonesia -> "Lumbung" Esperanto -> "Deponejo" + Dutch -> "Repository" _ -> "Repository" name :: Language -> Text @@ -121,6 +128,7 @@ Norwegian -> "Navn" Indonesia -> "Nama" Esperanto -> "Nomo" + Dutch -> "Naam" _ -> "Name" version :: Language -> Text @@ -139,6 +147,7 @@ Norwegian -> "Versjon" Indonesia -> "Versi" Esperanto -> "Versio" + Dutch -> "Versie" _ -> "Version" aurStatus :: Language -> Text @@ -155,6 +164,7 @@ Serbian -> "Статус у AUR-у" Indonesia -> "Status AUR" Esperanto -> "Stato en AUR" + Dutch -> "AUR Status" _ -> "AUR Status" -- NEEDS TRANSLATION @@ -169,6 +179,7 @@ Norwegian -> "Vedlikeholder" Indonesia -> "Pemelihara" Esperanto -> "Daŭriganto" + Dutch -> "Onderhouder" _ -> "Maintainer" projectUrl :: Language -> Text @@ -187,6 +198,7 @@ Norwegian -> "Prosjekt-URL" Indonesia -> "URL Proyek" Esperanto -> "URL de Projekto" + Dutch -> "Project URL" _ -> "Project URL" aurUrl :: Language -> Text @@ -202,6 +214,7 @@ Serbian -> "Страница у AUR-у" Indonesia -> "URL AUR" Esperanto -> "URL en AUR" + Dutch -> "AUR URL" _ -> "AUR URL" license :: Language -> Text @@ -220,6 +233,7 @@ Norwegian -> "Lisens" Indonesia -> "Lisensi" Esperanto -> "Permesilo" + Dutch -> "Licentie" _ -> "License" dependsOn :: Language -> Text @@ -236,6 +250,7 @@ Norwegian -> "Er avhengig av" Indonesia -> "Bergantung pada" Esperanto -> "Dependi de" + Dutch -> "Hangt af van" _ -> "Depends On" buildDeps :: Language -> Text @@ -249,6 +264,7 @@ Italian -> "Dipendenze di compilazione" Indonesia -> "Dependensi bangun" Esperanto -> "Muntaj Dependecoj" + Dutch -> "Bouw afhankelijkheden" _ -> "Build Deps" votes :: Language -> Text @@ -267,6 +283,7 @@ Norwegian -> "Stemmer" Indonesia -> "Suara" Esperanto -> "Balotiloj" + Dutch -> "Stemmen" _ -> "Votes" popularity :: Language -> Text @@ -276,6 +293,7 @@ Portuguese -> "Popularidade" Italian -> "Popolarità" Esperanto -> "Populareco" + Dutch -> "Populairiteit" _ -> "Popularity" description :: Language -> Text @@ -294,18 +312,5 @@ Norwegian -> "Beskrivelse" Indonesia -> "Deskripsi" Esperanto -> "Priskribo" + Dutch -> "Beschrijving" _ -> "Description" - -makeDeps :: Language -> Text -makeDeps = \case - Polish -> "Zależności Make" - Croatian -> "Make Zavisnosti" - German -> "Make-Abhängigkeiten" - Spanish -> "Dependencias de compilación" - Portuguese -> "Dependências de compilação" - French -> "Dépendances de compilation" - Russian -> "Зависимости Make" - Italian -> "Dipendenze di compilazione" - Indonesia -> "Dependensi bangun" - Esperanto -> "Make Dependecoj" - _ -> "Make Deps" diff --git a/lib/Aura/Logo.hs b/lib/Aura/Logo.hs --- a/lib/Aura/Logo.hs +++ b/lib/Aura/Logo.hs @@ -9,10 +9,11 @@ module Aura.Logo ( animateVersionMsg ) where import Aura.Colour (dtot, yellow) +import Aura.IO import Aura.Languages (translatorMsg) import Aura.Pacman (verMsgPad) import Aura.Settings -import Aura.Utils +import Aura.Shell import Data.Text.Prettyprint.Doc import RIO import qualified RIO.Text as T diff --git a/lib/Aura/MakePkg.hs b/lib/Aura/MakePkg.hs --- a/lib/Aura/MakePkg.hs +++ b/lib/Aura/MakePkg.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + -- | -- Module : Aura.State -- Copyright : (c) Colin Woodbury, 2012 - 2020 @@ -9,42 +11,34 @@ module Aura.MakePkg ( makepkg , makepkgSource - , makepkgConfFile ) where +import Aura.IO (optionalPrompt) import Aura.Languages import Aura.Settings import Aura.Types -import Aura.Utils (optionalPrompt) -import Control.Error.Util (note) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES +import Aura.Utils (note) import Lens.Micro (_2) import RIO import qualified RIO.ByteString.Lazy as BL +import RIO.Directory +import RIO.FilePath import qualified RIO.NonEmpty as NEL import qualified RIO.Text as T -import System.Path - (Absolute, Path, fromAbsoluteFilePath, toFilePath, ()) -import System.Path.IO (getCurrentDirectory, getDirectoryContents) import System.Process.Typed --- --- | The default location of the makepkg configuration: \/etc\/makepkg.conf -makepkgConfFile :: Path Absolute -makepkgConfFile = fromAbsoluteFilePath "/etc/makepkg.conf" - -makepkgCmd :: Path Absolute -makepkgCmd = fromAbsoluteFilePath "/usr/bin/makepkg" +makepkgCmd :: FilePath +makepkgCmd = "/usr/bin/makepkg" -- | Given the current user name, build the package of whatever -- directory we're in. -makepkg :: Settings -> User -> IO (Either Failure (NESet (Path Absolute))) +makepkg :: Settings -> User -> IO (Either Failure (NonEmpty FilePath)) makepkg ss usr = make ss usr (proc cmd $ opts <> colour) >>= g where (cmd, opts) = runStyle usr . map T.unpack . foldMap asFlag . makepkgFlagsOf $ buildConfigOf ss - g (ExitSuccess, _, fs) = pure . note (Failure buildFail_9) . fmap NES.fromList $ NEL.nonEmpty fs + g (ExitSuccess, _, fs) = pure . note (Failure buildFail_9) $ NEL.nonEmpty fs g (ExitFailure _, se, _) = do unless (switch ss DontSuppressMakepkg) $ do showError <- optionalPrompt ss buildFail_11 @@ -57,25 +51,32 @@ -- | Actually build the package, guarding on exceptions. -- Yields the filepaths of the built package tarballs. -make :: MonadIO m => Settings -> User -> ProcessConfig stdin stdout stderr -> m (ExitCode, BL.ByteString, [Path Absolute]) +make :: MonadIO m + => Settings + -> User + -> ProcessConfig stdin stdout stderr + -> m (ExitCode, BL.ByteString, [FilePath]) 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) . T.lines . decodeUtf8Lenient . BL.toStrict $ res ^. _2 + res <- readProcess $ proc "sudo" ["-u", T.unpack usr, makepkgCmd, "--packagelist"] + let fs = map 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) +runIt :: MonadIO m + => Settings + -> ProcessConfig stdin stdout stderr + -> m (ExitCode, BL.ByteString) runIt ss pc | switch ss DontSuppressMakepkg = (,mempty) <$> runProcess pc | otherwise = (\(ec, _, se) -> (ec, se)) <$> readProcess pc -- | Make a source package. See `man makepkg` and grep for `--allsource`. -makepkgSource :: User -> IO [Path Absolute] +makepkgSource :: User -> IO [FilePath] makepkgSource usr = do void . runProcess $ proc cmd opts pwd <- getCurrentDirectory - filter (T.isSuffixOf ".src.tar.gz" . T.pack . toFilePath) . map (pwd ) <$> getDirectoryContents pwd + filter (T.isSuffixOf ".src.tar.gz" . T.pack) . map (pwd ) <$> getDirectoryContents pwd where (cmd, opts) = runStyle usr ["--allsource"] -- | As of makepkg v4.2, building with `--asroot` is no longer allowed. runStyle :: User -> [String] -> (FilePath, [String]) -runStyle (User usr) opts = ("sudo", ["-u", T.unpack usr, toFilePath makepkgCmd] <> opts) +runStyle (User usr) opts = ("sudo", ["-u", T.unpack usr, makepkgCmd] <> opts) 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 @@ -1,7 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + -- | -- Module : Aura.Packages.AUR -- Copyright : (c) Colin Woodbury, 2012 - 2020 @@ -28,38 +27,33 @@ import Aura.Pkgbuild.Fetch import Aura.Settings import Aura.Types -import Aura.Utils (fmapEither, groupsOf) -import Control.Error.Util (hush, note) +import Aura.Utils import Control.Monad.Trans.Maybe import Control.Scheduler (Comp(..), traverseConcurrently) -import Data.Generics.Product (field) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES import Data.Versions (versioning) import Lens.Micro (each, non, (^..)) import Linux.Arch.Aur import Network.HTTP.Client (Manager) import RIO +import RIO.Directory +import RIO.FilePath import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.NonEmpty as NEL import qualified RIO.Set as S import qualified RIO.Text as T -import Servant.Client.Core (responseBody) -import System.Path -import System.Path.IO (getCurrentDirectory) import System.Process.Typed --- -- | Attempt to retrieve info about a given `Set` of packages from the AUR. -aurLookup :: Manager -> NESet PkgName -> IO (Maybe (Set PkgName, Set Buildable)) +aurLookup :: Manager -> NonEmpty 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 let (bads, goods) = partitionEithers badsgoods - goodNames = S.fromList $ goods ^.. each . field @"name" - pure (S.fromList bads <> NES.toSet names S.\\ goodNames, S.fromList goods) + goodNames = S.fromList $ goods ^.. each . to bName + pure (S.fromList bads <> S.fromList (NEL.toList names) S.\\ goodNames, S.fromList goods) -- | Yield fully realized `Package`s from the AUR. aurRepo :: IO Repository @@ -68,7 +62,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 (Set PkgName, Set Package)) + let f :: Settings -> NonEmpty PkgName -> IO (Maybe (Set PkgName, Set Package)) f ss ps = do --- Retrieve cached Packages --- cache <- readTVarIO tv @@ -77,7 +71,7 @@ case NEL.nonEmpty uncached of Nothing -> pure $ Just (S.empty, S.fromList cached) Just uncached' -> runMaybeT $ do - (bads, goods) <- MaybeT . aurLookup (managerOf ss) $ NES.fromList uncached' + (bads, goods) <- MaybeT $ aurLookup (managerOf ss) uncached' pkgs <- lift . traverse (packageBuildable ss) $ toList goods --- Update Cache --- let m = M.fromList $ map (pname &&& id) pkgs @@ -94,42 +88,48 @@ case (,) <$> mpb <*> mver of Nothing -> pure . Left . PkgName $ aurNameOf ai Just (pb, ver) -> pure $ Right Buildable - { name = PkgName $ aurNameOf ai - , version = ver - , base = bse - , provides = providesOf ai ^. to listToMaybe . non (aurNameOf ai) . to (Provides . PkgName) + { bName = PkgName $ aurNameOf ai + , bVersion = ver + , bBase = bse + , bProvides = providesOf ai ^. to listToMaybe . non (aurNameOf ai) . to (Provides . PkgName) -- TODO This is a potentially naughty mapMaybe, since deps that fail to -- parse will be silently dropped. Unfortunately there isn't much to be -- done - `aurLookup` and `aurRepo` which call this function only report -- existence errors (i.e. "this package couldn't be found at all"). - , deps = mapMaybe parseDep $ dependsOf ai ++ makeDepsOf ai - , pkgbuild = pb - , isExplicit = False } + , bDeps = mapMaybe parseDep $ dependsOf ai ++ makeDepsOf ai + , bPkgbuild = pb + , bIsExplicit = False } ---------------- -- AUR PKGBUILDS ---------------- -aurLink :: Path Unrooted -aurLink = fromUnrootedFilePath "https://aur.archlinux.org" +aurLink :: FilePath +aurLink = "https://aur.archlinux.org" -- | A package's home URL on the AUR. pkgUrl :: PkgName -> Text -pkgUrl (PkgName pkg) = T.pack . toUnrootedFilePath $ aurLink fromUnrootedFilePath "packages" fromUnrootedFilePath (T.unpack pkg) +pkgUrl (PkgName pkg) = T.pack $ aurLink "packages" T.unpack pkg ------------------- -- SOURCES FROM GIT ------------------- -- | Attempt to clone a package source from the AUR. -clone :: Buildable -> IO (Maybe (Path Absolute)) +clone :: Buildable -> IO (Maybe FilePath) clone b = do - ec <- runProcess . setStderr closed . setStdout closed $ proc "git" [ "clone", "--depth", "1", toUnrootedFilePath url ] + ec <- runProcess . setStderr closed . setStdout closed + $ proc "git" [ "clone", "--depth", "1", url ] case ec of - (ExitFailure _) -> pure Nothing - ExitSuccess -> do + ExitFailure _ -> pure Nothing + ExitSuccess -> do pwd <- getCurrentDirectory - pure . Just $ pwd (b ^. field @"base" . field @"name" . to (fromUnrootedFilePath . T.unpack)) - where url = aurLink (b ^. field @"base" . field @"name" . to (fromUnrootedFilePath . T.unpack)) <.> FileExt "git" + pure . Just $ pwd pathy + where + pathy :: FilePath + pathy = T.unpack . pnName $ bBase b + url :: FilePath + url = aurLink pathy <.> "git" + ------------ -- RPC CALLS ------------ @@ -143,7 +143,7 @@ aurSearch :: Text -> RIO Env [AurInfo] aurSearch regex = do ss <- asks settings - res <- liftMaybeM (Failure connectionFailure_1) . fmap hush . liftIO $ search (managerOf ss) regex + res <- liftMaybeM (Failure connectFailure_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@. @@ -155,11 +155,11 @@ <$> traverseConcurrently Par' (work m) (groupsOf 50 $ NEL.toList pkgs) where work :: Manager -> [PkgName] -> RIO Env [AurInfo] - work m ps = liftIO (info m $ map (^. field @"name") ps) >>= \case - Left (ConnectionError _) -> throwM (Failure connectionFailure_1) - Left (FailureResponse _ r) -> do - let !resp = display . decodeUtf8Lenient . toStrictBytes $ responseBody r + work m ps = liftIO (info m $ map pnName ps) >>= \case + Left (NotFound _) -> throwM (Failure connectFailure_1) + Left BadJSON -> throwM (Failure miscAURFailure_3) + Left (OtherAurError e) -> do + let !resp = display $ decodeUtf8Lenient e logDebug $ "Failed! Server said: " <> resp - throwM (Failure miscAURFailure_2) - Left _ -> throwM (Failure miscAURFailure_1) + throwM (Failure miscAURFailure_1) Right res -> pure 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 @@ -1,5 +1,4 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TupleSections #-} -- | -- Module : Aura.Packages.Repository @@ -15,19 +14,18 @@ ) where import Aura.Core +import Aura.IO import Aura.Languages (provides_1) import Aura.Pacman (pacmanLines, pacmanOutput) import Aura.Settings (CommonSwitch(..), Settings(..), shared) import Aura.Types -import Aura.Utils (fmapEither, getSelection, traverseEither) -import Control.Error.Util (hush, note) +import Aura.Utils import Control.Scheduler (Comp(..), traverseConcurrently) -import Data.Generics.Product (field) -import qualified Data.Set.NonEmpty as NES import Data.Versions import RIO hiding (try) import qualified RIO.Map as M import qualified RIO.Set as S +import qualified RIO.Text as T import Text.Megaparsec import Text.Megaparsec.Char @@ -38,14 +36,17 @@ pacmanRepo :: IO Repository pacmanRepo = do tv <- newTVarIO mempty + -- A mutex to ensure that the user will only be prompted for one input at a + -- time. + mv <- newMVar () - let g :: Settings -> NES.NESet PkgName -> IO (Maybe (Set PkgName, Set Package)) + let g :: Settings -> NonEmpty PkgName -> IO (Maybe (Set PkgName, Set Package)) g ss names = do --- Retrieve cached Packages --- cache <- readTVarIO tv let (uncached, cached) = fmapEither (\p -> note p $ M.lookup p cache) $ toList names --- Lookup uncached Packages --- - bgs <- traverseConcurrently Par' (resolveName ss) uncached + bgs <- traverseConcurrently Par' (resolveName mv ss) uncached let (bads, goods) = partitionEithers bgs (bads', goods') <- traverseEither f goods -- TODO Should also be made concurrent? --- Update Cache --- @@ -58,33 +59,46 @@ f (r, p) = fmap (FromRepo . packageRepo r p) <$> mostRecent r packageRepo :: PkgName -> Provides -> Versioning -> Prebuilt -packageRepo pn pro ver = Prebuilt { name = pn - , version = ver - , base = pn - , provides = pro } +packageRepo pn pro ver = Prebuilt { pName = pn + , pVersion = ver + , pBase = pn + , pProvides = pro } -- TODO Bind to libalpm /just/ for the @-Ssq@ functionality. These shell -- calls are one of the remaining bottlenecks. -- | If given a virtual package, try to find a real package to install. -resolveName :: Settings -> PkgName -> IO (Either PkgName (PkgName, Provides)) -resolveName ss pn = do - provs <- map PkgName <$> pacmanLines ["-Ssq", "^" <> (pn ^. field @"name") <> "$"] +resolveName :: MVar () -> Settings -> PkgName -> IO (Either PkgName (PkgName, Provides)) +resolveName mv ss pn = do + provs <- map PkgName <$> pacmanLines ["-Ssq", "^" <> escape (pnName pn) <> "$"] case provs of [] -> pure $ Left pn - _ -> Right . (, Provides pn) <$> chooseProvider ss pn provs + _ -> Right . (, Provides pn) <$> chooseProvider mv ss pn provs + where + escape :: Text -> Text + escape = T.foldl' f "" --- | Choose a providing package, favoring installed packages. + f :: Text -> Char -> Text + f acc '+' = acc <> "\\+" + f acc c = T.snoc acc c + +-- | Choose a providing package, favouring installed packages. -- If `--noconfirm` is provided, it will try to automatically select the provider -- with the same name as the dependency. If that doesn't exist, it will select -- the first available provider. -chooseProvider :: Settings -> PkgName -> [PkgName] -> IO PkgName -chooseProvider _ pn [] = pure pn -chooseProvider _ _ [p] = pure p -chooseProvider ss pn ps@(a:as) = +chooseProvider :: MVar () -> Settings -> PkgName -> [PkgName] -> IO PkgName +chooseProvider _ _ pn [] = pure pn +chooseProvider _ _ _ [p] = pure p +chooseProvider mv ss pn ps@(a:as) = traverseConcurrently Par' isInstalled ps >>= maybe f pure . listToMaybe . catMaybes where + f :: IO PkgName f | shared ss NoConfirm = pure . bool a pn $ pn `elem` ps - | otherwise = warn ss (provides_1 pn $ langOf ss) >> getSelection (^. field @"name") (a :| as) + | otherwise = do + void $ takeMVar mv + warn ss $ provides_1 pn + r <- getSelection pnName (a :| as) + putMVar mv () + pure r -- | The most recent version of a package, if it exists in the respositories. mostRecent :: PkgName -> IO (Either PkgName Versioning) diff --git a/lib/Aura/Pacman.hs b/lib/Aura/Pacman.hs --- a/lib/Aura/Pacman.hs +++ b/lib/Aura/Pacman.hs @@ -32,17 +32,15 @@ import Aura.Languages import Aura.Types import Data.Bifunctor (first) -import Data.Set.NonEmpty (NESet) -import Lens.Micro (at, (^?), _2, _Just, _head) -import Lens.Micro.GHC () +import Lens.Micro (_2) import RIO hiding (first, some, try) import qualified RIO.ByteString as BS import qualified RIO.ByteString.Lazy as BL +import RIO.FilePath 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) import Text.Megaparsec.Char @@ -74,21 +72,21 @@ garbage = L.space space1 (L.skipLineComment "#") (L.skipBlockComment "[" "]") -- | Default location of the pacman config file: \/etc\/pacman.conf -pacmanConfFile :: Path Absolute -pacmanConfFile = fromAbsoluteFilePath "/etc/pacman.conf" +pacmanConfFile :: FilePath +pacmanConfFile = "/etc/pacman.conf" -- | Default location of the pacman log flie: \/var\/log\/pacman.log -defaultLogFile :: Path Absolute -defaultLogFile = fromAbsoluteFilePath "/var/log/pacman.log" +defaultLogFile :: FilePath +defaultLogFile = "/var/log/pacman.log" -- | Default location of the pacman database lock file: \/var\/lib\/pacman\/db.lck -lockFile :: Path Absolute -lockFile = fromAbsoluteFilePath "/var/lib/pacman/db.lck" +lockFile :: FilePath +lockFile = "/var/lib/pacman/db.lck" -- | Given a filepath to the pacman config, try to parse its contents. -getPacmanConf :: Path Absolute -> IO (Either Failure Config) +getPacmanConf :: FilePath -> IO (Either Failure Config) getPacmanConf fp = do - file <- decodeUtf8Lenient <$> BS.readFile (toFilePath fp) + file <- decodeUtf8Lenient <$> BS.readFile fp pure . first (const (Failure confParsing_1)) $ parse config "pacman config" file -- | Fetches the @IgnorePkg@ entry from the config, if it's there. @@ -100,19 +98,23 @@ getIgnoredGroups (Config c) = maybe S.empty (S.fromList . map PkgGroup) $ M.lookup "IgnoreGroup" c -- | Given a `Set` of package groups, yield all the packages they contain. -groupPackages :: NESet PkgGroup -> IO (Set PkgName) +groupPackages :: NonEmpty PkgGroup -> IO (Set PkgName) groupPackages igs = fmap (f . decodeUtf8Lenient) . pacmanOutput $ "-Qg" : asFlag igs where 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) -getCachePath (Config c) = c ^? at "CacheDir" . _Just . _head . to (fromAbsoluteFilePath . T.unpack) +getCachePath :: Config -> Maybe FilePath +getCachePath (Config c) = do + fp <- T.unpack <$> (M.lookup "CacheDir" c >>= listToMaybe) + bool Nothing (Just fp) $ isAbsolute fp -- | Fetches the @LogFile@ entry from the config, if it's there. -getLogFilePath :: Config -> Maybe (Path Absolute) -getLogFilePath (Config c) = c ^? at "LogFile" . _Just . _head . to (fromAbsoluteFilePath . T.unpack) +getLogFilePath :: Config -> Maybe FilePath +getLogFilePath (Config c) = do + fp <- T.unpack <$> (M.lookup "LogFile" c >>= listToMaybe) + bool Nothing (Just fp) $ isAbsolute fp ---------- -- ACTIONS 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 @@ -11,15 +11,16 @@ ) where import Aura.Types +import RIO +import RIO.FilePath import qualified RIO.Text as T -import System.Path --- -- | The default location: \/var\/cache\/aura\/pkgbuilds\/ -pkgbuildCache :: Path Absolute -pkgbuildCache = fromAbsoluteFilePath "/var/cache/aura/pkgbuilds/" +pkgbuildCache :: FilePath +pkgbuildCache = "/var/cache/aura/pkgbuilds/" -- | The expected path to a stored PKGBUILD, given some package name. -pkgbuildPath :: PkgName -> Path Absolute -pkgbuildPath (PkgName p) = pkgbuildCache fromUnrootedFilePath (T.unpack p) <.> FileExt "pb" +pkgbuildPath :: PkgName -> FilePath +pkgbuildPath (PkgName p) = pkgbuildCache T.unpack p <.> "pb" 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE DataKinds #-} - -- | -- Module : Aura.Pkgbuild.Base -- Copyright : (c) Colin Woodbury, 2012 - 2020 @@ -10,16 +8,12 @@ module Aura.Pkgbuild.Editing ( hotEdit ) where +import Aura.IO 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 RIO.Directory import System.Process.Typed (proc, runProcess) --- @@ -29,23 +23,27 @@ -- package building. edit :: (FilePath -> IO a) -> Buildable -> IO Buildable edit f p = do - writeFileBinary filename $ p ^. field @"pkgbuild" . field @"pkgbuild" + writeFileBinary filename . pkgbuild $ bPkgbuild p void $ f filename newPB <- readFileBinary filename - pure (p & field @"pkgbuild" .~ Pkgbuild newPB) - where filename = "PKGBUILD" + pure (p { bPkgbuild = Pkgbuild newPB}) + where + filename :: FilePath + filename = "PKGBUILD" -- | Allow the user to edit the PKGBUILD if they asked to do so. hotEdit :: Settings -> Buildable -> IO Buildable hotEdit ss b | not $ switch ss HotEdit = pure b | otherwise = do - ans <- liftIO $ optionalPrompt ss (hotEdit_1 $ b ^. field @"name") + ans <- liftIO $ optionalPrompt ss (hotEdit_1 $ bName b) bool (pure b) f ans - where f = do - here <- getCurrentDirectory - tmp <- getTemporaryDirectory - setCurrentDirectory $ toFilePath tmp - b' <- edit (runProcess . proc (editorOf ss) . (:[])) b - setCurrentDirectory $ toFilePath here - pure b' + where + f :: IO Buildable + f = do + here <- getCurrentDirectory + tmp <- getTemporaryDirectory + setCurrentDirectory tmp + b' <- edit (runProcess . proc (editorOf ss) . (:[])) b + setCurrentDirectory here + pure b' 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -16,7 +15,6 @@ import Aura.Types (PkgName(..), Pkgbuild(..)) import Aura.Utils (urlContents) -import Data.Generics.Product (field) import Network.HTTP.Client (Manager) import Network.URI (escapeURIString, isUnescapedInURIComponent) import RIO @@ -36,7 +34,7 @@ -- | The PKGBUILD of a given package, retrieved from the AUR servers. getPkgbuild :: Manager -> PkgName -> IO (Maybe Pkgbuild) getPkgbuild m p = e $ do - t <- urlContents m . pkgbuildUrl . T.unpack $ p ^. field @"name" + t <- urlContents m . pkgbuildUrl . T.unpack $ pnName p pure $ fmap Pkgbuild t where -- TODO Make this less "baby's first Haskell". 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE DataKinds #-} - -- | -- Module : Aura.Pkgbuild.Records -- Copyright : (c) Colin Woodbury, 2012 - 2020 @@ -15,11 +13,8 @@ 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) +import RIO.Directory --- @@ -29,10 +24,10 @@ hasPkgbuildStored = doesFileExist . pkgbuildPath -- | Write the PKGBUILDs of some `Buildable`s to disk. -storePkgbuilds :: NESet Buildable -> IO () +storePkgbuilds :: NonEmpty Buildable -> IO () storePkgbuilds bs = do createDirectoryIfMissing True pkgbuildCache - traverse_ (\p -> writePkgbuild (p ^. field @"name") (p ^. field @"pkgbuild")) bs + traverse_ (\p -> writePkgbuild (bName p) (bPkgbuild p)) bs writePkgbuild :: PkgName -> Pkgbuild -> IO () -writePkgbuild pn (Pkgbuild pb) = writeFileBinary (toFilePath $ pkgbuildPath pn) pb +writePkgbuild pn (Pkgbuild pb) = writeFileBinary (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 @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} -- | -- Module : Aura.Pkgbuild.Security @@ -16,13 +17,12 @@ import Aura.Languages import Aura.Types (Language, Pkgbuild(..)) -import Control.Error.Util (hush) -import Data.Generics.Product (typed, types) +import Aura.Utils (hush) 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 Language.Bash.Word import Lens.Micro (each, (.~), (^..), _Just) import RIO hiding (Word) import qualified RIO.Map as M @@ -34,6 +34,9 @@ -- either a sign of maintainer negligence or malicious behaviour. data BannedTerm = BannedTerm Text BanCategory deriving (Eq, Ord, Show, Generic) +banCatL :: Lens' BannedTerm BanCategory +banCatL f (BannedTerm t bc) = BannedTerm t <$> f bc + -- | The reason why the bash term is black-listed. data BanCategory = Downloading | ScriptRunning @@ -65,27 +68,89 @@ -- | Extract all `SimpleCommand`s from a parsed bash AST. simpleCommands :: List -> [ShellCommand] -simpleCommands l = l ^.. types @ShellCommand . to p . each - where p sc@(SimpleCommand _ _) = [sc] - p sc = sc ^.. types @List . to simpleCommands . each +simpleCommands (List ss) = ss >>= statements >>= p + where + p :: ShellCommand -> [ShellCommand] + p sc@(SimpleCommand _ _) = [sc] + p sc = lists sc >>= simpleCommands + statements :: Statement -> [ShellCommand] + statements (Statement ao _) = andor ao + + andor :: AndOr -> [ShellCommand] + andor (Last pl) = pipeline pl + andor (And pl ao) = pipeline pl <> andor ao + andor (Or pl ao) = pipeline pl <> andor ao + + pipeline :: Pipeline -> [ShellCommand] + pipeline (Pipeline _ _ _ cs) = map command cs + + command :: Command -> ShellCommand + command (Command sc _) = sc + + lists :: ShellCommand -> [List] + lists (SimpleCommand _ _) = [] + lists (AssignBuiltin _ _) = [] + lists (FunctionDef _ l) = [l] + lists (Coproc _ c) = lists $ command c + lists (Subshell l) = [l] + lists (Group l) = [l] + lists (Arith _) = [] + lists (Cond _) = [] + lists (For _ _ l) = [l] + lists (ArithFor _ l) = [l] + lists (Select _ _ l) = [l] + lists (Case _ ccs) = map caseClause ccs + lists (If l1 l2 ml) = l1 : l2 : maybeToList ml + lists (Until l1 l2) = [l1, l2] + lists (While l1 l2) = [l1, l2] + + caseClause :: CaseClause -> List + caseClause (CaseClause _ l _) = l + bannedCommand :: ShellCommand -> [(ShellCommand, BannedTerm)] bannedCommand s@(SimpleCommand [] (g:c:_)) | g == [Char 'g', Char 'i', Char 't'] && c == [Char 'c', Char 'l', Char 'o', Char 'n', Char 'e'] = [(s, BannedTerm "git" Downloading)] bannedCommand s@(SimpleCommand [] (c:_)) = maybeToList $ (s,) <$> banned c -bannedCommand s@(SimpleCommand as _) = as ^.. each . typed @RValue . to r . each +bannedCommand s@(SimpleCommand as _) = as ^.. each . rValueL . to r . each where - r rv@(RValue w) = maybeToList ((s,) <$> (banned w & _Just . typed @BanCategory .~ CleverRedirect)) <> q rv + r rv@(RValue w) = maybeToList ((s,) <$> (banned w & _Just . banCatL .~ CleverRedirect)) <> q rv r rv = q rv q :: RValue -> [(ShellCommand, BannedTerm)] - q rv = rv ^.. types @Word . each . to p . each . to (s,) + q rv = map (s,) $ join (rWords rv) >>= p + p :: Span -> [BannedTerm] p (CommandSubst str) = maybeToList (hush $ parse "CommandSubst" str) >>= simpleCommands >>= map snd . bannedCommand p (ArithSubst str) = [BannedTerm (T.pack str) StrangeBashism] p (ProcessSubst _ str) = [BannedTerm (T.pack str) StrangeBashism] - p sp = sp ^.. types @Word . each . to p . each + p sp = join (sWords sp) >>= p + + rWords :: RValue -> [Word] + rWords (RValue w) = [w] + rWords (RArray ws) = ws >>= \(mw, w) -> w : maybeToList mw + + sWords :: Span -> [Word] + sWords (Single w) = [w] + sWords (Double w) = [w] + sWords (ANSIC w) = [w] + sWords (Locale w) = [w] + sWords (Backquote w) = [w] + sWords (ParamSubst ps) = subWords ps + sWords _ = [] + + subWords :: ParamSubst -> [Word] + subWords (Bare (Parameter _ mw)) = maybeToList mw + subWords (Brace _ (Parameter _ mw)) = maybeToList mw + subWords (Alt _ (Parameter _ mw) _ _ w) = w : maybeToList mw + subWords (Substring _ (Parameter _ mw) w1 w2) = w1 : w2 : maybeToList mw + subWords (Prefix _ _) = [] + subWords (Indices (Parameter _ mw)) = maybeToList mw + subWords (Length (Parameter _ mw)) = maybeToList mw + subWords (Delete _ (Parameter _ mw) _ _ w) = w : maybeToList mw + subWords (Replace _ (Parameter _ mw) _ _ w1 w2) = w1 : w2 : maybeToList mw + subWords (LetterCase _ (Parameter _ mw) _ _ w) = w : maybeToList mw bannedCommand _ = [] ------------ @@ -101,3 +166,10 @@ InlinedBash -> security_8 t StrangeBashism -> security_9 t CleverRedirect -> security_10 t + +-------- +-- UTILS +-------- + +rValueL :: Lens' Assign RValue +rValueL f (Assign p ao r) = Assign p ao <$> f r diff --git a/lib/Aura/Settings.hs b/lib/Aura/Settings.hs --- a/lib/Aura/Settings.hs +++ b/lib/Aura/Settings.hs @@ -11,6 +11,7 @@ module Aura.Settings ( Settings(..) + , logFuncOfL -- * Aura Configuration , BuildConfig(..), BuildSwitch(..) , switch @@ -29,7 +30,6 @@ import RIO import qualified RIO.Set as S import qualified RIO.Text as T -import System.Path (Absolute, Path, fromAbsoluteFilePath, toFilePath) --- @@ -48,16 +48,16 @@ -- Aura will react to them, but also pass them through to `pacman` -- calls if necessary. data CommonConfig = CommonConfig - { cachePathOf :: !(Either (Path Absolute) (Path Absolute)) - , configPathOf :: !(Either (Path Absolute) (Path Absolute)) - , logPathOf :: !(Either (Path Absolute) (Path Absolute)) + { cachePathOf :: !(Either FilePath FilePath) + , configPathOf :: !(Either FilePath FilePath) + , logPathOf :: !(Either FilePath FilePath) , commonSwitchesOf :: !(Set CommonSwitch) } deriving (Show, Generic) instance Flagable CommonConfig where asFlag (CommonConfig cap cop lfp cs) = - either (const []) (\p -> ["--cachedir", T.pack $ toFilePath p]) cap - <> either (const []) (\p -> ["--config", T.pack $ toFilePath p]) cop - <> either (const []) (\p -> ["--logfile", T.pack $ toFilePath p]) lfp + either (const []) (\p -> ["--cachedir", T.pack p]) cap + <> either (const []) (\p -> ["--config", T.pack p]) cop + <> either (const []) (\p -> ["--logfile", T.pack p]) lfp <> asFlag cs -- | Yes/No-style switches that are common to both Aura and Pacman. @@ -84,7 +84,7 @@ -- | Settings unique to the AUR package building process. data BuildConfig = BuildConfig { makepkgFlagsOf :: !(Set Makepkg) - , buildPathOf :: !(Path Absolute) + , buildPathOf :: !FilePath , buildUserOf :: !(Maybe User) , truncationOf :: !Truncation -- For `-As` , buildSwitchesOf :: !(Set BuildSwitch) } deriving (Show) @@ -101,6 +101,7 @@ | UseCustomizepkg | ForceBuilding | NoPkgbuildCheck + | AsDeps deriving (Eq, Ord, Show) -- | Is some Aura-specific setting turned on for this run? @@ -121,9 +122,13 @@ , ignoresOf :: !(Set PkgName) , commonConfigOf :: !CommonConfig , buildConfigOf :: !BuildConfig + , logLevelOf :: !LogLevel , logFuncOf :: !LogFunc } deriving stock (Generic) +logFuncOfL :: Lens' Settings LogFunc +logFuncOfL f s = (\lf -> s { logFuncOf = lf }) <$> f (logFuncOf s) + -- | Unless otherwise specified, packages will be built within @/tmp@. -defaultBuildDir :: Path Absolute -defaultBuildDir = fromAbsoluteFilePath "/tmp" +defaultBuildDir :: FilePath +defaultBuildDir = "/tmp" diff --git a/lib/Aura/Shell.hs b/lib/Aura/Shell.hs new file mode 100644 --- /dev/null +++ b/lib/Aura/Shell.hs @@ -0,0 +1,71 @@ +-- | +-- Module : Aura.Shell +-- Copyright : (c) Colin Woodbury, 2012 - 2020 +-- License : GPL3 +-- Maintainer: Colin Woodbury +-- +-- Interaction with the terminal. + +module Aura.Shell where + +import Aura.Types +import RIO +import qualified RIO.ByteString as B +import qualified RIO.Map as M +import qualified RIO.Text as T +import System.Process.Typed (proc, runProcess) + +--- + +-- | Code borrowed from `ansi-terminal` library by Max Bolingbroke. +csi :: [Int] -> ByteString -> ByteString +csi args code = "\ESC[" <> B.intercalate ";" (map (encodeUtf8 . textDisplay) args) <> code + +-- | Terminal code for raising the cursor. +cursorUpLineCode :: Int -> ByteString +cursorUpLineCode n = csi [n] "F" + +-- | This will get the true user name regardless of sudo-ing. +getTrueUser :: Environment -> Maybe User +getTrueUser env | isTrueRoot env = Just $ User "root" + | hasRootPriv env = User <$> M.lookup "SUDO_USER" env + | otherwise = User <$> M.lookup "USER" env + +-- | Is the current user of Aura the true @root@ user, and not just a sudo user? +isTrueRoot :: Environment -> Bool +isTrueRoot env = M.lookup "USER" env == Just "root" && not (M.member "SUDO_USER" env) + +-- | Is the user root, or using sudo? +hasRootPriv :: Environment -> Bool +hasRootPriv env = M.member "SUDO_USER" env || isTrueRoot env + +-- | `vi` is a sensible default, it should be installed by +-- on any Arch system. +getEditor :: Environment -> FilePath +getEditor = maybe "vi" T.unpack . M.lookup "EDITOR" + +-- | This will get the locale variable for translations from the environment +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`. +chown :: MonadIO m => User -> FilePath -> [String] -> m () +chown (User usr) pth args = void . runProcess $ proc "chown" (args <> [T.unpack usr, pth]) + +-- | Hide the cursor in a terminal. +hideCursor :: IO () +hideCursor = B.putStr hideCursorCode + +-- | Restore a cursor to visiblity in the terminal. +showCursor :: IO () +showCursor = B.putStr showCursorCode + +hideCursorCode :: ByteString +hideCursorCode = csi [] "?25l" + +showCursorCode :: ByteString +showCursorCode = csi [] "?25h" + +-- | Raise the cursor by @n@ lines. +raiseCursorBy :: Int -> IO () +raiseCursorBy = B.putStr . cursorUpLineCode diff --git a/lib/Aura/State.hs b/lib/Aura/State.hs --- a/lib/Aura/State.hs +++ b/lib/Aura/State.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DataKinds #-} - -- | -- Module : Aura.State -- Copyright : (c) Colin Woodbury, 2012 - 2020 @@ -21,17 +19,18 @@ import Aura.Cache import Aura.Colour (red) import Aura.Core (Env(..), notify, report, warn) +import Aura.IO import Aura.Languages import Aura.Pacman (pacman, pacmanLines) import Aura.Settings import Aura.Types -import Aura.Utils -import Control.Error.Util (hush) +import Aura.Utils (hush) import Data.Aeson -import Data.Generics.Product (field) import Data.Versions import RIO import qualified RIO.ByteString.Lazy as BL +import RIO.Directory +import RIO.FilePath import qualified RIO.List as L import RIO.List.Partial ((!!)) import qualified RIO.Map as M @@ -39,8 +38,6 @@ import qualified RIO.NonEmpty as NEL import qualified RIO.Text as T import RIO.Time -import System.Path -import System.Path.IO (createDirectoryIfMissing, getDirectoryContents) import Text.Printf (printf) --- @@ -70,8 +67,8 @@ , _toRemove :: ![PkgName] } -- | The default location of all saved states: \/var\/cache\/aura\/states -stateCache :: Path Absolute -stateCache = fromAbsoluteFilePath "/var/cache/aura/states" +stateCache :: FilePath +stateCache = "/var/cache/aura/states" -- | Does a given package have an entry in a particular `PkgState`? inState :: SimplePkg -> PkgState -> Bool @@ -103,7 +100,7 @@ olds old curr = map (uncurry SimplePkg) . M.assocs $ M.difference (pkgsOf old) (pkgsOf curr) -- | The filepaths of every saved package state. -getStateFiles :: IO [Path Absolute] +getStateFiles :: IO [FilePath] getStateFiles = do createDirectoryIfMissing True stateCache L.sort . map (stateCache ) <$> getDirectoryContents stateCache @@ -113,10 +110,10 @@ saveState :: Settings -> IO () saveState ss = do state <- currentState - let filename = stateCache fromUnrootedFilePath (dotFormat (timeOf state)) <.> FileExt "json" + let filename = stateCache dotFormat (timeOf state) <.> "json" createDirectoryIfMissing True stateCache - BL.writeFile (toFilePath filename) $ encode state - notify ss . saveState_1 $ langOf ss + BL.writeFile filename $ encode state + notify ss saveState_1 dotFormat :: ZonedTime -> String dotFormat (ZonedTime t _) = L.intercalate "." items @@ -134,7 +131,7 @@ restoreState :: RIO Env () restoreState = liftIO getStateFiles >>= maybe (throwM $ Failure restoreState_2) f . NEL.nonEmpty - where f :: NonEmpty (Path Absolute) -> RIO Env () + where f :: NonEmpty FilePath -> RIO Env () f sfs = do ss <- asks settings let pth = either id id . cachePathOf $ commonConfigOf ss @@ -146,25 +143,24 @@ Cache cache <- liftIO $ cacheContents pth let StateDiff rein remo = compareStates past curr (okay, nope) = L.partition (`M.member` cache) rein - traverse_ (report red restoreState_1 . fmap (^. field @"name")) $ NEL.nonEmpty nope + traverse_ (report red restoreState_1 . fmap spName) $ NEL.nonEmpty nope reinstallAndRemove (mapMaybe (`M.lookup` cache) okay) remo -selectState :: NonEmpty (Path Absolute) -> IO (Path Absolute) -selectState = getSelection (T.pack . toFilePath) +selectState :: NonEmpty FilePath -> IO FilePath +selectState = getSelection T.pack -- | Given a `FilePath` to a package state file, attempt to read and parse -- its contents. As of Aura 2.0, only state files in JSON format are accepted. -readState :: Path Absolute -> IO (Maybe PkgState) -readState = fmap decode . BL.readFile . toFilePath +readState :: FilePath -> IO (Maybe PkgState) +readState = fmap decode . BL.readFile -- | `reinstalling` can mean true reinstalling, or just altering. reinstallAndRemove :: [PackagePath] -> [PkgName] -> RIO Env () -reinstallAndRemove [] [] = asks settings >>= \ss -> - liftIO (warn ss . reinstallAndRemove_1 $ langOf ss) +reinstallAndRemove [] [] = asks settings >>= \ss -> warn ss reinstallAndRemove_1 reinstallAndRemove down remo | null remo = reinstall | null down = remove | otherwise = reinstall *> remove where remove = liftIO . pacman $ "-R" : asFlag remo - reinstall = liftIO . pacman $ "-U" : map (T.pack . toFilePath . path) down + reinstall = liftIO . pacman $ "-U" : map (T.pack . ppPath) down diff --git a/lib/Aura/Types.hs b/lib/Aura/Types.hs --- a/lib/Aura/Types.hs +++ b/lib/Aura/Types.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -22,7 +19,7 @@ , Dep(..), parseDep, renderedDep , Buildable(..) , Prebuilt(..) - , SimplePkg(..), simplepkg, simplepkg' + , SimplePkg(..), simplepkg, simplepkg', bToSP, pToSP -- * Typeclasses , Flagable(..) -- * Package Building @@ -37,28 +34,22 @@ , PkgName(..) , PkgGroup(..) , Provides(..) - , PackagePath(..) + , PackagePath, packagePath, ppPath , Pkgbuild(..) , Environment , User(..) ) where -import Control.Error.Util (hush) +import Aura.Utils import Data.Aeson (FromJSONKey, ToJSONKey) -import Data.Bifunctor (Bifunctor(..)) import Data.Bitraversable -import Data.Generics.Product (field, super) -import Data.Semigroup.Foldable (Foldable1(..)) -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NES 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 Lens.Micro import RIO hiding (try) +import RIO.FilePath import qualified RIO.Text as T -import System.Path (Absolute, Path, takeFileName, toUnrootedFilePath) import Text.Megaparsec import Text.Megaparsec.Char @@ -79,56 +70,57 @@ -- | The name of a `Package`. pname :: Package -> PkgName -pname (FromRepo pb) = pb ^. field @"name" -pname (FromAUR b) = b ^. field @"name" +pname (FromRepo pb) = pName pb +pname (FromAUR b) = bName b -- | Other names which allow this `Package` to be satisfied as a dependency. pprov :: Package -> Provides -pprov (FromRepo pb) = pb ^. field @"provides" -pprov (FromAUR b) = b ^. field @"provides" +pprov (FromRepo pb) = pProvides pb +pprov (FromAUR b) = bProvides b -- | The version of a `Package`. pver :: Package -> Versioning -pver (FromRepo pb) = pb ^. field @"version" -pver (FromAUR b) = b ^. field @"version" +pver (FromRepo pb) = pVersion pb +pver (FromAUR b) = bVersion b -dividePkgs :: NESet Package -> These (NESet Prebuilt) (NESet Buildable) -dividePkgs = bimap NES.fromList NES.fromList . partNonEmpty f . NES.toList +dividePkgs :: NonEmpty Package -> These (NonEmpty Prebuilt) (NonEmpty Buildable) +dividePkgs = partNonEmpty f where f :: Package -> These Prebuilt Buildable f (FromRepo p) = This p f (FromAUR b) = That b --- TODO Contribute this upstream. --- | Partition a `NonEmpty` based on some function. -partNonEmpty :: (a -> These b c) -> NonEmpty a -> These (NonEmpty b) (NonEmpty c) -partNonEmpty f = foldMap1 (bimap pure pure . f) - -- TODO Figure out how to do this more generically. instance Ord Package where compare (FromAUR a) (FromAUR b) = compare a b compare (FromRepo a) (FromRepo b) = compare a b - compare (FromAUR a) (FromRepo b) = compare (a ^. super @SimplePkg) (b ^. super @SimplePkg) - compare (FromRepo a) (FromAUR b) = compare (a ^. super @SimplePkg) (b ^. super @SimplePkg) + compare (FromAUR a) (FromRepo b) = compare (bToSP a) (pToSP b) + compare (FromRepo a) (FromAUR b) = compare (pToSP a) (bToSP b) -- | A `Package` from the AUR that's buildable in some way on the user's machine. -data Buildable = Buildable { name :: !PkgName - , version :: !Versioning - , base :: !PkgName - , provides :: !Provides - , deps :: ![Dep] - , pkgbuild :: !Pkgbuild - , isExplicit :: !Bool } deriving (Eq, Ord, Show, Generic) +data Buildable = Buildable + { bName :: !PkgName + , bVersion :: !Versioning + , bBase :: !PkgName + , bProvides :: !Provides + , bDeps :: ![Dep] + , bPkgbuild :: !Pkgbuild + , bIsExplicit :: !Bool } + deriving (Eq, Ord, Show, Generic) -- | A prebuilt `Package` from the official Arch repositories. -data Prebuilt = Prebuilt { name :: !PkgName - , version :: !Versioning - , base :: !PkgName - , provides :: !Provides } deriving (Eq, Ord, Show, Generic) +data Prebuilt = Prebuilt + { pName :: !PkgName + , pVersion :: !Versioning + , pBase :: !PkgName + , pProvides :: !Provides } + deriving (Eq, Ord, Show, Generic) -- | A dependency on another package. -data Dep = Dep { name :: !PkgName - , demand :: !VersionDemand } deriving (Eq, Ord, Show, Generic) +data Dep = Dep + { dName :: !PkgName + , dDemand :: !VersionDemand } + deriving (Eq, Ord, Show, Generic) -- | Parse a dependency entry as it would appear in a PKGBUILD: -- @@ -142,17 +134,18 @@ n = PkgName <$> takeWhile1P Nothing (\c -> c /= '<' && c /= '>' && c /= '=') v = do end <- atEnd - if | end -> pure Anything - | otherwise -> choice [ char '<' *> fmap LessThan versioning' - , string ">=" *> fmap AtLeast versioning' - , char '>' *> fmap MoreThan versioning' - , char '=' *> fmap MustBe versioning' - , pure Anything ] + if end + then pure Anything + else choice [ char '<' *> fmap LessThan versioning' + , string ">=" *> fmap AtLeast versioning' + , char '>' *> fmap MoreThan versioning' + , char '=' *> fmap MustBe versioning' + , pure Anything ] -- | Renders the `Dep` into a form that @pacman -T@ understands. The dual of -- `parseDep`. renderedDep :: Dep -> Text -renderedDep (Dep n ver) = (n ^. field @"name") <> asT ver +renderedDep (Dep n ver) = pnName n <> asT ver where asT :: VersionDemand -> Text asT (LessThan v) = "<" <> prettyV v @@ -170,11 +163,11 @@ deriving (Eq, Ord) instance Show VersionDemand where - show (LessThan v) = T.unpack $ "<" <> prettyV v - show (AtLeast v) = T.unpack $ ">=" <> prettyV v - show (MoreThan v) = T.unpack $ ">" <> prettyV v - show (MustBe v) = T.unpack $ "=" <> prettyV v - show Anything = "Anything" + show (LessThan v) = T.unpack $ "<" <> prettyV v + show (AtLeast v) = T.unpack $ ">=" <> prettyV v + show (MoreThan v) = T.unpack $ ">" <> prettyV v + show (MustBe v) = T.unpack $ "=" <> prettyV v + show Anything = "Anything" -- | Attempt to zoom into the `Versioning` hiding within a `VersionDemand`. _VersionDemand :: Traversal' VersionDemand Versioning @@ -189,26 +182,35 @@ -- | A package name with its version number. data SimplePkg = SimplePkg - { name :: !PkgName - , version :: !Versioning } + { spName :: !PkgName + , spVersion :: !Versioning } deriving (Eq, Ord, Show, Generic) +bToSP :: Buildable -> SimplePkg +bToSP b = SimplePkg (bName b) (bVersion b) + +pToSP :: Prebuilt -> SimplePkg +pToSP p = SimplePkg (pName p) (pVersion p) + -- | Attempt to create a `SimplePkg` from filepaths like -- @\/var\/cache\/pacman\/pkg\/linux-3.2.14-1-x86_64.pkg.tar.xz@ simplepkg :: PackagePath -> Maybe SimplePkg -simplepkg (PackagePath t) = uncurry SimplePkg <$> bitraverse hush hush (parse n "name" t', parse v "version" t') - where t' = T.pack . toUnrootedFilePath $ takeFileName t +simplepkg (PackagePath t) = + uncurry SimplePkg <$> bitraverse hush hush (parse n "name" t', parse v "version" t') + where + t' :: Text + t' = T.pack $ takeFileName t - n :: Parsec Void Text PkgName - n = PkgName . T.pack <$> manyTill anySingle (try finished) + n :: Parsec Void Text PkgName + n = PkgName . T.pack <$> manyTill anySingle (try finished) - -- | Assumes that a version number will never start with a letter, - -- and that a package name section (i.e. abc-def-ghi) will never start - -- with a number. - finished = char '-' *> lookAhead digitChar - v = manyTill anySingle (try finished) *> ver - ver = try (fmap Ideal semver' <* post) <|> try (fmap General version' <* post) <|> fmap Complex mess' - post = char '-' *> (string "x86_64" <|> string "any") *> string ".pkg.tar.xz" + -- | Assumes that a version number will never start with a letter, + -- and that a package name section (i.e. abc-def-ghi) will never start + -- with a number. + finished = char '-' *> lookAhead digitChar + v = manyTill anySingle (try finished) *> ver + ver = try (fmap Ideal semver' <* post) <|> try (fmap General version' <* post) <|> fmap Complex mess' + post = char '-' *> (string "x86_64" <|> string "any") *> string ".pkg.tar.xz" -- | Attempt to create a `SimplePkg` from text like: -- xchat 2.8.8-19 @@ -221,19 +223,28 @@ -- * \/var\/cache\/pacman\/pkg\/linux-3.2.14-1-x86_64.pkg.tar.xz -- * \/var\/cache\/pacman\/pkg\/wine-1.4rc6-1-x86_64.pkg.tar.xz -- * \/var\/cache\/pacman\/pkg\/ruby-1.9.3_p125-4-x86_64.pkg.tar.xz -newtype PackagePath = PackagePath { path :: Path Absolute } deriving (Eq, Generic) +newtype PackagePath = PackagePath { ppPath :: FilePath } + deriving (Eq, Generic) -- | If they have the same package names, compare by their versions. -- Otherwise, do raw comparison of the path string. instance Ord PackagePath where - compare a b | nameA /= nameB = compare (path a) (path b) + compare a b | nameA /= nameB = compare (ppPath a) (ppPath b) | otherwise = compare verA verB - where (nameA, verA) = f a - (nameB, verB) = f b - f = ((^? _Just . field @"name") &&& (^? _Just . field @"version")) . simplepkg + where + (nameA, verA) = f a + (nameB, verB) = f b + f :: PackagePath -> (Maybe PkgName, Maybe Versioning) + f = (fmap spName &&& fmap spVersion) . simplepkg + +-- | Smart constructor for `PackagePath`. +packagePath :: FilePath -> Maybe PackagePath +packagePath fp = bool Nothing (Just $ PackagePath fp) $ isAbsolute fp + -- | The contents of a PKGBUILD file. -newtype Pkgbuild = Pkgbuild { pkgbuild :: 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 @@ -252,10 +263,11 @@ | Indonesia | Chinese | Esperanto + | Dutch deriving (Eq, Enum, Bounded, Ord, Show) -- | The various ways that dependency resolution can fail. -data DepError = NonExistant PkgName +data DepError = NonExistant PkgName PkgName | VerConflict (Doc AnsiStyle) | Ignored (Doc AnsiStyle) | BrokenProvides PkgName Provides PkgName @@ -273,18 +285,20 @@ type Environment = Map Text Text -- | The name of a user account on a Linux system. -newtype User = User { user :: 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 :: Text } +newtype PkgName = PkgName { pnName :: 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 :: Text } +newtype PkgGroup = PkgGroup { pgGroup :: Text } deriving stock (Eq, Ord, Show, Generic) deriving newtype (Flagable) -- | The dependency which some package provides. May not be the same name -- as the package itself (e.g. cronie provides cron). -newtype Provides = Provides { provides :: PkgName } deriving (Eq, Ord, Show, Generic) +newtype Provides = Provides { provides :: PkgName } + deriving (Eq, Ord, Show, Generic) diff --git a/lib/Aura/Utils.hs b/lib/Aura/Utils.hs --- a/lib/Aura/Utils.hs +++ b/lib/Aura/Utils.hs @@ -9,52 +9,37 @@ module Aura.Utils ( -- * Strings Pattern(..) - , replaceByPatt, searchLines + , searchLines -- * Network , urlContents - -- * Shell - , csi, cursorUpLineCode, hideCursor, showCursor, raiseCursorBy - , getTrueUser, getEditor, getLocale - , hasRootPriv, isTrueRoot - , chown - -- * File IO - , ifFile - -- * Output - , putStrLnA - , putText - , putTextLn - , colourCheck - , entrify - -- * User Input - , optionalPrompt - , getSelection - -- * Misc. - , maybe' + -- * Semigroupoids + , foldMap1 + , fold1 + -- * Errors + , hush + , note + -- * Compactable , fmapEither , traverseEither + -- * These + , These(..) + , these + -- * Misc. + , maybe' , groupsOf + , nes + , partNonEmpty ) where -import Aura.Colour -import Aura.Languages (whitespace, yesNoMessage, yesPattern) -import Aura.Settings -import Aura.Types (Environment, Language, User(..)) -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Terminal +import Data.Bifunctor import Network.HTTP.Client import Network.HTTP.Types.Status (statusCode) import RIO -import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import qualified RIO.List as L -import RIO.List.Partial (maximum) -import qualified RIO.Map as M +import qualified RIO.NonEmpty as NEL +import qualified RIO.Set as S 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) --- @@ -64,43 +49,10 @@ -- | 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] -> Text -> Text -replaceByPatt [] l = l -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 `Text`. searchLines :: Text -> [Text] -> [Text] searchLines pat = filter (T.isInfixOf pat) ------ --- IO ------ --- | Given a number of selections, allows the user to choose one. -getSelection :: Foldable f => (a -> Text) -> f a -> IO a -getSelection f choiceLabels = do - let quantity = length choiceLabels - 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 - BL.putStr ">> " - hFlush stdout - userChoice <- decodeUtf8Lenient <$> B.getLine - case userChoice `lookup` choices of - Just valid -> pure valid - Nothing -> getSelection f choiceLabels -- Ask again. - --- | If a file exists, it performs action `t` on the argument. --- | If the file doesn't exist, it performs `f` and returns the argument. -ifFile :: MonadIO m => (a -> m a) -> m b -> Path Absolute -> a -> m a -ifFile t f file x = liftIO (doesFileExist file) >>= bool (f $> x) (t x) - ---------- -- NETWORK ---------- @@ -112,121 +64,9 @@ 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] -> ByteString -> ByteString -csi args code = "\ESC[" <> B.intercalate ";" (map (encodeUtf8 . textDisplay) args) <> code - --- | Terminal code for raising the cursor. -cursorUpLineCode :: Int -> ByteString -cursorUpLineCode n = csi [n] "F" - --- | This will get the true user name regardless of sudo-ing. -getTrueUser :: Environment -> Maybe User -getTrueUser env | isTrueRoot env = Just $ User "root" - | hasRootPriv env = User <$> M.lookup "SUDO_USER" env - | otherwise = User <$> M.lookup "USER" env - --- | Is the current user of Aura the true @root@ user, and not just a sudo user? -isTrueRoot :: Environment -> Bool -isTrueRoot env = M.lookup "USER" env == Just "root" && not (M.member "SUDO_USER" env) - --- | Is the user root, or using sudo? -hasRootPriv :: Environment -> Bool -hasRootPriv env = M.member "SUDO_USER" env || isTrueRoot env - --- | `vi` is a sensible default, it should be installed by --- on any Arch system. -getEditor :: Environment -> FilePath -getEditor = maybe "vi" T.unpack . M.lookup "EDITOR" - --- | This will get the locale variable for translations from the environment -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`. -chown :: MonadIO m => User -> Path Absolute -> [String] -> m () -chown (User usr) pth args = void . runProcess $ proc "chown" (args <> [T.unpack usr, toFilePath pth]) - --- | Hide the cursor in a terminal. -hideCursor :: IO () -hideCursor = B.putStr hideCursorCode - --- | Restore a cursor to visiblity in the terminal. -showCursor :: IO () -showCursor = B.putStr showCursorCode - -hideCursorCode :: ByteString -hideCursorCode = csi [] "?25l" - -showCursorCode :: ByteString -showCursorCode = csi [] "?25h" - --- | Raise the cursor by @n@ lines. -raiseCursorBy :: Int -> IO () -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 = 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. -colourCheck :: Settings -> Doc ann -> Doc ann -colourCheck ss | shared ss (Colour Never) = unAnnotate - | shared ss (Colour Always) = id - | isTerminal ss = id - | otherwise = unAnnotate - -putText :: Text -> IO () -putText = B.putStr . encodeUtf8 - -putTextLn :: Text -> IO () -putTextLn = BL.putStrLn . BL.fromStrict . encodeUtf8 - ----------- --- PROMPTS ----------- -yesNoPrompt :: Settings -> Doc AnsiStyle -> IO Bool -yesNoPrompt ss msg = do - putStrA ss . yellow $ msg <+> yesNoMessage (langOf ss) <> " " - hFlush stdout - response <- decodeUtf8Lenient <$> B.getLine - pure $ isAffirmative (langOf ss) response - --- | An empty response emplies "yes". -isAffirmative :: Language -> Text -> Bool -isAffirmative l t = T.null t || elem (T.toCaseFold t) (yesPattern l) - --- | Doesn't prompt when `--noconfirm` is used. -optionalPrompt :: Settings -> (Language -> Doc AnsiStyle) -> IO Bool -optionalPrompt ss msg | shared ss NoConfirm = pure True - | otherwise = yesNoPrompt ss (msg $ langOf ss) - ------- -- MISC ------- --- | Format two lists into two nice rows a la `-Qi` or `-Si`. -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 - --- | Right-pads strings according to the longest string in the group. -padding :: Settings -> [Text] -> [Text] -padding ss fs = map (T.justifyLeft longest ws) 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 maybe' zero m f = maybe zero f m @@ -255,3 +95,53 @@ go bs = xs : go rest where (xs, rest) = L.splitAt n bs + +nes :: Set a -> Maybe (NonEmpty a) +nes = NEL.nonEmpty . S.toList + +hush :: Either a b -> Maybe b +hush = either (const Nothing) Just + +note :: a -> Maybe b -> Either a b +note a = maybe (Left a) Right + +-- | Borrowed from semigroupoids. +foldMap1 :: Semigroup m => (a -> m) -> NonEmpty a -> m +foldMap1 f (a :| []) = f a +foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs) + +-- | Borrowed from semigroupoids. +fold1 :: Semigroup m => NonEmpty m -> m +fold1 = foldMap1 id + +-- | Partition a `NonEmpty` based on some function. +partNonEmpty :: (a -> These b c) -> NonEmpty a -> These (NonEmpty b) (NonEmpty c) +partNonEmpty f = foldMap1 (bimap pure pure . f) + +-------------------------------------------------------------------------------- +-- These + +data These a b = This a | That b | These a b + +instance (Semigroup a, Semigroup b) => Semigroup (These a b) where + This x <> This y = This (x <> y) + This x <> These z y = These (x <> z) y + This x <> That y = These x y + + That x <> That y = That (x <> y) + That x <> This y = These y x + That x <> These y z = These y (x <> z) + + These w x <> This y = These (w <> y) x + These w x <> That y = These w (x <> y) + These w x <> These y z = These (w <> y) (x <> z) + +instance Bifunctor These where + bimap f _ (This x) = This (f x) + bimap _ g (That y) = That (g y) + bimap f g (These x y) = These (f x) (g y) + +these :: (a -> t) -> (b -> t) -> (a -> b -> t) -> These a b -> t +these f _ _ (This a) = f a +these _ g _ (That b) = g b +these _ _ h (These a b) = h a b diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -8,8 +8,8 @@ import Data.Versions import RIO import qualified RIO.Map as M +import RIO.Partial -- import Language.Bash.Pretty (prettyText) -import System.Path import Test.Tasty import Test.Tasty.HUnit import Text.Megaparsec @@ -45,7 +45,7 @@ ] , testGroup "Aura.Types" [ testCase "simplepkg" - $ simplepkg (PackagePath $ fromAbsoluteFilePath "/var/cache/pacman/pkg/linux-is-cool-3.2.14-1-x86_64.pkg.tar.xz") + $ simplepkg (fromJust $ packagePath "/var/cache/pacman/pkg/linux-is-cool-3.2.14-1-x86_64.pkg.tar.xz") @?= Just (SimplePkg "linux-is-cool" . Ideal $ SemVer 3 2 14 [[Digits 1]] []) , testCase "simplepkg'" $ simplepkg' "xchat 2.8.8-19" @?= Just (SimplePkg "xchat" . Ideal $ SemVer 2 8 8 [[Digits 19]] [])