diff --git a/Cabal/Distribution/Fields/Field.hs b/Cabal/Distribution/Fields/Field.hs index c2b97ff7120dc062f37f88ffe7ea62a4158adcee..42108eef5495a4fb7cf5b1591a4851b5a3502537 100644 --- a/Cabal/Distribution/Fields/Field.hs +++ b/Cabal/Distribution/Fields/Field.hs @@ -73,7 +73,7 @@ fieldLineBS (FieldLine _ bs) = bs -- | Section arguments, e.g. name of the library data SectionArg ann = SecArgName !ann !ByteString - -- ^ identifier, or omething which loos like number. Also many dot numbers, i.e. "7.6.3" + -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3" | SecArgStr !ann !ByteString -- ^ quoted string | SecArgOther !ann !ByteString diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs index f2963dbb308b8edb4aa5c8a2353f44970677f2f5..25f65224a1ac38ab96646b4407a0f5368b01b2d8 100644 --- a/Cabal/Distribution/PackageDescription/Check.hs +++ b/Cabal/Distribution/PackageDescription/Check.hs @@ -56,7 +56,7 @@ import Distribution.Types.CondTree import Distribution.Types.ExeDependency import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName -import Distribution.Utils.Generic (isAscii, safeInit) +import Distribution.Utils.Generic (isAscii) import Distribution.Verbosity import Distribution.Version import Language.Haskell.Extension diff --git a/Cabal/Distribution/Simple/Compiler.hs b/Cabal/Distribution/Simple/Compiler.hs index d338a2c8e0389140d17bfec9d12feb9689d67da8..fd0e05af8bdef8124c40634c836a3efa26045545 100644 --- a/Cabal/Distribution/Simple/Compiler.hs +++ b/Cabal/Distribution/Simple/Compiler.hs @@ -73,7 +73,6 @@ module Distribution.Simple.Compiler ( import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.Generic(safeLast) import Distribution.Pretty import Distribution.Compiler diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index ab77115837a7fd6a13d14ebdf662e517966c7bda..39570332d65aff34872fb7f5310fdfccfd61ff7c 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -102,7 +102,6 @@ import Distribution.Backpack.DescribeUnitId import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) import Distribution.Backpack.Id -import Distribution.Utils.Generic import Distribution.Utils.LogProgress import qualified Distribution.Simple.GHC as GHC @@ -972,7 +971,7 @@ dependencySatisfiable -- Reinterpret the "package name" as an unqualified component -- name = LSubLibName $ packageNameToUnqualComponentName depName - -- Check whether a libray exists and is visible. + -- Check whether a library exists and is visible. -- We don't disambiguate between dependency on non-existent or private -- library yet, so we just return a bool and later report a generic error. visible lib = maybe diff --git a/Cabal/Distribution/Simple/HaskellSuite.hs b/Cabal/Distribution/Simple/HaskellSuite.hs index b1be692b3a0642c71fdc21f708d5dcc20acdc9e9..787b3edb0eac89b0830980e2599bd1bee91dfead 100644 --- a/Cabal/Distribution/Simple/HaskellSuite.hs +++ b/Cabal/Distribution/Simple/HaskellSuite.hs @@ -26,7 +26,6 @@ import Distribution.PackageDescription import Distribution.Simple.LocalBuildInfo import Distribution.System (Platform) import Distribution.Compat.Exception -import Distribution.Utils.Generic import Language.Haskell.Extension import Distribution.Simple.Program.Builtin diff --git a/Cabal/Distribution/Simple/Test/Log.hs b/Cabal/Distribution/Simple/Test/Log.hs index a8fa51771edee980dfa4bbc64ed06a42e247e57e..77939f20b0a8d03d94592713f3a821e93e61701d 100644 --- a/Cabal/Distribution/Simple/Test/Log.hs +++ b/Cabal/Distribution/Simple/Test/Log.hs @@ -143,7 +143,7 @@ summarizePackage verbosity packageLog = do where addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) --- | Print a summary of a single test case's result to the console, supressing +-- | Print a summary of a single test case's result to the console, suppressing -- output for certain verbosity or test filter levels. summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () summarizeTest _ _ (GroupLogs {}) = return () diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index 9912edecc839aaaf652a8db3d20395e4136c6ec7..01f81c1969e080a9f261ea57bfcca13db0d98a4d 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -154,6 +154,8 @@ module Distribution.Simple.Utils ( ordNubRight, safeHead, safeTail, + safeLast, + safeInit, unintersperse, wrapText, wrapLine, diff --git a/Cabal/Distribution/Types/BuildInfo.hs b/Cabal/Distribution/Types/BuildInfo.hs index 7682d7ef6141c24d99ca70e0f55efba15043ac68..d8d0fe462f949b6ab094382013f0629fe5fed9f9 100644 --- a/Cabal/Distribution/Types/BuildInfo.hs +++ b/Cabal/Distribution/Types/BuildInfo.hs @@ -82,7 +82,7 @@ data BuildInfo = BuildInfo { -- Example 2: a library that is being built by a foreing tool (e.g. rust) -- and copied and registered together with this library. The -- logic on how this library is built will have to be encoded in a - -- custom Setup for now. Oherwise cabal would need to lear how to + -- custom Setup for now. Otherwise cabal would need to lear how to -- call arbitrary library builders. extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when -- copying. E.g. [libHS<name>_<flavour> | flavour <- extraLibFlavours]. This diff --git a/Cabal/Distribution/Types/PackageDescription.hs b/Cabal/Distribution/Types/PackageDescription.hs index aeb2ed65258bffb46bbd663dfc6c984a9237b51e..a1f563be2b96113a62ecbbe2f708e0d027e5802d 100644 --- a/Cabal/Distribution/Types/PackageDescription.hs +++ b/Cabal/Distribution/Types/PackageDescription.hs @@ -475,6 +475,6 @@ instance L.HasBuildInfos PackageDescription where <*> (traverse . L.buildInfo) f x6 -- benchmarks <*> pure a20 -- data files <*> pure a21 -- data dir - <*> pure a22 -- exta src files + <*> pure a22 -- extra src files <*> pure a23 -- extra temp files <*> pure a24 -- extra doc files diff --git a/Cabal/Distribution/Utils/Generic.hs b/Cabal/Distribution/Utils/Generic.hs index 11da74d198d05a513b98eed7c4374380c7d501ef..993dfa9b69af5fc88eb35d1b3d78b9d5a5a2e4c0 100644 --- a/Cabal/Distribution/Utils/Generic.hs +++ b/Cabal/Distribution/Utils/Generic.hs @@ -369,21 +369,29 @@ listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b bSet = Set.fromList b -- | A total variant of 'head'. +-- +-- @since 3.2.0.0 safeHead :: [a] -> Maybe a safeHead [] = Nothing safeHead (x:_) = Just x -- | A total variant of 'tail'. +-- +-- @since 3.2.0.0 safeTail :: [a] -> [a] safeTail [] = [] safeTail (_:xs) = xs -- | A total variant of 'last'. +-- +-- @since 3.2.0.0 safeLast :: [a] -> Maybe a safeLast [] = Nothing safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) -- | A total variant of 'init'. +-- +-- @since 3.2.0.0 safeInit :: [a] -> [a] safeInit [] = [] safeInit [_] = [] diff --git a/Cabal/Distribution/Utils/IOData.hs b/Cabal/Distribution/Utils/IOData.hs index b77094ec0387dec3ea34e63b61bdaaa003679f89..dad302b2d3b7b216dc9fcdc25c312acb01ac0011 100644 --- a/Cabal/Distribution/Utils/IOData.hs +++ b/Cabal/Distribution/Utils/IOData.hs @@ -78,7 +78,7 @@ instance KnownIODataMode LBS.ByteString where -- This is the dual operation ot 'hGetIODataContents', -- and consequently the handle is closed with `hClose`. -- --- /Note:/ this performes lazy-IO. +-- /Note:/ this performs lazy-IO. -- -- @since 2.2 hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () diff --git a/Cabal/Distribution/Utils/Structured.hs b/Cabal/Distribution/Utils/Structured.hs index 66eb05c8c9e5d7c4733d49709c7ac364f45ffbb9..23f8d4c002f45e75191265652abae0913517ca91 100644 --- a/Cabal/Distribution/Utils/Structured.hs +++ b/Cabal/Distribution/Utils/Structured.hs @@ -49,8 +49,10 @@ module Distribution.Utils.Structured ( -- | These functions operate like @binary@'s counterparts, -- but the serialised version has a structure hash in front. structuredEncode, + structuredEncodeFile, structuredDecode, structuredDecodeOrFailIO, + structuredDecodeFileOrFail, -- * Structured class Structured (structure), MD5, @@ -178,7 +180,7 @@ typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) -- | Flatten 'Structure' into something we can calculate hash of. -- -- As 'Structure' can be potentially infinite. For mutually recursive types, --- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occured +-- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred -- another time. structureBuilder :: Structure -> Builder.Builder structureBuilder s0 = State.evalState (go s0) Map.empty where @@ -262,6 +264,10 @@ structuredEncode => a -> LBS.ByteString structuredEncode x = Binary.encode (Tag :: Tag a, x) +-- | Lazily serialise a value to a file +structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO () +structuredEncodeFile f = LBS.writeFile f . structuredEncode + -- | Structured 'Binary.decode'. -- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure. -- Throws pure exception on invalid inputs. @@ -280,6 +286,10 @@ structuredDecodeOrFailIO bs = handler (ErrorCall str) = return $ Left str #endif +-- | Lazily reconstruct a value previously written to a file. +structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a) +structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f + ------------------------------------------------------------------------------- -- Helper data ------------------------------------------------------------------------------- diff --git a/Cabal/doc/hcar/Cabal-201604.tex b/Cabal/doc/hcar/Cabal-201604.tex index a89f6088f1649344d4e1dec1bd155baaca14b850..74abe2dbde12542457ebb225612346fc38485ed4 100644 --- a/Cabal/doc/hcar/Cabal-201604.tex +++ b/Cabal/doc/hcar/Cabal-201604.tex @@ -94,7 +94,7 @@ features that are currently targeted at 1.26 are: \item Further work on nix-style local builds, perhaps making that code path the default. \item Enabling Hackage Security by default. -\item Native suport for +\item Native support for \href{https://github.com/haskell/cabal/pull/2540}{``foreign libraries''}: Haskell libraries that are intended to be used by non-Haskell code. \item New Parsec-based parser for \texttt{.cabal} files. diff --git a/Cabal/doc/installing-packages.rst b/Cabal/doc/installing-packages.rst index 326e71b4f48dd464ab04a33ff04684346526bd57..c702aba2ee85682a7eb6befa5d93d583acbf8ddc 100644 --- a/Cabal/doc/installing-packages.rst +++ b/Cabal/doc/installing-packages.rst @@ -57,7 +57,7 @@ The name of the repository is given on the first line, and can be anything; packages downloaded from this repository will be cached under ``~/.cabal/packages/hackage.haskell.org`` (or whatever name you specify; you can change the prefix by changing the value of -``remote-repo-cache``). If you want, you can configure multiple +:cfg-field:`remote-repo-cache`). If you want, you can configure multiple repositories, and ``cabal`` will combine them and be able to download packages from any of them. @@ -97,7 +97,32 @@ received were the right ones. How that is done is however outside the scope of ``cabal`` proper. More information about the security infrastructure can be found at -https://github.com/well-typed/hackage-security. +https://github.com/haskell/hackage-security. + +Local no-index repositories +^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +It's possible to use a directory of `.tar.gz` package files as a local package +repository. + +:: + + repository my-local-repository + url: file+noindex:///absolute/path/to/directory + +``cabal`` will construct the index automatically from the +``package-name-version.tar.gz`` files in the directory, and will use optional +corresponding ``package-name-version.cabal`` files as new revisions. + +The index is cached inside the given directory. If the directory is not +writable, you can append ``#shared-cache`` fragment to the URI, +then the cache will be stored inside the :cfg-field:`remote-repo-cache` directory. +The part of the path will be used to determine the cache key part. + +.. note:: + The URI scheme ``file:`` is interpreted as a remote repository, + as described in the previous sections, thus requiring manual construction + of ``01-index.tar`` file. Legacy repositories ^^^^^^^^^^^^^^^^^^^ @@ -120,7 +145,7 @@ although, in (and only in) the specific case of Hackage, the URL ``http://hackage.haskell.org/packages/archive`` will be silently translated to ``http://hackage.haskell.org/``. -The second kind of legacy repositories are so-called “local†+The second kind of legacy repositories are so-called “(legacy) local†repositories: :: diff --git a/Cabal/tests/ParserTests/errors/big-version.cabal b/Cabal/tests/ParserTests/errors/big-version.cabal index 533dae563aa8ca2e8abb9622589eaf025e5fb0a4..f554525735d88b08cb9dea0ecd8b5439db274afb 100644 --- a/Cabal/tests/ParserTests/errors/big-version.cabal +++ b/Cabal/tests/ParserTests/errors/big-version.cabal @@ -1,5 +1,5 @@ cabal-version: 3.0 -name: big-vesion +name: big-version -- 10 digits version: 1234567890 diff --git a/Cabal/tests/ParserTests/regressions/big-version.cabal b/Cabal/tests/ParserTests/regressions/big-version.cabal index 1812bdde664532e0d7e035a10969ec1178482580..054fe029ddb17bd89dcdda192732036e58ebbb1c 100644 --- a/Cabal/tests/ParserTests/regressions/big-version.cabal +++ b/Cabal/tests/ParserTests/regressions/big-version.cabal @@ -1,5 +1,5 @@ cabal-version: 3.0 -name: big-vesion +name: big-version -- 9 digits version: 123456789 diff --git a/Cabal/tests/ParserTests/regressions/big-version.expr b/Cabal/tests/ParserTests/regressions/big-version.expr index 0bfaeb4c370e379d20eee831c6b2021f14ce98ae..b0f67fad70f9b8cea6c5da87a78a31816a09482f 100644 --- a/Cabal/tests/ParserTests/regressions/big-version.expr +++ b/Cabal/tests/ParserTests/regressions/big-version.expr @@ -82,7 +82,7 @@ GenericPackageDescription licenseRaw = Left NONE, maintainer = "", package = PackageIdentifier - {pkgName = `PackageName "big-vesion"`, + {pkgName = `PackageName "big-version"`, pkgVersion = `mkVersion [123456789]`}, pkgUrl = "", setupBuildInfo = Nothing, diff --git a/Cabal/tests/ParserTests/regressions/big-version.format b/Cabal/tests/ParserTests/regressions/big-version.format index c1e68ec0834286fbd5ca7b423d0e7824b67cf183..64885651cdee910594a723ba592935ad3626b0a5 100644 --- a/Cabal/tests/ParserTests/regressions/big-version.format +++ b/Cabal/tests/ParserTests/regressions/big-version.format @@ -1,5 +1,5 @@ cabal-version: 3.0 -name: big-vesion +name: big-version version: 123456789 library diff --git a/Cabal/tests/Test/Laws.hs b/Cabal/tests/Test/Laws.hs index 22ae1ae523a1bfd52eb78b10ddbe905640a00a6c..d4013fdb749b216ad4f05b2c6548b54baf6baa86 100644 --- a/Cabal/tests/Test/Laws.hs +++ b/Cabal/tests/Test/Laws.hs @@ -53,7 +53,7 @@ monoid_2 :: (Eq a, Data.Monoid.Monoid a) => a -> a -> a -> Bool monoid_2 x y z = (x `mappend` y) `mappend` z == x `mappend` (y `mappend` z) --- | The 'mconcat' definition. It can be overidden for the sake of effeciency +-- | The 'mconcat' definition. It can be overidden for the sake of efficiency -- but it must still satisfy the property given by the default definition: -- -- > mconcat = foldr mappend mempty diff --git a/cabal-dev-scripts/cabal-dev-scripts.cabal b/cabal-dev-scripts/cabal-dev-scripts.cabal index a197dc33a25dba30f527d4fab1e51ba832869ce3..05757586ba4c420fdb6c7bdfdf614a10e3308d97 100644 --- a/cabal-dev-scripts/cabal-dev-scripts.cabal +++ b/cabal-dev-scripts/cabal-dev-scripts.cabal @@ -37,7 +37,7 @@ executable gen-spdx , lens ^>=4.18.1 , optparse-applicative ^>=0.15.1.0 , text - , zinza ^>=0.1 + , zinza ^>=0.2 executable gen-spdx-exc default-language: Haskell2010 @@ -54,4 +54,4 @@ executable gen-spdx-exc , lens ^>=4.18.1 , optparse-applicative ^>=0.15.1.0 , text - , zinza ^>=0.1 + , zinza ^>=0.2 diff --git a/cabal-dev-scripts/src/GenSPDX.hs b/cabal-dev-scripts/src/GenSPDX.hs index 0bbce81c6efbd605cb6de4c18d5972a9f8336256..e413488600a9a1c93b7ad57d58ac7b8db4a476f9 100644 --- a/cabal-dev-scripts/src/GenSPDX.hs +++ b/cabal-dev-scripts/src/GenSPDX.hs @@ -8,7 +8,6 @@ import Data.List (sortOn) import Data.Semigroup ((<>)) import Data.Text (Text) import Data.Traversable (for) -import GHC.Generics (Generic) import qualified Data.ByteString.Lazy as LBS import qualified Data.Set as Set diff --git a/cabal-dev-scripts/src/GenUtils.hs b/cabal-dev-scripts/src/GenUtils.hs index 3809eef64b9e87fe244c314c10521faaf28ee43a..c94c0447913b007779fed10b674d5d4d4ad824fc 100644 --- a/cabal-dev-scripts/src/GenUtils.hs +++ b/cabal-dev-scripts/src/GenUtils.hs @@ -145,8 +145,9 @@ data Input = Input deriving (Show, Generic) instance Z.Zinza Input where - toType = Z.genericToTypeSFP - toValue = Z.genericToValueSFP + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + fromValue = Z.genericFromValueSFP data InputLicense = InputLicense { ilConstructor :: Text @@ -157,5 +158,6 @@ data InputLicense = InputLicense deriving (Show, Generic) instance Z.Zinza InputLicense where - toType = Z.genericToTypeSFP - toValue = Z.genericToValueSFP + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + fromValue = Z.genericFromValueSFP diff --git a/cabal-dev-scripts/src/Preprocessor.hs b/cabal-dev-scripts/src/Preprocessor.hs index e7afb17b88483d5cb56347466f9ad72d45d73881..af0708c4dc36394a70897bc9e7db12dc31aa6956 100644 --- a/cabal-dev-scripts/src/Preprocessor.hs +++ b/cabal-dev-scripts/src/Preprocessor.hs @@ -1,3 +1,6 @@ +{- cabal: +build-depends: base, containers +-} {-# LANGUAGE DeriveFunctor #-} module Main (main) where diff --git a/cabal-install/Distribution/Client/CmdRun.hs b/cabal-install/Distribution/Client/CmdRun.hs index 8a2ca97d0934f2cb438e68d51bfa5987af219e7f..2eaf1238452820b5b6c09f723fc347495b6aabea 100644 --- a/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal-install/Distribution/Client/CmdRun.hs @@ -23,15 +23,20 @@ import Distribution.Client.Compat.Prelude hiding (toList) import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages +import Distribution.Client.CmdRun.ClientRunFlags + import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) + , configureExOptions, haddockOptions, installOptions, testOptions + , benchmarkOptions, configureOptions, liftOptions ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) ) import Distribution.Client.GlobalFlags ( defaultGlobalFlags ) -import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI(..), OptionField (..), usageAlternatives ) import Distribution.Types.ComponentName ( showComponentName ) import Distribution.Deprecated.Text @@ -45,7 +50,7 @@ import Distribution.Client.CmdInstall ( establishDummyProjectBaseContext ) import Distribution.Client.ProjectConfig ( ProjectConfig(..), ProjectConfigShared(..) - , withProjectOrGlobalConfig ) + , withProjectOrGlobalConfigIgn ) import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage(..) , ElaboratedInstallPlan, binDirectoryFor ) @@ -109,43 +114,74 @@ import System.FilePath runCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags , HaddockFlags, TestFlags, BenchmarkFlags + , ClientRunFlags ) -runCommand = Client.installCommand { - commandName = "v2-run", - commandSynopsis = "Run an executable.", - commandUsage = usageAlternatives "v2-run" - [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ], - commandDescription = Just $ \pname -> wrapText $ - "Runs the specified executable-like component (an executable, a test, " - ++ "or a benchmark), first ensuring it is up to date.\n\n" - - ++ "Any executable-like component in any package in the project can be " - ++ "specified. A package can be specified if contains just one " - ++ "executable-like. The default is to use the package in the current " - ++ "directory if it contains just one executable-like.\n\n" - - ++ "Extra arguments can be passed to the program, but use '--' to " - ++ "separate arguments for the program from arguments for " ++ pname - ++ ". The executable is run in an environment where it can find its " - ++ "data files inplace in the build tree.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-run\n" - ++ " Run the executable-like in the package in the current directory\n" - ++ " " ++ pname ++ " v2-run foo-tool\n" - ++ " Run the named executable-like (in any package in the project)\n" - ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" - ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" - ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" - ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" - - ++ cmdCommonHelpTextNewBuildBeta +runCommand = CommandUI + { commandName = "v2-run" + , commandSynopsis = "Run an executable." + , commandUsage = usageAlternatives "v2-run" + [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ] + , commandDescription = Just $ \pname -> wrapText $ + "Runs the specified executable-like component (an executable, a test, " + ++ "or a benchmark), first ensuring it is up to date.\n\n" + + ++ "Any executable-like component in any package in the project can be " + ++ "specified. A package can be specified if contains just one " + ++ "executable-like. The default is to use the package in the current " + ++ "directory if it contains just one executable-like.\n\n" + + ++ "Extra arguments can be passed to the program, but use '--' to " + ++ "separate arguments for the program from arguments for " ++ pname + ++ ". The executable is run in an environment where it can find its " + ++ "data files inplace in the build tree.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-run\n" + ++ " Run the executable-like in the package in the current directory\n" + ++ " " ++ pname ++ " v2-run foo-tool\n" + ++ " Run the named executable-like (in any package in the project)\n" + ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" + ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" + ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" + ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty, mempty) + , commandOptions = \showOrParseArgs -> + liftOptions get1 set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. + (filter ((`notElem` ["constraint", "dependency" + , "exact-configuration"]) + . optionName) $ + configureOptions showOrParseArgs) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + ++ liftOptions get3 set3 + -- hide "target-package-db" flag from the + -- install options. + (filter ((`notElem` ["target-package-db"]) + . optionName) $ + installOptions showOrParseArgs) + ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) + ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) + ++ liftOptions get7 set7 (clientRunOptions showOrParseArgs) } + where + get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g) + get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g) + get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g) + get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g) + get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g) + get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g) + get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) + -- | The @run@ command runs a specified executable-like component, building it -- first if necessary. The component can be either an executable, a test, @@ -156,10 +192,12 @@ runCommand = Client.installCommand { -- "Distribution.Client.ProjectOrchestration" -- runAction :: ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, TestFlags, BenchmarkFlags ) + , HaddockFlags, TestFlags, BenchmarkFlags + , ClientRunFlags ) -> [String] -> GlobalFlags -> IO () runAction ( configFlags, configExFlags, installFlags - , haddockFlags, testFlags, benchmarkFlags ) + , haddockFlags, testFlags, benchmarkFlags + , clientRunFlags ) targetStrings globalFlags = do globalTmp <- getTemporaryDirectory tempDir <- createTempDirectory globalTmp "cabal-repl." @@ -170,7 +208,10 @@ runAction ( configFlags, configExFlags, installFlags without config = establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] OtherCommand - baseCtx <- withProjectOrGlobalConfig verbosity globalConfigFlag with without + let + ignoreProject = fromFlagOrDefault False (crunIgnoreProject clientRunFlags) + + baseCtx <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without let scriptOrError script err = do diff --git a/cabal-install/Distribution/Client/CmdRun/ClientRunFlags.hs b/cabal-install/Distribution/Client/CmdRun/ClientRunFlags.hs new file mode 100644 index 0000000000000000000000000000000000000000..c9357b2b244c1f834fe400dec33feea6cddde18d --- /dev/null +++ b/cabal-install/Distribution/Client/CmdRun/ClientRunFlags.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.CmdRun.ClientRunFlags +( ClientRunFlags(..) +, defaultClientRunFlags +, clientRunOptions +) where + +import Distribution.Client.Compat.Prelude + +import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) +import Distribution.Simple.Setup (Flag (..), toFlag, trueArg) + +data ClientRunFlags = ClientRunFlags + { crunIgnoreProject :: Flag Bool + } deriving (Eq, Show, Generic) + +instance Monoid ClientRunFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ClientRunFlags where + (<>) = gmappend + +instance Binary ClientRunFlags +instance Structured ClientRunFlags + +defaultClientRunFlags :: ClientRunFlags +defaultClientRunFlags = ClientRunFlags + { crunIgnoreProject = toFlag False + } + +clientRunOptions :: ShowOrParseArgs -> [OptionField ClientRunFlags] +clientRunOptions _ = + [ option "z" ["ignore-project"] + "Ignore local project configuration" + crunIgnoreProject (\v flags -> flags { crunIgnoreProject = v }) + trueArg + ] diff --git a/cabal-install/Distribution/Client/CmdUpdate.hs b/cabal-install/Distribution/Client/CmdUpdate.hs index 296bcadd432bc61eca6bf3351b4fccb0b6ec3f1b..db0b7ce2a7f2e77e39d567f4ce693ef4323ee3ef 100644 --- a/cabal-install/Distribution/Client/CmdUpdate.hs +++ b/cabal-install/Distribution/Client/CmdUpdate.hs @@ -186,7 +186,8 @@ updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do transport <- repoContextGetTransport repoCtxt case repo of - RepoLocal{..} -> return () + RepoLocal{} -> return () + RepoLocalNoIndex{} -> return () RepoRemote{..} -> do downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index d1f8e97bf32a87ecaafd9aa84c9b74181aa9eb5e..944175725c878270c35a7dfc4201a243724f720e 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -41,7 +41,8 @@ module Distribution.Client.Config ( userConfigUpdate, createDefaultConfigFile, - remoteRepoFields + remoteRepoFields, + postProcessRepo, ) where import Language.Haskell.Extension ( Language(Haskell2010) ) @@ -50,7 +51,7 @@ import Distribution.Deprecated.ViewAsFieldDescr ( viewAsFieldDescr ) import Distribution.Client.Types - ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo + ( RemoteRepo(..), LocalRepo (..), Username(..), Password(..), emptyRemoteRepo , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps ) import Distribution.Client.BuildReports.Types @@ -64,7 +65,7 @@ import Distribution.Client.Setup , InstallFlags(..), installOptions, defaultInstallFlags , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand - , showRepo, parseRepo, readRepo ) + , showRemoteRepo, parseRemoteRepo, readRemoteRepo ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..), defaultClientInstallFlags , clientInstallOptions ) @@ -92,7 +93,7 @@ import Distribution.Deprecated.ParseUtils , locatedErrorMsg, showPWarning , readFields, warning, lineNo , simpleField, listField, spaceListField - , parseFilePathQ, parseOptCommaList, parseTokenQ ) + , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError) import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) import Distribution.Client.HttpUtils @@ -252,6 +253,7 @@ instance Semigroup SavedConfig where globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, globalCacheDir = combine globalCacheDir, globalLocalRepos = lastNonEmptyNL globalLocalRepos, + globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, globalLogsDir = combine globalLogsDir, globalWorldFile = combine globalWorldFile, globalRequireSandbox = combine globalRequireSandbox, @@ -1034,7 +1036,7 @@ deprecatedFieldDescriptions :: [FieldDescr SavedConfig] deprecatedFieldDescriptions = [ liftGlobalFlag $ listField "repos" - (Disp.text . showRepo) parseRepo + (Disp.text . showRemoteRepo) parseRemoteRepo (fromNubList . globalRemoteRepos) (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) , liftGlobalFlag $ @@ -1117,9 +1119,9 @@ parseConfig src initial = \str -> do let init0 = savedInitFlags config user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config - (remoteRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- + (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- foldM parseSections - ([], savedHaddockFlags config, init0, user0, global0, [], []) + ([], [], savedHaddockFlags config, init0, user0, global0, [], []) knownSections let remoteRepoSections = @@ -1127,9 +1129,15 @@ parseConfig src initial = \str -> do . nubBy ((==) `on` remoteRepoName) $ remoteRepoSections0 + let localRepoSections = + reverse + . nubBy ((==) `on` localRepoName) + $ localRepoSections0 + return . fixConfigMultilines $ config { savedGlobalFlags = (savedGlobalFlags config) { globalRemoteRepos = toNubList remoteRepoSections, + globalLocalNoIndexRepos = toNubList localRepoSections, -- the global extra prog path comes from the configure flag prog path globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) }, @@ -1185,61 +1193,57 @@ parseConfig src initial = \str -> do parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial - parseSections (rs, h, i, u, g, p, a) - (ParseUtils.Section _ "repository" name fs) = do + parseSections (rs, ls, h, i, u, g, p, a) + (ParseUtils.Section lineno "repository" name fs) = do r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs - when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $ - warning $ "'key-threshold' for repository " ++ show (remoteRepoName r') - ++ " higher than number of keys" - when (not (null (remoteRepoRootKeys r')) - && remoteRepoSecure r' /= Just True) $ - warning $ "'root-keys' for repository " ++ show (remoteRepoName r') - ++ " non-empty, but 'secure' not set to True." - return (r':rs, h, i, u, g, p, a) - - parseSections (rs, h, i, u, g, p, a) + r'' <- postProcessRepo lineno name r' + case r'' of + Left local -> return (rs, local:ls, h, i, u, g, p, a) + Right remote -> return (remote:rs, ls, h, i, u, g, p, a) + + parseSections (rs, ls, h, i, u, g, p, a) (ParseUtils.F lno "remote-repo" raw) = do - let mr' = readRepo raw + let mr' = readRemoteRepo raw r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' - return (r':rs, h, i, u, g, p, a) + return (r':rs, ls, h, i, u, g, p, a) - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "haddock" name fs) | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (rs, h', i, u, g, p, a) + return (rs, ls, h', i, u, g, p, a) | otherwise = do warning "The 'haddock' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "init" name fs) | name == "" = do i' <- parseFields initFlagsFields i fs - return (rs, h, i', u, g, p, a) + return (rs, ls, h, i', u, g, p, a) | otherwise = do warning "The 'init' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "install-dirs" name fs) | name' == "user" = do u' <- parseFields installDirsFields u fs - return (rs, h, i, u', g, p, a) + return (rs, ls, h, i, u', g, p, a) | name' == "global" = do g' <- parseFields installDirsFields g fs - return (rs, h, i, u, g', p, a) + return (rs, ls, h, i, u, g', p, a) | otherwise = do warning "The 'install-paths' section should be for 'user' or 'global'" return accum where name' = lowercase name - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "program-locations" name fs) | name == "" = do p' <- parseFields withProgramsFields p fs - return (rs, h, i, u, g, p', a) + return (rs, ls, h, i, u, g, p', a) | otherwise = do warning "The 'program-locations' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "program-default-options" name fs) | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (rs, h, i, u, g, p, a') + return (rs, ls, h, i, u, g, p, a') | otherwise = do warning "The 'program-default-options' section should be unnamed" return accum @@ -1247,6 +1251,34 @@ parseConfig src initial = \str -> do warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum +postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) +postProcessRepo lineno reponame repo0 = do + when (null reponame) $ + syntaxError lineno $ "a 'repository' section requires the " + ++ "repository name as an argument" + + case uriScheme (remoteRepoURI repo0) of + -- TODO: check that there are no authority, query or fragment + -- Note: the trailing colon is important + "file+noindex:" -> do + let uri = remoteRepoURI repo0 + return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") + + _ -> do + let repo = repo0 { remoteRepoName = reponame } + + when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ + warning $ "'key-threshold' for repository " + ++ show (remoteRepoName repo) + ++ " higher than number of keys" + + when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ + warning $ "'root-keys' for repository " + ++ show (remoteRepoName repo) + ++ " non-empty, but 'secure' not set to True." + + return $ Right repo + showConfig :: SavedConfig -> String showConfig = showConfigWithComments mempty @@ -1297,7 +1329,7 @@ installDirsFields = map viewAsFieldDescr installDirsOptions ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals) - remoteRepoFields (Just def) vals + remoteRepoFields (Just def) vals remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields = diff --git a/cabal-install/Distribution/Client/DistDirLayout.hs b/cabal-install/Distribution/Client/DistDirLayout.hs index 4226193670f18bf9df420a3b746b28b4c580190e..612047ad761b33ff56d866f211c561d9fc08614a 100644 --- a/cabal-install/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/Distribution/Client/DistDirLayout.hs @@ -155,11 +155,11 @@ data CabalDirLayout = CabalDirLayout { -- | Information about the root directory of the project. -- --- It can either be an implict project root in the current dir if no +-- It can either be an implicit project root in the current dir if no -- @cabal.project@ file is found, or an explicit root if the file is found. -- data ProjectRoot = - -- | -- ^ An implict project root. It contains the absolute project + -- | -- ^ An implicit project root. It contains the absolute project -- root dir. ProjectRootImplicit FilePath diff --git a/cabal-install/Distribution/Client/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs index 992eb0f3fc7443a2f47410a1a1ea13bcf7fade39..e9a31a91f846a4d70627d3e9a39293c6c096304d 100644 --- a/cabal-install/Distribution/Client/FetchUtils.hs +++ b/cabal-install/Distribution/Client/FetchUtils.hs @@ -177,6 +177,7 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do downloadRepoPackage = case repo of RepoLocal{..} -> return (packageFile repo pkgid) + RepoLocalNoIndex{..} -> return (packageFile repo pkgid) RepoRemote{..} -> do transport <- repoContextGetTransport repoCtxt @@ -292,6 +293,7 @@ packageFile repo pkgid = packageDir repo pkgid -- the tarball for a given @PackageIdentifer@ is stored. -- packageDir :: Repo -> PackageId -> FilePath +packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir packageDir repo pkgid = repoLocalDir repo </> display (packageName pkgid) </> display (packageVersion pkgid) diff --git a/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal-install/Distribution/Client/GlobalFlags.hs index dbaf07be93088654017e58b6a0f28a1427555e50..fa1243bf677c94e2ff8a61e0db1723ded7a511ea 100644 --- a/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/Distribution/Client/GlobalFlags.hs @@ -17,7 +17,7 @@ import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.Types - ( Repo(..), RemoteRepo(..) ) + ( Repo(..), RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) import Distribution.Simple.Setup ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList @@ -27,7 +27,7 @@ import Distribution.Client.HttpUtils import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils - ( info ) + ( info, warn ) import Control.Concurrent ( MVar, newMVar, modifyMVar ) @@ -48,6 +48,8 @@ import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote import qualified Distribution.Client.Security.HTTP as Sec.HTTP import qualified Distribution.Client.Security.DNS as Sec.DNS +import qualified System.FilePath.Posix as FilePath.Posix + -- ------------------------------------------------------------ -- * Global flags -- ------------------------------------------------------------ @@ -62,6 +64,7 @@ data GlobalFlags = GlobalFlags { globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. globalCacheDir :: Flag FilePath, globalLocalRepos :: NubList FilePath, + globalLocalNoIndexRepos :: NubList LocalRepo, globalLogsDir :: Flag FilePath, globalWorldFile :: Flag FilePath, globalRequireSandbox :: Flag Bool, @@ -83,6 +86,7 @@ defaultGlobalFlags = GlobalFlags { globalRemoteRepos = mempty, globalCacheDir = mempty, globalLocalRepos = mempty, + globalLocalNoIndexRepos = mempty, globalLogsDir = mempty, globalWorldFile = mempty, globalRequireSandbox = Flag False, @@ -141,20 +145,25 @@ withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a withRepoContext verbosity globalFlags = withRepoContext' verbosity - (fromNubList (globalRemoteRepos globalFlags)) - (fromNubList (globalLocalRepos globalFlags)) - (fromFlag (globalCacheDir globalFlags)) - (flagToMaybe (globalHttpTransport globalFlags)) - (flagToMaybe (globalIgnoreExpiry globalFlags)) - (fromNubList (globalProgPathExtra globalFlags)) - -withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] + (fromNubList (globalRemoteRepos globalFlags)) + (fromNubList (globalLocalRepos globalFlags)) + (fromNubList (globalLocalNoIndexRepos globalFlags)) + (fromFlag (globalCacheDir globalFlags)) + (flagToMaybe (globalHttpTransport globalFlags)) + (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalProgPathExtra globalFlags)) + +withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] -> [LocalRepo] -> FilePath -> Maybe String -> Maybe Bool -> [FilePath] -> (RepoContext -> IO a) -> IO a -withRepoContext' verbosity remoteRepos localRepos +withRepoContext' verbosity remoteRepos localRepos localNoIndexRepos sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do + for_ localNoIndexRepos $ \local -> + unless (FilePath.Posix.isAbsolute (localRepoPath local)) $ + warn verbosity $ "file+noindex " ++ localRepoName local ++ " repository path is not absolute; this is fragile, and not recommended" + transportRef <- newMVar Nothing let httpLib = Sec.HTTP.transportAdapter verbosity @@ -162,6 +171,7 @@ withRepoContext' verbosity remoteRepos localRepos initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> callback RepoContext { repoContextRepos = allRemoteRepos + ++ allLocalNoIndexRepos ++ map RepoLocal localRepos , repoContextGetTransport = getTransport transportRef , repoContextWithSecureRepo = withSecureRepo secureRepos' @@ -170,6 +180,8 @@ withRepoContext' verbosity remoteRepos localRepos where secureRemoteRepos = [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ] + + allRemoteRepos :: [Repo] allRemoteRepos = [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir | remote <- remoteRepos @@ -177,6 +189,14 @@ withRepoContext' verbosity remoteRepos localRepos isSecure = remoteRepoSecure remote == Just True ] + allLocalNoIndexRepos :: [Repo] + allLocalNoIndexRepos = + [ RepoLocalNoIndex local cacheDir + | local <- localNoIndexRepos + , let cacheDir | localRepoSharedCache local = sharedCacheDir </> localRepoCacheKey local + | otherwise = localRepoPath local + ] + getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport getTransport transportRef = modifyMVar transportRef $ \mTransport -> do diff --git a/cabal-install/Distribution/Client/HashValue.hs b/cabal-install/Distribution/Client/HashValue.hs new file mode 100644 index 0000000000000000000000000000000000000000..54b8aee9e61ea47cf64cf185ea4cd5d4b5aba58a --- /dev/null +++ b/cabal-install/Distribution/Client/HashValue.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.HashValue ( + HashValue, + hashValue, + truncateHash, + showHashValue, + readFileHashValue, + hashFromTUF, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Hackage.Security.Client as Sec + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Control.Exception (evaluate) +import System.IO (IOMode (..), withBinaryFile) + +----------------------------------------------- +-- The specific choice of hash implementation +-- + +-- Is a crypto hash necessary here? One thing to consider is who controls the +-- inputs and what's the result of a hash collision. Obviously we should not +-- install packages we don't trust because they can run all sorts of code, but +-- if I've checked there's no TH, no custom Setup etc, is there still a +-- problem? If someone provided us a tarball that hashed to the same value as +-- some other package and we installed it, we could end up re-using that +-- installed package in place of another one we wanted. So yes, in general +-- there is some value in preventing intentional hash collisions in installed +-- package ids. + +newtype HashValue = HashValue BS.ByteString + deriving (Eq, Generic, Show, Typeable) + +-- Cannot do any sensible validation here. Although we use SHA256 +-- for stuff we hash ourselves, we can also get hashes from TUF +-- and that can in principle use different hash functions in future. +-- +-- Therefore, we simply derive this structurally. +instance Binary HashValue +instance Structured HashValue + +-- | Hash some data. Currently uses SHA256. +-- +hashValue :: LBS.ByteString -> HashValue +hashValue = HashValue . SHA256.hashlazy + +showHashValue :: HashValue -> String +showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) + +-- | Hash the content of a file. Uses SHA256. +-- +readFileHashValue :: FilePath -> IO HashValue +readFileHashValue tarball = + withBinaryFile tarball ReadMode $ \hnd -> + evaluate . hashValue =<< LBS.hGetContents hnd + +-- | Convert a hash from TUF metadata into a 'PackageSourceHash'. +-- +-- Note that TUF hashes don't neessarily have to be SHA256, since it can +-- support new algorithms in future. +-- +hashFromTUF :: Sec.Hash -> HashValue +hashFromTUF (Sec.Hash hashstr) = + --TODO: [code cleanup] either we should get TUF to use raw bytestrings or + -- perhaps we should also just use a base16 string as the internal rep. + case Base16.decode (BS.pack hashstr) of + (hash, trailing) | not (BS.null hash) && BS.null trailing + -> HashValue hash + _ -> error "hashFromTUF: cannot decode base16 hash" + + +-- | Truncate a 32 byte SHA256 hash to +-- +-- For example 20 bytes render as 40 hex chars, which we use for unit-ids. +-- Or even 4 bytes for 'hashedInstalledPackageIdShort' +-- +truncateHash :: Int -> HashValue -> HashValue +truncateHash n (HashValue h) = HashValue (BS.take n h) diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs index 3ef37bdf0408ec74a0c6c864949a68b711ccb012..a76becc05baa1c0402b5405c4f8ccfec083049b7 100644 --- a/cabal-install/Distribution/Client/IndexUtils.hs +++ b/cabal-install/Distribution/Client/IndexUtils.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- @@ -50,6 +51,8 @@ import qualified Distribution.Client.Tar as Tar import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types import Distribution.Verbosity +import Distribution.Pretty (prettyShow) +import Distribution.Parsec (simpleParsec) import Distribution.Package ( PackageId, PackageIdentifier(..), mkPackageName @@ -70,7 +73,7 @@ import Distribution.Version import Distribution.Deprecated.Text ( display, simpleParse ) import Distribution.Simple.Utils - ( die', warn, info ) + ( die', warn, info, createDirectoryIfMissingVerbose ) import Distribution.Client.Setup ( RepoContext(..) ) @@ -83,9 +86,11 @@ import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.SourcePackage import qualified Data.Map as Map +import qualified Data.Set as Set import Control.DeepSeq import Control.Monad import Control.Exception +import Data.List (stripPrefix) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS @@ -93,17 +98,19 @@ import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath , tryFindAddSourcePackageDesc ) -import Distribution.Compat.Binary +import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail) import Distribution.Compat.Exception (catchIO) import Distribution.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath - ( (</>), (<.>), takeExtension, replaceExtension, splitDirectories, normalise ) -import System.FilePath.Posix as FilePath.Posix - ( takeFileName ) + ( (</>), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory ) +import qualified System.FilePath.Posix as FilePath.Posix import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) +import Distribution.Compat.Directory (listDirectory) + +import qualified Codec.Compression.GZip as GZip import qualified Hackage.Security.Client as Sec import qualified Hackage.Security.Util.Some as Sec @@ -130,9 +137,10 @@ indexBaseName :: Repo -> FilePath indexBaseName repo = repoLocalDir repo </> fn where fn = case repo of - RepoSecure {} -> "01-index" - RepoRemote {} -> "00-index" - RepoLocal {} -> "00-index" + RepoSecure {} -> "01-index" + RepoRemote {} -> "00-index" + RepoLocal {} -> "00-index" + RepoLocalNoIndex {} -> "noindex" ------------------------------------------------------------------------ -- Reading the source package index @@ -218,7 +226,12 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do describeState (IndexStateTime time) = "historical state as of " ++ display time pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do - let rname = maybe "" remoteRepoName $ maybeRepoRemote r + let rname = case r of + RepoRemote remote _ -> remoteRepoName remote + RepoSecure remote _ -> remoteRepoName remote + RepoLocalNoIndex local _ -> localRepoName local + RepoLocal _ -> "" + info verbosity ("Reading available packages of " ++ rname ++ "...") idxState <- case mb_idxState of @@ -240,6 +253,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do unless (idxState == IndexStateHead) $ case r of RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')") + RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')") RepoSecure {} -> pure () @@ -301,7 +315,7 @@ readRepoIndex :: Verbosity -> RepoContext -> Repo -> IndexState -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) readRepoIndex verbosity repoCtxt repo idxState = handleNotFound $ do - warnIfIndexIsOld =<< getIndexFileAge repo + when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) readPackageIndexCacheFile verbosity mkAvailablePackage (RepoIndex repoCtxt repo) @@ -330,6 +344,10 @@ readRepoIndex verbosity repoCtxt repo idxState = RepoLocal{..} -> warn verbosity $ "The package list for the local repo '" ++ repoLocalDir ++ "' is missing. The repo is invalid." + RepoLocalNoIndex local _ -> warn verbosity $ + "Error during construction of local+noindex " + ++ localRepoName local ++ " repository index: " + ++ show e return (mempty,mempty,emptyStateInfo) else ioError e @@ -338,11 +356,12 @@ readRepoIndex verbosity repoCtxt repo idxState = when (dt >= isOldThreshold) $ case repo of RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt - RepoLocal{..} -> return () + RepoLocal{} -> return () + RepoLocalNoIndex {} -> return () errMissingPackageList repoRemote = "The package list for '" ++ remoteRepoName repoRemote - ++ "' does not exist. Run 'cabal update' to download it." + ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote errOutdatedPackageList repoRemote dt = "The package list for '" ++ remoteRepoName repoRemote ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun " @@ -366,18 +385,23 @@ getSourcePackagesMonitorFiles repos = -- updateRepoIndexCache :: Verbosity -> Index -> IO () updateRepoIndexCache verbosity index = - whenCacheOutOfDate index $ do - updatePackageIndexCacheFile verbosity index + whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index whenCacheOutOfDate :: Index -> IO () -> IO () whenCacheOutOfDate index action = do exists <- doesFileExist $ cacheFile index if not exists - then action - else do - indexTime <- getModTime $ indexFile index - cacheTime <- getModTime $ cacheFile index - when (indexTime > cacheTime) action + then action + else if localNoIndex index + then return () -- TODO: don't update cache for local+noindex repositories + else do + indexTime <- getModTime $ indexFile index + cacheTime <- getModTime $ cacheFile index + when (indexTime > cacheTime) action + +localNoIndex :: Index -> Bool +localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True +localNoIndex _ = False ------------------------------------------------------------------------ -- Reading the index file @@ -391,9 +415,10 @@ data PackageEntry = -- | A build tree reference is either a link or a snapshot. data BuildTreeRefType = SnapshotRef | LinkRef - deriving (Eq,Generic) + deriving (Eq,Show,Generic) instance Binary BuildTreeRefType +instance Structured BuildTreeRefType refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType refTypeFromTypeCode t @@ -492,7 +517,7 @@ extractPkg verbosity entry blockNo = case Tar.entryContent entry of extractPrefs :: Tar.Entry -> Maybe [Dependency] extractPrefs entry = case Tar.entryContent entry of Tar.NormalFile content _ - | takeFileName entrypath == "preferred-versions" + | FilePath.Posix.takeFileName entrypath == "preferred-versions" -> Just prefs where entrypath = Tar.entryPath entry @@ -562,20 +587,27 @@ is01Index (RepoIndex _ repo) = case repo of RepoSecure {} -> True RepoRemote {} -> False RepoLocal {} -> False + RepoLocalNoIndex {} -> True is01Index (SandboxIndex _) = False updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") - withIndexEntries verbosity index $ \entries -> do - let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) - cache = Cache { cacheHeadTs = maxTs - , cacheEntries = entries - } - writeIndexCache index cache - info verbosity ("Index cache updated to index-state " - ++ display (cacheHeadTs cache)) + withIndexEntries verbosity index callback callbackNoIndex + where + callback entries = do + let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) + cache = Cache { cacheHeadTs = maxTs + , cacheEntries = entries + } + writeIndexCache index cache + info verbosity ("Index cache updated to index-state " + ++ display (cacheHeadTs cache)) + + callbackNoIndex entries = do + writeNoIndexCache verbosity index $ NoIndexCache entries + info verbosity "Index cache updated" -- | Read the index (for the purpose of building a cache) -- @@ -597,8 +629,12 @@ updatePackageIndexCacheFile verbosity index = do -- TODO: It would be nicer if we actually incrementally updated @cabal@'s -- cache, rather than reconstruct it from zero on each update. However, this -- would require a change in the cache format. -withIndexEntries :: Verbosity -> Index -> ([IndexCacheEntry] -> IO a) -> IO a -withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback = +withIndexEntries + :: Verbosity -> Index + -> ([IndexCacheEntry] -> IO a) + -> ([NoIndexCacheEntry] -> IO a) + -> IO a +withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback _ = repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do -- Incrementally (lazily) read all the entries in the tar file in order, @@ -625,7 +661,60 @@ withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback = timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ epochTimeToTimestamp $ Sec.indexEntryTime sie -withIndexEntries verbosity index callback = do -- non-secure repositories +withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do + dirContents <- listDirectory localDir + let contentSet = Set.fromList dirContents + + entries <- handle handler $ fmap catMaybes $ forM dirContents $ \file -> do + case isTarGz file of + Nothing -> do + unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $ + info verbosity $ "Skipping " ++ file + return Nothing + Just pkgid | cabalPath `Set.member` contentSet -> do + contents <- BSS.readFile (localDir </> cabalPath) + forM (parseGenericPackageDescriptionMaybe contents) $ \gpd -> + return (CacheGPD gpd contents) + where + cabalPath = prettyShow pkgid ++ ".cabal" + Just pkgId -> do + -- check for the right named .cabal file in the compressed tarball + tarGz <- BS.readFile (localDir </> file) + let tar = GZip.decompress tarGz + entries = Tar.read tar + + case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of + Just ce -> return (Just ce) + Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file + + info verbosity $ "Entries in file+noindex repository " ++ name + for_ entries $ \(CacheGPD gpd _) -> + info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd) + + callback entries + where + handler :: IOException -> IO a + handler e = die' verbosity $ "Error while updating index for " ++ name ++ " repository " ++ show e + + isTarGz :: FilePath -> Maybe PackageIdentifier + isTarGz fp = do + pfx <- stripSuffix ".tar.gz" fp + simpleParsec pfx + + stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str)) + + -- look for <pkgid>/<pkgname>.cabal inside the tarball + readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry + readCabalEntry pkgId entry Nothing + | filename == Tar.entryPath entry + , Tar.NormalFile contents _ <- Tar.entryContent entry + = let bs = BS.toStrict contents + in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs + where + filename = prettyShow pkgId FilePath.Posix.</> prettyShow (packageName pkgId) ++ ".cabal" + readCabalEntry _ _ x = x + +withIndexEntries verbosity index callback _ = do -- non-secure repositories withFile (indexFile index) ReadMode $ \h -> do bs <- maybeDecompress `fmap` BS.hGetContents h pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs @@ -642,13 +731,18 @@ readPackageIndexCacheFile :: Package pkg -> Index -> IndexState -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) -readPackageIndexCacheFile verbosity mkPkg index idxState = do - cache0 <- readIndexCache verbosity index - indexHnd <- openFile (indexFile index) ReadMode - let (cache,isi) = filterCache idxState cache0 - (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache - pure (pkgs,deps,isi) - +readPackageIndexCacheFile verbosity mkPkg index idxState + | localNoIndex index = do + cache0 <- readNoIndexCache verbosity index + pkgs <- packageNoIndexFromCache verbosity mkPkg cache0 + pure (pkgs, [], emptyStateInfo) + + | otherwise = do + cache0 <- readIndexCache verbosity index + indexHnd <- openFile (indexFile index) ReadMode + let (cache,isi) = filterCache idxState cache0 + (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache + pure (pkgs,deps,isi) packageIndexFromCache :: Package pkg => Verbosity @@ -661,6 +755,21 @@ packageIndexFromCache verbosity mkPkg hnd cache = do pkgIndex <- evaluate $ PackageIndex.fromList pkgs return (pkgIndex, prefs) +packageNoIndexFromCache + :: forall pkg. Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> NoIndexCache + -> IO (PackageIndex pkg) +packageNoIndexFromCache _verbosity mkPkg cache = + evaluate $ PackageIndex.fromList pkgs + where + pkgs = + [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0 + | CacheGPD gpd bs <- noIndexCacheEntries cache + , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd + ] + -- | Read package list -- -- The result package releases and preference entries are guaranteed @@ -749,8 +858,7 @@ packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cach ------------------------------------------------------------------------ --- Index cache data structure --- +-- Index cache data structure -- -- | Read the 'Index' cache from the filesystem -- @@ -773,20 +881,46 @@ readIndexCache verbosity index = do Right res -> return (hashConsCache res) +readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache +readNoIndexCache verbosity index = do + cacheOrFail <- readNoIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ concat + [ "Parsing the index cache failed (", msg, "). " + , "Trying to regenerate the index cache..." + ] + + updatePackageIndexCacheFile verbosity index + + either (die' verbosity) return =<< readNoIndexCache' index + + -- we don't hash cons local repository cache, they are hopefully small + Right res -> return res + -- | Read the 'Index' cache from the filesystem without attempting to -- regenerate on parsing failures. readIndexCache' :: Index -> IO (Either String Cache) readIndexCache' index - | is01Index index = decodeFileOrFail' (cacheFile index) + | is01Index index = structuredDecodeFileOrFail (cacheFile index) | otherwise = liftM (Right .read00IndexCache) $ BSS.readFile (cacheFile index) +readNoIndexCache' :: Index -> IO (Either String NoIndexCache) +readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index) + -- | Write the 'Index' cache to the filesystem writeIndexCache :: Index -> Cache -> IO () writeIndexCache index cache - | is01Index index = encodeFile (cacheFile index) cache + | is01Index index = structuredEncodeFile (cacheFile index) cache | otherwise = writeFile (cacheFile index) (show00IndexCache cache) +writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO () +writeNoIndexCache verbosity index cache = do + let path = cacheFile index + createDirectoryIfMissingVerbose verbosity True (takeDirectory path) + structuredEncodeFile path cache + -- | Write the 'IndexState' to the filesystem writeIndexTimestamp :: Index -> IndexState -> IO () writeIndexTimestamp index st @@ -852,28 +986,44 @@ data Cache = Cache -- 'cacheEntries' , cacheEntries :: [IndexCacheEntry] } + deriving (Show, Generic) instance NFData Cache where rnf = rnf . cacheEntries +-- | Cache format for 'file+noindex' repositories +newtype NoIndexCache = NoIndexCache + { noIndexCacheEntries :: [NoIndexCacheEntry] + } + deriving (Show, Generic) + +instance NFData NoIndexCache where + rnf = rnf . noIndexCacheEntries + -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. -- type BlockNo = Word32 -- Tar.TarEntryOffset - data IndexCacheEntry = CachePackageId PackageId !BlockNo !Timestamp | CachePreference Dependency !BlockNo !Timestamp | CacheBuildTreeRef !BuildTreeRefType !BlockNo -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build - deriving (Eq,Generic) + deriving (Eq,Show,Generic) + +data NoIndexCacheEntry + = CacheGPD GenericPackageDescription !BSS.ByteString + deriving (Eq,Show,Generic) instance NFData IndexCacheEntry where rnf (CachePackageId pkgid _ _) = rnf pkgid rnf (CachePreference dep _ _) = rnf dep rnf (CacheBuildTreeRef _ _) = () +instance NFData NoIndexCacheEntry where + rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs + cacheEntryTimestamp :: IndexCacheEntry -> Timestamp cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp cacheEntryTimestamp (CachePreference _ _ ts) = ts @@ -882,24 +1032,26 @@ cacheEntryTimestamp (CachePackageId _ _ ts) = ts ---------------------------------------------------------------------------- -- new binary 01-index.cache format -instance Binary Cache where - put (Cache headTs ents) = do - -- magic / format version - -- - -- NB: this currently encodes word-size implicitly; when we - -- switch to CBOR encoding, we will have a platform - -- independent binary encoding - put (0xcaba1002::Word) - put headTs - put ents +instance Binary Cache +instance Binary IndexCacheEntry +instance Binary NoIndexCache + +instance Structured Cache +instance Structured IndexCacheEntry +instance Structured NoIndexCache + +-- | We need to save only .cabal file contents +instance Binary NoIndexCacheEntry where + put (CacheGPD _ bs) = put bs get = do - magic <- get - when (magic /= (0xcaba1002::Word)) $ - fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic) - Cache <$> get <*> get + bs <- get + case parseGenericPackageDescriptionMaybe bs of + Just gpd -> return (CacheGPD gpd bs) + Nothing -> fail "Failed to parse GPD" -instance Binary IndexCacheEntry +instance Structured NoIndexCacheEntry where + structure = nominalStructure ---------------------------------------------------------------------------- -- legacy 00-index.cache format @@ -972,16 +1124,19 @@ show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries show00IndexCacheEntry :: IndexCacheEntry -> String show00IndexCacheEntry entry = unwords $ case entry of - CachePackageId pkgid b _ -> [ packageKey - , display (packageName pkgid) - , display (packageVersion pkgid) - , blocknoKey - , show b - ] - CacheBuildTreeRef tr b -> [ buildTreeRefKey - , [typeCodeFromRefType tr] - , show b - ] - CachePreference dep _ _ -> [ preferredVersionKey - , display dep - ] + CachePackageId pkgid b _ -> + [ packageKey + , display (packageName pkgid) + , display (packageVersion pkgid) + , blocknoKey + , show b + ] + CacheBuildTreeRef tr b -> + [ buildTreeRefKey + , [typeCodeFromRefType tr] + , show b + ] + CachePreference dep _ _ -> + [ preferredVersionKey + , display dep + ] diff --git a/cabal-install/Distribution/Client/PackageHash.hs b/cabal-install/Distribution/Client/PackageHash.hs index 9073c93085f01afedc331ebfe3e1d2d04edfc540..d4226867b260f4c0f708900d9b17fdb3dff5a4ee 100644 --- a/cabal-install/Distribution/Client/PackageHash.hs +++ b/cabal-install/Distribution/Client/PackageHash.hs @@ -20,13 +20,6 @@ module Distribution.Client.PackageHash ( -- ** Platform-specific variations hashedInstalledPackageIdLong, hashedInstalledPackageIdShort, - - -- * Low level hash choice - HashValue, - hashValue, - showHashValue, - readFileHashValue, - hashFromTUF, ) where import Prelude () @@ -48,23 +41,16 @@ import Distribution.Pretty (prettyShow) import Distribution.Deprecated.Text ( display ) import Distribution.Types.PkgconfigVersion (PkgconfigVersion) +import Distribution.Client.HashValue import Distribution.Client.Types ( InstalledPackageId ) import qualified Distribution.Solver.Types.ComponentDeps as CD -import qualified Hackage.Security.Client as Sec - -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map import qualified Data.Set as Set import Data.Function (on) -import Control.Exception (evaluate) -import System.IO (withBinaryFile, IOMode(..)) - ------------------------------- -- Calculating package hashes @@ -121,15 +107,11 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = -- max length now 64 [ truncateStr 14 (display name) , truncateStr 8 (display version) - , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs)) + , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) ] where PackageIdentifier name version = pkgHashPkgId - -- Truncate a 32 byte SHA256 hash to 160bits, 20 bytes :-( - -- It'll render as 40 hex chars. - truncateHash (HashValue h) = HashValue (BS.take 20 h) - -- Truncate a string, with a visual indication that it is truncated. truncateStr n s | length s <= n = s | otherwise = take (n-1) s ++ "_" @@ -163,11 +145,10 @@ hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} intercalate "-" [ filter (not . flip elem "aeiou") (display name) , display version - , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs)) + , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs)) ] where PackageIdentifier name version = pkgHashPkgId - truncateHash (HashValue h) = HashValue (BS.take 4 h) -- | All the information that contribues to a package's hash, and thus its -- 'InstalledPackageId'. @@ -330,57 +311,3 @@ renderPackageHashInputs PackageHashInputs{ | otherwise = entry key format value showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment - ------------------------------------------------ --- The specific choice of hash implementation --- - --- Is a crypto hash necessary here? One thing to consider is who controls the --- inputs and what's the result of a hash collision. Obviously we should not --- install packages we don't trust because they can run all sorts of code, but --- if I've checked there's no TH, no custom Setup etc, is there still a --- problem? If someone provided us a tarball that hashed to the same value as --- some other package and we installed it, we could end up re-using that --- installed package in place of another one we wanted. So yes, in general --- there is some value in preventing intentional hash collisions in installed --- package ids. - -newtype HashValue = HashValue BS.ByteString - deriving (Eq, Generic, Show, Typeable) - --- Cannot do any sensible validation here. Although we use SHA256 --- for stuff we hash ourselves, we can also get hashes from TUF --- and that can in principle use different hash functions in future. --- --- Therefore, we simply derive this structurally. -instance Binary HashValue -instance Structured HashValue - --- | Hash some data. Currently uses SHA256. --- -hashValue :: LBS.ByteString -> HashValue -hashValue = HashValue . SHA256.hashlazy - -showHashValue :: HashValue -> String -showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) - --- | Hash the content of a file. Uses SHA256. --- -readFileHashValue :: FilePath -> IO HashValue -readFileHashValue tarball = - withBinaryFile tarball ReadMode $ \hnd -> - evaluate . hashValue =<< LBS.hGetContents hnd - --- | Convert a hash from TUF metadata into a 'PackageSourceHash'. --- --- Note that TUF hashes don't neessarily have to be SHA256, since it can --- support new algorithms in future. --- -hashFromTUF :: Sec.Hash -> HashValue -hashFromTUF (Sec.Hash hashstr) = - --TODO: [code cleanup] either we should get TUF to use raw bytestrings or - -- perhaps we should also just use a base16 string as the internal rep. - case Base16.decode (BS.pack hashstr) of - (hash, trailing) | not (BS.null hash) && BS.null trailing - -> HashValue hash - _ -> error "hashFromTUF: cannot decode base16 hash" diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index ec560b2ab052cc640556aeddd4d334e0ae79707a..8282a6beaf2dbe4a482ea7c6c28ce4892bf0167a 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -187,6 +187,7 @@ projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} = verbosity buildSettingRemoteRepos buildSettingLocalRepos + buildSettingLocalNoIndexRepos buildSettingCacheDir buildSettingHttpTransport (Just buildSettingIgnoreExpiry) @@ -209,6 +210,7 @@ projectConfigWithSolverRepoContext verbosity verbosity (fromNubList projectConfigRemoteRepos) (fromNubList projectConfigLocalRepos) + (fromNubList projectConfigLocalNoIndexRepos) (fromFlagOrDefault (error "projectConfigWithSolverRepoContext: projectConfigCacheDir") @@ -233,6 +235,7 @@ resolveSolverSettings ProjectConfig{ -- the flag assignments need checking. solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos solverSettingLocalRepos = fromNubList projectConfigLocalRepos + solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos solverSettingConstraints = projectConfigConstraints solverSettingPreferences = projectConfigPreferences solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages @@ -296,6 +299,7 @@ resolveBuildTimeSettings verbosity projectConfigShared = ProjectConfigShared { projectConfigRemoteRepos, projectConfigLocalRepos, + projectConfigLocalNoIndexRepos, projectConfigProgPathExtra }, projectConfigBuildOnly @@ -316,6 +320,7 @@ resolveBuildTimeSettings verbosity buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos buildSettingLocalRepos = fromNubList projectConfigLocalRepos + buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos buildSettingCacheDir = fromFlag projectConfigCacheDir buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index c71cae16c7ed7a564a6ad38e7714de2e00fdef4e..53975930bf21d4b154c474eb514137debc3c0c45 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -27,12 +27,12 @@ import Distribution.Deprecated.ParseUtils (parseFlagAssignment) import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types - ( RemoteRepo(..), emptyRemoteRepo + ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo , AllowNewer(..), AllowOlder(..) ) import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) import Distribution.Client.Config - ( SavedConfig(..), remoteRepoFields ) + ( SavedConfig(..), remoteRepoFields, postProcessRepo ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..), defaultClientInstallFlags @@ -78,7 +78,7 @@ import Text.PrettyPrint ( Doc, ($+$) ) import qualified Distribution.Deprecated.ParseUtils as ParseUtils (field) import Distribution.Deprecated.ParseUtils - ( ParseResult(..), PError(..), syntaxError, PWarning(..), warning + ( ParseResult(..), PError(..), syntaxError, PWarning(..) , simpleField, commaNewLineListField, newLineListField, parseTokenQ , parseHaskellString, showToken ) import Distribution.Client.ParseUtils @@ -90,6 +90,8 @@ import Distribution.Types.PackageVersionConstraint import qualified Data.Map as Map +import Network.URI (URI (..)) + ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types -- @@ -334,6 +336,7 @@ convertLegacyAllPackageFlags globalFlags configFlags globalSandboxConfigFile = _, -- ?? globalRemoteRepos = projectConfigRemoteRepos, globalLocalRepos = projectConfigLocalRepos, + globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, globalProgPathExtra = projectConfigProgPathExtra, globalStoreDir = projectConfigStoreDir } = globalFlags @@ -568,6 +571,7 @@ convertToLegacySharedConfig globalRemoteRepos = projectConfigRemoteRepos, globalCacheDir = projectConfigCacheDir, globalLocalRepos = projectConfigLocalRepos, + globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, globalLogsDir = projectConfigLogsDir, globalWorldFile = mempty, globalRequireSandbox = mempty, @@ -1385,36 +1389,39 @@ programDbOptions progDb showOrParseArgs get' set = | otherwise = arg +-- The implementation is slight hack: we parse all as remote repository +-- but if the url schema is file+noindex, we switch to local. remoteRepoSectionDescr :: SectionDescr GlobalFlags -remoteRepoSectionDescr = - SectionDescr { - sectionName = "repository", - sectionFields = remoteRepoFields, - sectionSubsections = [], - sectionGet = map (\x->(remoteRepoName x, x)) . fromNubList - . globalRemoteRepos, - sectionSet = - \lineno reponame repo0 conf -> do - when (null reponame) $ - syntaxError lineno $ "a 'repository' section requires the " - ++ "repository name as an argument" - let repo = repo0 { remoteRepoName = reponame } - when (remoteRepoKeyThreshold repo - > length (remoteRepoRootKeys repo)) $ - warning $ "'key-threshold' for repository " - ++ show (remoteRepoName repo) - ++ " higher than number of keys" - when (not (null (remoteRepoRootKeys repo)) - && remoteRepoSecure repo /= Just True) $ - warning $ "'root-keys' for repository " - ++ show (remoteRepoName repo) - ++ " non-empty, but 'secure' not set to True." - return conf { - globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) - }, - sectionEmpty = emptyRemoteRepo "" +remoteRepoSectionDescr = SectionDescr + { sectionName = "repository" + , sectionEmpty = emptyRemoteRepo "" + , sectionFields = remoteRepoFields + , sectionSubsections = [] + , sectionGet = getS + , sectionSet = setS } - + where + getS :: GlobalFlags -> [(String, RemoteRepo)] + getS gf = + map (\x->(remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) + ++ + map (\x->(localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) + + setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags + setS lineno reponame repo0 conf = do + repo1 <- postProcessRepo lineno reponame repo0 + case repo1 of + Left repo -> return conf + { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf) + } + Right repo -> return conf + { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) + } + + localToRemote :: LocalRepo -> RemoteRepo + localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name) + { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "") + } ------------------------------- -- Local field utils diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index 28f620a8e062346ab5879afd9c6936cd5156c693..7e02e3863a90203f18a0a1c4a3dcab56f25465b4 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -24,7 +24,7 @@ import Distribution.Client.Compat.Prelude import Prelude () import Distribution.Client.Types - ( RemoteRepo, AllowNewer(..), AllowOlder(..) + ( RemoteRepo, LocalRepo, AllowNewer(..), AllowOlder(..) , WriteGhcEnvironmentFilesPolicy ) import Distribution.Client.Dependency.Types ( PreSolver ) @@ -179,6 +179,7 @@ data ProjectConfigShared -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. projectConfigLocalRepos :: NubList FilePath, + projectConfigLocalNoIndexRepos :: NubList LocalRepo, projectConfigIndexState :: Flag IndexState, projectConfigStoreDir :: Flag FilePath, @@ -387,6 +388,7 @@ data SolverSettings = SolverSettings { solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. solverSettingLocalRepos :: [FilePath], + solverSettingLocalNoIndexRepos :: [LocalRepo], solverSettingConstraints :: [(UserConstraint, ConstraintSource)], solverSettingPreferences :: [PackageVersionConstraint], solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages @@ -446,6 +448,7 @@ data BuildTimeSettings buildSettingKeepTempFiles :: Bool, buildSettingRemoteRepos :: [RemoteRepo], buildSettingLocalRepos :: [FilePath], + buildSettingLocalNoIndexRepos :: [LocalRepo], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, buildSettingIgnoreExpiry :: Bool, diff --git a/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/Distribution/Client/ProjectPlanOutput.hs index aa94a511e27bb9a7973a2629f78d03c16d79819b..eab89cbd7f5af24d60abca50ab7bd452598131be 100644 --- a/cabal-install/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/Distribution/Client/ProjectPlanOutput.hs @@ -19,7 +19,7 @@ import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding.Types import Distribution.Client.DistDirLayout import Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId) -import Distribution.Client.PackageHash (showHashValue, hashValue) +import Distribution.Client.HashValue (showHashValue, hashValue) import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -203,6 +203,10 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = J.object [ "type" J..= J.String "local-repo" , "path" J..= J.String repoLocalDir ] + RepoLocalNoIndex{..} -> + J.object [ "type" J..= J.String "local-repo-no-index" + , "path" J..= J.String repoLocalDir + ] RepoRemote{..} -> J.object [ "type" J..= J.String "remote-repo" , "uri" J..= J.String (show (remoteRepoURI repoRemote)) diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 10b0556e455d7f8c853861f7450caec91b410726..d139379da0694aff9d224af0ce68a0cbb86956a7 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -70,6 +70,7 @@ module Distribution.Client.ProjectPlanning ( import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Client.HashValue import Distribution.Client.ProjectPlanning.Types as Ty import Distribution.Client.PackageHash import Distribution.Client.RebuildMonad diff --git a/cabal-install/Distribution/Client/Security/HTTP.hs b/cabal-install/Distribution/Client/Security/HTTP.hs index 30026577602bcb4cd42e5a8613a9d6889b4881fd..07896fa72b689d22b7ba7471e09bfee6b91c07b4 100644 --- a/cabal-install/Distribution/Client/Security/HTTP.hs +++ b/cabal-install/Distribution/Client/Security/HTTP.hs @@ -143,7 +143,7 @@ mkReqHeaders reqHeaders mRange = concat [ insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] insert x y = modifyAssocList x (++ y) - -- modify the first maching element + -- modify the first matching element modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] modifyAssocList a f = go where go [] = [] diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index b6de0f283338e6ef4a8e34534e08d57e4e4075c9..b063c03c80b82061c9d099ad6aa8401e9837ce1a 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -61,9 +61,9 @@ module Distribution.Client.Setup , liftOptions , yesNoOpt --TODO: stop exporting these: - , showRepo - , parseRepo - , readRepo + , showRemoteRepo + , parseRemoteRepo + , readRemoteRepo ) where import Prelude () @@ -73,6 +73,7 @@ import Distribution.Deprecated.ReadP (readP_to_E) import Distribution.Client.Types ( Username(..), Password(..), RemoteRepo(..) + , LocalRepo (..), emptyLocalRepo , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , WriteGhcEnvironmentFilesPolicy(..) ) @@ -420,7 +421,12 @@ globalCommand commands = CommandUI { option [] ["remote-repo"] "The name and url for a remote repository" globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) - (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList)) + (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) + + ,option [] ["local-no-index-repo"] + "The name and a path for a local no-index repository" + globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v }) + (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) ,option [] ["remote-repo-cache"] "The location where downloads from all remote repos are cached" @@ -2951,15 +2957,15 @@ parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse v | v == nullVersion -> Dependency (packageName p) anyVersion (Set.singleton LMainLibName) | otherwise -> Dependency (packageName p) (thisVersion v) (Set.singleton LMainLibName) -showRepo :: RemoteRepo -> String -showRepo repo = remoteRepoName repo ++ ":" +showRemoteRepo :: RemoteRepo -> String +showRemoteRepo repo = remoteRepoName repo ++ ":" ++ uriToString id (remoteRepoURI repo) [] -readRepo :: String -> Maybe RemoteRepo -readRepo = readPToMaybe parseRepo +readRemoteRepo :: String -> Maybe RemoteRepo +readRemoteRepo = readPToMaybe parseRemoteRepo -parseRepo :: Parse.ReadP r RemoteRepo -parseRepo = do +parseRemoteRepo :: Parse.ReadP r RemoteRepo +parseRemoteRepo = do name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") _ <- Parse.char ':' uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") @@ -2973,6 +2979,21 @@ parseRepo = do remoteRepoShouldTryHttps = False } +showLocalRepo :: LocalRepo -> String +showLocalRepo repo = localRepoName repo ++ ":" ++ localRepoPath repo + +readLocalRepo :: String -> Maybe LocalRepo +readLocalRepo = readPToMaybe parseLocalRepo + +parseLocalRepo :: Parse.ReadP r LocalRepo +parseLocalRepo = do + name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") + _ <- Parse.char ':' + path <- Parse.munch1 (const True) + return $ (emptyLocalRepo name) + { localRepoPath = path + } + -- ------------------------------------------------------------ -- * Helpers for Documentation -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index f8cc2557279b4765c877535b43bb777e7ac58ff6..aa2598480ac66e2c4c87e65100640763eafb4a5a 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -49,6 +49,7 @@ import Distribution.Types.LibraryName ( LibraryName(..) ) import Distribution.Client.SourceRepo ( SourceRepoMaybe ) +import Distribution.Client.HashValue (showHashValue, hashValue, truncateHash) import Distribution.Solver.Types.PackageIndex ( PackageIndex ) @@ -64,12 +65,14 @@ import Distribution.Solver.Types.SourcePackage import Distribution.Compat.Graph (IsNode(..)) import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Deprecated.ParseUtils (parseOptCommaList) -import Distribution.Simple.Utils (ordNub) +import Distribution.Simple.Utils (ordNub, toUTF8BS) import Distribution.Deprecated.Text (Text(..)) import Network.URI (URI(..), nullURI) import Control.Exception (Exception, SomeException) + import qualified Text.PrettyPrint as Disp +import qualified Data.ByteString.Lazy.Char8 as LBS newtype Username = Username { unUsername :: String } @@ -330,6 +333,34 @@ instance Structured RemoteRepo emptyRemoteRepo :: String -> RemoteRepo emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False +-- | /no-index/ style local repositories. +-- +-- https://github.com/haskell/cabal/issues/6359 +data LocalRepo = LocalRepo + { localRepoName :: String + , localRepoPath :: FilePath + , localRepoSharedCache :: Bool + } + deriving (Show, Eq, Ord, Generic) + +instance Binary LocalRepo +instance Structured LocalRepo + +-- | Construct a partial 'LocalRepo' value to fold the field parser list over. +emptyLocalRepo :: String -> LocalRepo +emptyLocalRepo name = LocalRepo name "" False + +-- | Calculate a cache key for local-repo. +-- +-- For remote repositories we just use name, but local repositories may +-- all be named "local", so we add a bit of `localRepoPath` into the +-- mix. +localRepoCacheKey :: LocalRepo -> String +localRepoCacheKey local = localRepoName local ++ "-" ++ hashPart where + hashPart + = showHashValue $ truncateHash 8 $ hashValue + $ LBS.fromStrict $ toUTF8BS $ localRepoPath local + -- | Different kinds of repositories -- -- NOTE: It is important that this type remains serializable. @@ -338,6 +369,14 @@ data Repo = RepoLocal { repoLocalDir :: FilePath } + + -- | Local repository, without index. + -- + -- https://github.com/haskell/cabal/issues/6359 + | RepoLocalNoIndex + { repoLocal :: LocalRepo + , repoLocalDir :: FilePath + } -- | Standard (unsecured) remote repositores | RepoRemote { @@ -364,14 +403,16 @@ instance Structured Repo -- | Check if this is a remote repo isRepoRemote :: Repo -> Bool -isRepoRemote RepoLocal{} = False -isRepoRemote _ = True +isRepoRemote RepoLocal{} = False +isRepoRemote RepoLocalNoIndex{} = False +isRepoRemote _ = True -- | Extract @RemoteRepo@ from @Repo@ if remote. maybeRepoRemote :: Repo -> Maybe RemoteRepo -maybeRepoRemote (RepoLocal _localDir) = Nothing -maybeRepoRemote (RepoRemote r _localDir) = Just r -maybeRepoRemote (RepoSecure r _localDir) = Just r +maybeRepoRemote (RepoLocal _localDir) = Nothing +maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing +maybeRepoRemote (RepoRemote r _localDir) = Just r +maybeRepoRemote (RepoSecure r _localDir) = Just r -- ------------------------------------------------------------ -- * Build results diff --git a/cabal-install/Distribution/Client/Update.hs b/cabal-install/Distribution/Client/Update.hs index 980e187dbe03315750df2e88ed09e35dd9b030c6..52bb1f76c96dd3d152c159d25dd3b5b90711b497 100644 --- a/cabal-install/Distribution/Client/Update.hs +++ b/cabal-install/Distribution/Client/Update.hs @@ -74,6 +74,7 @@ updateRepo verbosity updateFlags repoCtxt repo = do transport <- repoContextGetTransport repoCtxt case repo of RepoLocal{..} -> return () + RepoLocalNoIndex{..} -> return () RepoRemote{..} -> do downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir case downloadResult of diff --git a/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs index ca63d2d0c9f2beabeff21999f68e1502f48b2f58..47130a4e99fa0211a2361c76152d41f2868adff0 100644 --- a/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs +++ b/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs @@ -14,7 +14,7 @@ import Distribution.Types.MungedPackageName import Distribution.InstalledPackageInfo (InstalledPackageInfo) import GHC.Generics (Generic) --- | An 'InstSolverPackage' is a pre-existing installed pacakge +-- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver. data InstSolverPackage = InstSolverPackage { instSolverPkgIPI :: InstalledPackageInfo, diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 97017809fa14aa64d645d7b1ede271e6271d3b32..3dec72f03c72e7f74ab27b6666b7aa3e023799c8 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -177,6 +177,7 @@ executable cabal Distribution.Client.CmdInstall.ClientInstallFlags Distribution.Client.CmdRepl Distribution.Client.CmdRun + Distribution.Client.CmdRun.ClientRunFlags Distribution.Client.CmdTest Distribution.Client.CmdLegacy Distribution.Client.CmdSdist @@ -203,6 +204,7 @@ executable cabal Distribution.Client.Glob Distribution.Client.GlobalFlags Distribution.Client.Haddock + Distribution.Client.HashValue Distribution.Client.HttpUtils Distribution.Client.IndexUtils Distribution.Client.IndexUtils.Timestamp diff --git a/cabal-install/cabal-install.cabal.pp b/cabal-install/cabal-install.cabal.pp index 64552e485b40d16cd6e4f4501993a0a75be75a24..c133f97e965f8a98d84bc1dc7a4cb243bb82b356 100644 --- a/cabal-install/cabal-install.cabal.pp +++ b/cabal-install/cabal-install.cabal.pp @@ -108,6 +108,7 @@ Version: 3.2.0.0 Distribution.Client.CmdInstall.ClientInstallFlags Distribution.Client.CmdRepl Distribution.Client.CmdRun + Distribution.Client.CmdRun.ClientRunFlags Distribution.Client.CmdTest Distribution.Client.CmdLegacy Distribution.Client.CmdSdist @@ -134,6 +135,7 @@ Version: 3.2.0.0 Distribution.Client.Glob Distribution.Client.GlobalFlags Distribution.Client.Haddock + Distribution.Client.HashValue Distribution.Client.HttpUtils Distribution.Client.IndexUtils Distribution.Client.IndexUtils.Timestamp diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 62dc727418643caca9228d96fed9cf1bf1cfe320..ceada5bd7c2405a00e918f12d21bebd4bef3739d 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -459,6 +459,7 @@ instance Arbitrary ProjectConfigShared where <*> arbitrary <*> (toNubList <$> listOf arbitraryShortToken) <*> arbitrary + <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitraryConstraints <*> shortListOf 2 arbitrary @@ -485,6 +486,7 @@ instance Arbitrary ProjectConfigShared where , projectConfigHaddockIndex = x05 , projectConfigRemoteRepos = x06 , projectConfigLocalRepos = x07 + , projectConfigLocalNoIndexRepos = x07b , projectConfigIndexState = x08 , projectConfigConstraints = x09 , projectConfigPreferences = x10 @@ -513,6 +515,7 @@ instance Arbitrary ProjectConfigShared where , projectConfigHaddockIndex = x05' , projectConfigRemoteRepos = x06' , projectConfigLocalRepos = x07' + , projectConfigLocalNoIndexRepos = x07b' , projectConfigIndexState = x08' , projectConfigConstraints = postShrink_Constraints x09' , projectConfigPreferences = x10' @@ -534,13 +537,13 @@ instance Arbitrary ProjectConfigShared where , projectConfigProgPathExtra = x26' , projectConfigStoreDir = x27' } | ((x00', x01', x02', x03', x04'), - (x05', x06', x07', x08', x09'), + (x05', x06', x07', x07b', x08', x09'), (x10', x11', x12', x13', x14', x15'), (x16', x17', x18', x19', x20', x21'), x22', x23', x24', x25', x26', x27') <- shrink ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04), - (x05, x06, x07, x08, preShrink_Constraints x09), + (x05, x06, x07, x07b, x08, preShrink_Constraints x09), (x10, x11, x12, x13, x14, x15), (x16, x17, x18, x19, x20, x21), x22, x23, x24, x25, x26, x27) @@ -824,6 +827,12 @@ instance Arbitrary RemoteRepo where shortListOf1 5 (oneof [ choose ('0', '9') , choose ('a', 'f') ]) +instance Arbitrary LocalRepo where + arbitrary = LocalRepo + <$> arbitraryShortToken `suchThat` (not . (":" `isPrefixOf`)) + <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths + <*> arbitrary + instance Arbitrary UserConstraintScope where arbitrary = oneof [ UserQualified <$> arbitrary <*> arbitrary , UserAnySetupQualifier <$> arbitrary diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index a77e960affb6649435abe33ff7706c9763ceda12..a04eb105522e3986171d81a02a692d0f644f5fbc 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -61,6 +61,7 @@ instance ToExpr HaddockTarget instance ToExpr IndependentGoals instance ToExpr IndexState instance ToExpr InstallMethod +instance ToExpr LocalRepo instance ToExpr MinimizeConflictSet instance ToExpr OnlyConstrained instance ToExpr OptimisationLevel diff --git a/cabal-testsuite/PackageTests/Regression/T5309/memoized-tcm/costMatrix.h b/cabal-testsuite/PackageTests/Regression/T5309/memoized-tcm/costMatrix.h index a7f1bc25e82efe0266ddd21a85a397e58ba46122..db7cb6059b83dfd3a9ddc553c5cc4a594502c10d 100644 --- a/cabal-testsuite/PackageTests/Regression/T5309/memoized-tcm/costMatrix.h +++ b/cabal-testsuite/PackageTests/Regression/T5309/memoized-tcm/costMatrix.h @@ -139,7 +139,7 @@ class CostMatrix * the median for the two. Puts the median and alphabet size into retMedian, * which must therefore by necessity be allocated elsewhere. * - * This functin allocates _if necessary_. So freeing inputs after a call will not + * This function allocates _if necessary_. So freeing inputs after a call will not * cause invalid reads from the cost matrix. */ int getSetCostMedian(dcElement_t* left, dcElement_t* right, dcElement_t* retMedian); diff --git a/generics-sop-lens.hs b/generics-sop-lens.hs index 13e54923053aa347aa202e63ff6f3a4c4945764c..0710582a43335ec30cdbc4741922696f8ff4587e 100644 --- a/generics-sop-lens.hs +++ b/generics-sop-lens.hs @@ -38,7 +38,7 @@ genericLenses genericLenses p = case gdatatypeInfo p of Newtype _ _ _ -> "-- newtype deriving not implemented" ADT _ _ (Constructor _ :* Nil) -> "-- fieldnameless deriving not implemented" - ADT _ _ (Infix _ _ _ :* Nil) -> "-- infix consturctor deriving not implemented" + ADT _ _ (Infix _ _ _ :* Nil) -> "-- infix constructor deriving not implemented" ADT _ dn (Record _ fis :* Nil) -> unlines $ concatMap replaceTypes $ hcollapse $ hcmap (Proxy :: Proxy Typeable) derive fis where @@ -57,7 +57,7 @@ genericClassyLenses genericClassyLenses p = case gdatatypeInfo p of Newtype _ _ _ -> "-- newtype deriving not implemented" ADT _ _ (Constructor _ :* Nil) -> "-- fieldnameless deriving not implemented" - ADT _ _ (Infix _ _ _ :* Nil) -> "-- infix consturctor deriving not implemented" + ADT _ _ (Infix _ _ _ :* Nil) -> "-- infix constructor deriving not implemented" ADT _ dn (Record _ fis :* Nil) -> unlines $ concatMap replaceTypes $ [[ "class Has" ++ dn ++ " a where"